From cfbfe13f5b515ae2e3c6cdd97e2ccee03bc26e56 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Sun, 1 Feb 2009 00:54:40 +0100 Subject: Imported Upstream version 8.2~rc2+dfsg --- CHANGES | 117 +- COMPATIBILITY | 6 + COPYRIGHT | 8 +- INSTALL.doc | 11 +- Makefile | 4 +- Makefile.build | 78 +- Makefile.common | 71 +- Makefile.doc | 184 +- checker/check.ml | 4 +- checker/checker.ml | 13 +- checker/declarations.ml | 18 +- checker/declarations.mli | 6 +- checker/mod_checking.ml | 26 +- checker/modops.ml | 24 +- checker/subtyping.ml | 14 +- config/Makefile.template | 5 +- config/coq_config.mli | 12 +- configure | 157 +- contrib/cc/cctac.ml | 27 +- contrib/dp/dp_gappa.ml | 6 +- contrib/dp/dp_zenon.mll | 4 +- contrib/extraction/common.ml | 610 ++-- contrib/extraction/common.mli | 20 +- contrib/extraction/extract_env.ml | 287 +- contrib/extraction/extraction.ml | 26 +- contrib/extraction/g_extraction.ml4 | 23 + contrib/extraction/haskell.ml | 9 +- contrib/extraction/modutil.ml | 76 +- contrib/extraction/modutil.mli | 16 +- contrib/extraction/ocaml.ml | 142 +- contrib/extraction/scheme.ml | 4 +- contrib/extraction/table.ml | 158 +- contrib/extraction/table.mli | 14 +- contrib/firstorder/rules.ml | 4 +- contrib/fourier/Fourier.v | 8 +- contrib/fourier/fourier.ml | 4 +- contrib/funind/functional_principles_proofs.ml | 23 +- contrib/funind/functional_principles_types.ml | 32 +- contrib/funind/g_indfun.ml4 | 125 +- contrib/funind/indfun.ml | 4 +- contrib/funind/indfun_common.ml | 7 +- contrib/funind/invfun.ml | 8 +- contrib/funind/merge.ml | 4 +- contrib/funind/rawterm_to_relation.ml | 16 +- contrib/funind/recdef.ml | 8 +- contrib/interface/ascent.mli | 2 +- contrib/interface/blast.ml | 28 +- contrib/interface/centaur.ml4 | 22 +- contrib/interface/dad.ml | 2 +- contrib/interface/depends.ml | 6 +- contrib/interface/name_to_ast.ml | 8 +- contrib/interface/parse.ml | 4 +- contrib/interface/paths.ml | 2 +- contrib/interface/pbp.ml | 2 +- contrib/interface/showproof.ml | 3 +- contrib/interface/vtp.ml | 2 +- contrib/interface/xlate.ml | 114 +- contrib/jprover/README | 76 - contrib/jprover/jall.ml | 4599 ------------------------ contrib/jprover/jall.mli | 339 -- contrib/jprover/jlogic.ml | 106 - contrib/jprover/jlogic.mli | 40 - contrib/jprover/jprover.ml4 | 554 --- contrib/jprover/jterm.ml | 872 ----- contrib/jprover/jterm.mli | 110 - contrib/jprover/jtunify.ml | 507 --- contrib/jprover/jtunify.mli | 35 - contrib/jprover/opname.ml | 90 - contrib/jprover/opname.mli | 15 - contrib/micromega/coq_micromega.ml | 2 +- contrib/omega/OmegaLemmas.v | 43 +- contrib/omega/coq_omega.ml | 47 +- contrib/ring/ring.ml | 28 +- contrib/setoid_ring/Ring_base.v | 1 - contrib/setoid_ring/Ring_tac.v | 1 - contrib/setoid_ring/newring.ml4 | 11 +- contrib/subtac/equations.ml4 | 1149 ++++++ contrib/subtac/eterm.ml | 121 +- contrib/subtac/eterm.mli | 22 +- contrib/subtac/g_subtac.ml4 | 16 +- contrib/subtac/subtac.ml | 38 +- contrib/subtac/subtac_cases.ml | 4 +- contrib/subtac/subtac_classes.ml | 159 +- contrib/subtac/subtac_classes.mli | 10 +- contrib/subtac/subtac_coercion.ml | 59 +- contrib/subtac/subtac_coercion.mli | 3 + contrib/subtac/subtac_command.ml | 6 +- contrib/subtac/subtac_obligations.ml | 246 +- contrib/subtac/subtac_obligations.mli | 19 +- contrib/subtac/subtac_pretyping.ml | 4 +- contrib/subtac/subtac_pretyping_F.ml | 23 +- contrib/subtac/subtac_utils.ml | 7 +- contrib/subtac/subtac_utils.mli | 3 +- contrib/xml/cic2Xml.ml | 2 +- contrib/xml/cic2acic.ml | 10 +- contrib/xml/proofTree2Xml.ml4 | 4 +- contrib/xml/xmlcommand.ml | 29 +- dev/doc/changes.txt | 5 + dev/ocamldebug-coq.template | 4 +- dev/ocamlweb-doc/Makefile | 2 +- dev/top_printers.ml | 3 +- doc/stdlib/Library.tex | 4 +- doc/stdlib/index-list.html.template | 15 +- doc/stdlib/make-library-files | 6 +- ide/coq.ico | Bin 27574 -> 0 bytes ide/coq.ml | 13 +- ide/coqide.ml | 30 +- ide/highlight.mll | 19 +- ide/ideutils.ml | 7 +- ide/undo_lablgtk_ge212.mli | 36 + install.sh | 13 + interp/constrextern.ml | 83 +- interp/constrintern.ml | 640 ++-- interp/constrintern.mli | 29 +- interp/dumpglob.ml | 228 ++ interp/dumpglob.mli | 43 + interp/genarg.ml | 22 +- interp/genarg.mli | 19 +- interp/implicit_quantifiers.ml | 214 +- interp/implicit_quantifiers.mli | 33 +- interp/modintern.ml | 34 +- interp/modintern.mli | 5 +- interp/notation.ml | 18 +- interp/notation.mli | 4 +- interp/syntax_def.ml | 13 +- interp/syntax_def.mli | 10 +- interp/topconstr.ml | 111 +- interp/topconstr.mli | 32 +- kernel/declarations.ml | 8 +- kernel/declarations.mli | 8 +- kernel/indtypes.ml | 5 +- kernel/indtypes.mli | 3 +- kernel/inductive.ml | 5 +- kernel/mod_typing.ml | 115 +- kernel/modops.ml | 115 +- kernel/names.ml | 14 +- kernel/names.mli | 5 +- kernel/safe_typing.ml | 15 +- kernel/subtyping.ml | 16 +- kernel/univ.ml | 23 +- lib/envars.ml | 84 + lib/envars.mli | 15 + lib/flags.ml | 67 +- lib/flags.mli | 34 +- lib/option.ml | 6 +- lib/option.mli | 4 +- lib/system.ml | 45 +- lib/system.mli | 13 +- lib/util.ml | 150 +- lib/util.mli | 17 +- library/decl_kinds.ml | 17 +- library/decl_kinds.mli | 12 +- library/declaremods.ml | 145 +- library/impargs.ml | 10 +- library/impargs.mli | 8 +- library/lib.ml | 118 +- library/lib.mli | 118 +- library/libnames.ml | 26 +- library/libnames.mli | 3 +- library/libobject.ml | 7 +- library/library.ml | 130 +- library/library.mli | 6 +- parsing/argextend.ml4 | 26 +- parsing/egrammar.ml | 48 +- parsing/g_constr.ml4 | 64 +- parsing/g_ltac.ml4 | 19 +- parsing/g_prim.ml4 | 4 +- parsing/g_proofs.ml4 | 17 +- parsing/g_tactic.ml4 | 78 +- parsing/g_vernac.ml4 | 227 +- parsing/lexer.ml4 | 49 +- parsing/pcoq.ml4 | 5 +- parsing/pcoq.mli | 5 +- parsing/ppconstr.ml | 112 +- parsing/ppconstr.mli | 10 +- parsing/pptactic.ml | 59 +- parsing/ppvernac.ml | 172 +- parsing/prettyp.ml | 13 +- parsing/prettyp.mli | 4 +- parsing/printer.ml | 19 +- parsing/printmod.ml | 6 +- parsing/q_constr.ml4 | 4 +- parsing/q_coqast.ml4 | 44 +- parsing/search.ml | 17 +- parsing/search.mli | 9 +- parsing/vernacextend.ml4 | 5 +- pretyping/cases.ml | 9 +- pretyping/evarconv.ml | 25 +- pretyping/evarutil.ml | 170 +- pretyping/evarutil.mli | 13 +- pretyping/evd.ml | 9 +- pretyping/evd.mli | 10 +- pretyping/indrec.ml | 15 +- pretyping/indrec.mli | 5 +- pretyping/inductiveops.ml | 54 +- pretyping/inductiveops.mli | 7 +- pretyping/matching.ml | 268 +- pretyping/matching.mli | 42 +- pretyping/pretyping.ml | 39 +- pretyping/rawterm.ml | 4 +- pretyping/recordops.ml | 19 +- pretyping/recordops.mli | 13 +- pretyping/reductionops.ml | 40 +- pretyping/retyping.ml | 28 +- pretyping/retyping.mli | 4 +- pretyping/tacred.ml | 155 +- pretyping/termops.ml | 43 +- pretyping/termops.mli | 16 +- pretyping/typeclasses.ml | 109 +- pretyping/typeclasses.mli | 22 +- pretyping/unification.ml | 189 +- pretyping/vnorm.ml | 19 +- proofs/clenvtac.ml | 36 +- proofs/clenvtac.mli | 6 +- proofs/logic.ml | 190 +- proofs/logic.mli | 3 +- proofs/pfedit.ml | 10 +- proofs/pfedit.mli | 9 +- proofs/proof_type.ml | 3 +- proofs/proof_type.mli | 3 +- proofs/redexpr.ml | 21 +- proofs/refiner.ml | 4 +- proofs/refiner.mli | 3 +- proofs/tacexpr.ml | 26 +- proofs/tacmach.ml | 5 +- proofs/tacmach.mli | 3 +- proofs/tactic_debug.ml | 8 +- proofs/tactic_debug.mli | 4 +- scripts/coqc.ml | 60 +- scripts/coqmktop.ml | 133 +- tactics/auto.ml | 574 +-- tactics/auto.mli | 52 +- tactics/class_tactics.ml4 | 872 +++-- tactics/decl_interp.ml | 8 +- tactics/decl_proof_instr.ml | 10 +- tactics/decl_proof_instr.mli | 2 +- tactics/dhyp.ml | 5 +- tactics/eauto.ml4 | 36 +- tactics/elim.ml | 4 +- tactics/equality.ml | 169 +- tactics/equality.mli | 12 +- tactics/evar_tactics.ml | 4 +- tactics/evar_tactics.mli | 3 +- tactics/extraargs.ml4 | 21 +- tactics/extraargs.mli | 10 +- tactics/extratactics.ml4 | 103 +- tactics/hiddentac.ml | 15 +- tactics/hiddentac.mli | 9 +- tactics/hipattern.ml4 | 173 +- tactics/hipattern.mli | 22 +- tactics/inv.ml | 40 +- tactics/refine.ml | 6 +- tactics/setoid_replace.ml | 2023 ----------- tactics/setoid_replace.mli | 85 - tactics/tacinterp.ml | 329 +- tactics/tacinterp.mli | 12 +- tactics/tacticals.ml | 44 +- tactics/tacticals.mli | 10 +- tactics/tactics.ml | 710 ++-- tactics/tactics.mli | 43 +- tactics/tauto.ml4 | 166 +- test-suite/bugs/closed/shouldfail/1898.v | 5 + test-suite/bugs/closed/shouldsucceed/121.v | 2 +- test-suite/bugs/closed/shouldsucceed/1791.v | 38 + test-suite/bugs/closed/shouldsucceed/1891.v | 13 + test-suite/bugs/closed/shouldsucceed/1900.v | 8 + test-suite/bugs/closed/shouldsucceed/1901.v | 11 + test-suite/bugs/closed/shouldsucceed/1907.v | 7 + test-suite/bugs/closed/shouldsucceed/1918.v | 377 ++ test-suite/bugs/closed/shouldsucceed/1925.v | 22 + test-suite/bugs/closed/shouldsucceed/1931.v | 29 + test-suite/bugs/closed/shouldsucceed/1935.v | 21 + test-suite/bugs/closed/shouldsucceed/1963.v | 19 + test-suite/bugs/closed/shouldsucceed/1977.v | 4 + test-suite/bugs/closed/shouldsucceed/1981.v | 5 + test-suite/bugs/closed/shouldsucceed/2001.v | 20 + test-suite/bugs/closed/shouldsucceed/2017.v | 15 + test-suite/bugs/closed/shouldsucceed/2021.v | 23 + test-suite/bugs/closed/shouldsucceed/2027.v | 11 + test-suite/check | 4 +- test-suite/complexity/autodecomp.v | 11 + test-suite/failure/Reordering.v | 5 + test-suite/failure/guard.v | 11 + test-suite/output/ArgumentsScope.v | 12 +- test-suite/output/Cases.out | 2 + test-suite/output/Cases.v | 13 + test-suite/output/Notations.out | 7 + test-suite/output/Notations.v | 30 + test-suite/success/Equations.v | 321 ++ test-suite/success/Generalization.v | 13 + test-suite/success/Inversion.v | 8 + test-suite/success/Notations.v | 5 + test-suite/success/Record.v | 81 +- test-suite/success/Reordering.v | 15 + test-suite/success/apply.v | 53 + test-suite/success/dependentind.v | 87 +- test-suite/success/guard.v | 11 + test-suite/success/refine.v | 5 + test-suite/success/rewrite_iterated.v | 30 + test-suite/success/setoid_test.v | 14 + test-suite/success/simpl.v | 23 + test-suite/success/unicode_utf8.v | 102 +- theories/Arith/Div2.v | 64 +- theories/Arith/Even.v | 158 +- theories/Arith/Max.v | 6 +- theories/Classes/EquivDec.v | 56 +- theories/Classes/Equivalence.v | 40 +- theories/Classes/Functions.v | 19 +- theories/Classes/Init.v | 14 +- theories/Classes/Morphisms.v | 140 +- theories/Classes/Morphisms_Prop.v | 37 +- theories/Classes/Morphisms_Relations.v | 10 +- theories/Classes/RelationClasses.v | 116 +- theories/Classes/SetoidAxioms.v | 9 +- theories/Classes/SetoidClass.v | 66 +- theories/Classes/SetoidDec.v | 35 +- theories/Classes/SetoidTactics.v | 8 +- theories/FSets/FMapFacts.v | 1276 +++++-- theories/FSets/FMapInterface.v | 10 +- theories/FSets/FMapList.v | 4 +- theories/FSets/FMapPositive.v | 86 +- theories/FSets/FSetAVL.v | 10 +- theories/FSets/FSetBridge.v | 13 +- theories/FSets/FSetDecide.v | 49 +- theories/FSets/FSetEqProperties.v | 47 +- theories/FSets/FSetFacts.v | 48 +- theories/FSets/FSetFullAVL.v | 10 +- theories/FSets/FSetInterface.v | 35 +- theories/FSets/FSetList.v | 10 +- theories/FSets/FSetProperties.v | 566 +-- theories/FSets/FSetToFiniteSet.v | 12 +- theories/FSets/FSetWeakList.v | 57 +- theories/FSets/OrderedType.v | 35 +- theories/FSets/OrderedTypeAlt.v | 11 +- theories/FSets/OrderedTypeEx.v | 24 +- theories/Init/Datatypes.v | 30 +- theories/Init/Logic.v | 18 +- theories/Init/Peano.v | 38 +- theories/Init/Tactics.v | 46 +- theories/Lists/SetoidList.v | 209 +- theories/Logic/ClassicalDescription.v | 4 +- theories/Logic/ClassicalFacts.v | 4 +- theories/Logic/Decidable.v | 9 +- theories/Logic/DecidableTypeEx.v | 24 +- theories/Logic/Diaconescu.v | 4 +- theories/Logic/EqdepFacts.v | 10 +- theories/Logic/FunctionalExtensionality.v | 60 + theories/NArith/BinNat.v | 6 +- theories/NArith/Ndigits.v | 289 +- theories/Numbers/Integer/Abstract/ZBase.v | 8 +- theories/Numbers/Integer/Abstract/ZDomain.v | 4 +- theories/Numbers/Integer/Abstract/ZMulOrder.v | 6 +- theories/Numbers/Integer/BigZ/BigZ.v | 4 +- theories/Numbers/Integer/BigZ/ZMake.v | 3 +- theories/Numbers/Integer/NatPairs/ZNatPairs.v | 6 +- theories/Numbers/NatInt/NZBase.v | 4 +- theories/Numbers/NatInt/NZOrder.v | 4 +- theories/Numbers/Natural/Abstract/NAdd.v | 4 +- theories/Numbers/Natural/Abstract/NBase.v | 10 +- theories/Numbers/Natural/Abstract/NDefOps.v | 4 +- theories/Numbers/Natural/Abstract/NStrongRec.v | 8 +- theories/Numbers/Natural/BigN/BigN.v | 4 +- theories/Numbers/Natural/BigN/NMake_gen.ml | 3 +- theories/Numbers/NumPrelude.v | 6 +- theories/Program/Basics.v | 18 +- theories/Program/Combinators.v | 16 +- theories/Program/Equality.v | 325 +- theories/Program/FunctionalExtensionality.v | 109 - theories/Program/Program.v | 9 + theories/Program/Subset.v | 5 +- theories/Program/Syntax.v | 24 +- theories/Program/Tactics.v | 52 +- theories/Program/Utils.v | 4 +- theories/Program/Wf.v | 207 +- theories/QArith/Qpower.v | 2 +- theories/Relations/Operators_Properties.v | 334 +- theories/Relations/Relation_Operators.v | 132 +- theories/Setoids/Setoid.v | 61 +- theories/Setoids/Setoid_Prop.v | 79 - theories/Setoids/Setoid_tac.v | 595 --- theories/ZArith/Zdiv.v | 89 +- theories/ZArith/auxiliary.v | 42 +- tools/beautify-archive | 52 + tools/coq_makefile.ml4 | 441 ++- tools/coqdep.ml | 26 +- tools/coqdoc/cdglobals.ml | 3 +- tools/coqdoc/coqdoc.css | 38 +- tools/coqdoc/coqdoc.sty | 104 +- tools/coqdoc/index.mli | 4 +- tools/coqdoc/index.mll | 48 +- tools/coqdoc/main.ml | 24 +- tools/coqdoc/output.ml | 365 +- tools/coqdoc/output.mli | 4 +- tools/coqdoc/pretty.mll | 113 +- toplevel/auto_ind_decl.ml | 12 +- toplevel/classes.ml | 343 +- toplevel/classes.mli | 27 +- toplevel/command.ml | 166 +- toplevel/command.mli | 12 +- toplevel/coqinit.ml | 27 +- toplevel/coqtop.ml | 58 +- toplevel/himsg.ml | 92 +- toplevel/metasyntax.ml | 65 +- toplevel/metasyntax.mli | 6 +- toplevel/mltop.ml4 | 100 +- toplevel/mltop.mli | 19 +- toplevel/protectedtoplevel.ml | 9 +- toplevel/record.ml | 186 +- toplevel/record.mli | 17 +- toplevel/toplevel.ml | 10 +- toplevel/usage.ml | 19 +- toplevel/usage.mli | 7 +- toplevel/vernac.ml | 72 +- toplevel/vernacentries.ml | 289 +- toplevel/vernacexpr.ml | 131 +- 415 files changed, 15482 insertions(+), 18445 deletions(-) delete mode 100644 contrib/jprover/README delete mode 100644 contrib/jprover/jall.ml delete mode 100644 contrib/jprover/jall.mli delete mode 100644 contrib/jprover/jlogic.ml delete mode 100644 contrib/jprover/jlogic.mli delete mode 100644 contrib/jprover/jprover.ml4 delete mode 100644 contrib/jprover/jterm.ml delete mode 100644 contrib/jprover/jterm.mli delete mode 100644 contrib/jprover/jtunify.ml delete mode 100644 contrib/jprover/jtunify.mli delete mode 100644 contrib/jprover/opname.ml delete mode 100644 contrib/jprover/opname.mli create mode 100644 contrib/subtac/equations.ml4 delete mode 100644 ide/coq.ico create mode 100644 ide/undo_lablgtk_ge212.mli create mode 100755 install.sh create mode 100644 interp/dumpglob.ml create mode 100644 interp/dumpglob.mli create mode 100644 lib/envars.ml create mode 100644 lib/envars.mli delete mode 100644 tactics/setoid_replace.ml delete mode 100644 tactics/setoid_replace.mli create mode 100644 test-suite/bugs/closed/shouldfail/1898.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1791.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1891.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1900.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1901.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1907.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1918.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1925.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1931.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1935.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1963.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1977.v create mode 100644 test-suite/bugs/closed/shouldsucceed/1981.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2001.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2017.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2021.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2027.v create mode 100644 test-suite/complexity/autodecomp.v create mode 100644 test-suite/failure/Reordering.v create mode 100644 test-suite/success/Equations.v create mode 100644 test-suite/success/Generalization.v create mode 100644 test-suite/success/Reordering.v create mode 100644 test-suite/success/guard.v create mode 100644 test-suite/success/rewrite_iterated.v create mode 100644 theories/Logic/FunctionalExtensionality.v delete mode 100644 theories/Program/FunctionalExtensionality.v delete mode 100644 theories/Setoids/Setoid_Prop.v delete mode 100644 theories/Setoids/Setoid_tac.v create mode 100755 tools/beautify-archive diff --git a/CHANGES b/CHANGES index a789796c..035579cd 100644 --- a/CHANGES +++ b/CHANGES @@ -13,13 +13,14 @@ Language arguments in terms. - Sort of Record/Structure, Inductive and CoInductive defaults to Type if omitted. -- Record/Structure now usable for defining coinductive types - (e.g. "Record stream := { hd : nat; tl : stream }.") +- Support for optional "where" notation clauses for record fields. +- (Co)Inductive types can be defined as records + (e.g. "CoInductive stream := { hd : nat; tl : stream }.") - New syntax "Theorem id1:t1 ... with idn:tn" for proving mutually dependent statements. - Support for sort-polymorphism on constants denoting inductive types. - Several evolutions of the module system (handling of module aliases, - functorial module types, an Include feature, etc). (TODO: Say more!) + functorial module types, an Include feature, etc). - Prop now a subtype of Set (predicative and impredicative forms). - Recursive inductive types in Prop with a single constructor of which all arguments are in Prop is now considered to be a singleton @@ -27,6 +28,10 @@ Language As a consequence, Acc_rect has now a more direct proof [possible source of easily fixed incompatibility in case of manual definition of a recursor in a recursive singleton inductive type]. +- New syntax to do implicit generalization in binders and inside terms. +- New tentative syntax for introduction of record objects without mentioning + the constructor {| field := body; ... |}, turning missing fields into holes + (compatible with refine and Program). Vernacular commands @@ -55,12 +60,28 @@ Vernacular commands conversion tests. It generalizes commands Opaque and Transparent by introducing a range of levels. Lower levels are assigned to constants that should be expanded first. +- New options Global and Local to Opaque and Transparent. - New command "Print Assumptions" to display all variables, parameters or axioms a theorem or definition relies on. - "Add Rec LoadPath" now provides references to libraries using partially qualified names (this holds also for coqtop/coqc option -R). +- SearchAbout supports negated search criteria, reference to logical objects + by their notation, and more generally search of subterms. +- "Declare ML Module" now allows to import .cmxs files when Coq is + compiled in native code with a version of OCaml that supports native + Dynlink (>= 3.11). +- New command "Create HintDb name [discriminated]" to explicitely declare + a new hint database and optionaly turn on a discrimination net + implementation to index all the lemmas in the database. +- New commands "Hint Transparent" and "Hint Opaque" to set the unfolding + status of definitions used by auto. This information is taken into account + by the discrimination net and the unification algorithm. +- "Hint Extern" now takes an optional pattern and applies the given tactic + all the time if no pattern is given. +- Specific sort constraints on Record now taken into account. +- "Print LoadPath" supports a path argument to filter the display. -Libraries (DOC TO CHECK) +Libraries - Several parts of the libraries are now in Type, in particular FSets, SetoidList, ListSet, Sorting, Zmisc. This may induce a few @@ -93,6 +114,11 @@ Libraries (DOC TO CHECK) thanks to new features of Coq modules (in particular Include), see FSetInterface. Same for maps. Hints in these interfaces have been reworked (they are now placed in a "set" database). + * To allow full subtyping between weak and ordered sets, a field + "eq_dec" has been added to OrderedType. The old version of OrderedType + is now called MiniOrderedType and functor MOT_to_OT allow to + convert to the new version. The interfaces and implementations + of sets now contain also such a "eq_dec" field. * FSetDecide, contributed by Aaron Bohannon, contains a decision procedure allowing to solve basic set-related goals (for instance, is a point in a particular set ?). See FSetProperties for examples. @@ -155,7 +181,9 @@ Libraries (DOC TO CHECK) - Definition of pred and minus made compatible with the structural decreasing criterion for use in fixpoints. - Files Relations/Rstar.v and Relations/Newman.v moved out to the user - contribution repository (contribution CoC_History). + contribution repository (contribution CoC_History). New lemmas about + transitive closure added and some bound variables renamed (exceptional + risk of incompatibilities). Notations, coercions, implicit arguments and type inference @@ -163,17 +191,16 @@ Notations, coercions, implicit arguments and type inference pattern-matching problems. - Experimental allowance for omission of the clauses easily detectable as impossible in pattern-matching problems. -- Improved inference of implicit arguments. +- Improved inference of implicit arguments, now working inside record + declarations. - New options "Set Maximal Implicit Insertion", "Set Reversible Pattern Implicit", "Set Strongly Strict Implicit" and "Set Printing Implicit Defensive" for controlling inference and use of implicit arguments. - New modifier in "Implicit Arguments" to force an implicit argument to be maximally inserted. -- New modifier of "Implicit Arguments" to enrich the set of implicit arguments. - (DOC TODO?) - New options Global and Local to "Implicit Arguments" for section surviving or non export outside module. -- Level "constr" moved from 9 to 8. (DOC TODO?) +- Level "constr" moved from 9 to 8. - Structure/Record now printed as Record (unless option Printing All is set). - Support for parametric notations defining constants. - Insertion of coercions below product types refrains to unfold @@ -184,6 +211,8 @@ Tactic Language - Second-order pattern-matching now working in Ltac "match" clauses (syntax for second-order unification variable is "@?X"). +- Support for matching on let bindings in match context using syntax + "H := body" or "H := body : type". - (?X ?Y) patterns now match any application instead of only unary applications (possible source of incompatibility). - Ltac accepts integer arguments (syntax is "ltac:nnn" for nnn an integer). @@ -192,7 +221,7 @@ Tactic Language or just "..". Also, n can be different from the number of subgoals generated by expr_0. In this case, the value of expr (or idtac in case of just "..") is applied to the intermediate subgoals to make - the number of tactics equal to the number of subgoals. (DOC TODO) + the number of tactics equal to the number of subgoals. - A name used as the name of the parameter of a lemma (like f in "apply f_equal with (f:=t)") is now interpreted as a ltac variable if such a variable exists (this is a possible source of @@ -206,12 +235,19 @@ Tactic Language "let ... in ..." into a lazy one. - Patterns for hypotheses types in "match goal" are now interpreted in type_scope. +- A bound variable whose name is not used elsewhere now serves as + metavariable in "match" and it gets instantiated by an identifier + (allow e.g. to extract the name of a statement like "exists x, P x"). - New printing of Ltac call trace for better debugging. +- The C-zar (formerly know as declarative) proof language is now properly + documented. Tactics - New tactics "apply -> term", "apply <- term", "apply -> term in - ident", "apply <- term in ident" for applying equivalences (iff). (DOC TODO) + ident", "apply <- term in ident" for applying equivalences (iff). +- "apply" and "rewrite" now take open terms (terms with undefined existentials) + as input. - Slight improvement of the hnf and simpl tactics when applied on expressions with explicit occurrences of match or fix. - New tactics "eapply in", "erewrite", "erewrite in". @@ -230,6 +266,7 @@ Tactics to remember the term to which the induction or case analysis applied (possible source of parsing incompatibilities when destruct or induction is part of a let-in expression in Ltac; extra parentheses are then required). +- New support for "as" clause in tactics "apply in" and "eapply in". - Some new intro patterns: * intro pattern "?A" genererates a fresh name based on A. Caveat about a slight loss of compatibility: @@ -238,7 +275,7 @@ Tactics is still legal but equivalent to intros ?a ?b. * intro pattern "(A & ... & Y & Z)" synonym to "(A,....,(Y,Z)))))" for right-associative constructs like /\ or exists. -- Several syntax extensions concerning "rewrite": (DOC TODO) +- Several syntax extensions concerning "rewrite": * "rewrite A,B,C" can be used to rewrite A, then B, then C. These rewrites occur only on the first subgoal: in particular, side-conditions of the "rewrite A" are not concerned by the "rewrite B,C". @@ -258,21 +295,21 @@ Tactics - New syntax "rename a into b, c into d" for "rename a into b; rename c into d" - New tactics "dependent induction/destruction H [ generalizing id_1 .. id_n ]" to do induction-inversion on instantiated inductive families à la BasicElim. -- Tactic "apply" now able to reason modulo unfolding of constants - (possible source of incompatibility in situations where apply may fail, - e.g. as argument of a try or a repeat and in a ltac function); - version of apply that does not unfold is renamed into "simple apply" - (usable for compatibility or for automation). -- Tactic "apply" now able to traverse conjunctions and to select the first - matching lemma among the components of the conjunction; tactic apply also - able to apply lemmas of conclusion an empty type. +- Tactics "apply" and "apply in" now able to reason modulo unfolding of + constants (possible source of incompatibility in situations where apply + may fail, e.g. as argument of a try or a repeat and in a ltac function); + versions that do not unfold are renamed into "simple apply" and + "simple apply in" (usable for compatibility or for automation). +- Tactics "apply" and "apply in" now able to traverse conjunctions and to + select the first matching lemma among the components of the conjunction; + tactic "apply" also able to apply lemmas of conclusion an empty type. - Tactic "apply" now supports application of several lemmas in a row. - Tactics "set" and "pose" can set functions using notation "(f x1..xn := c)". - New tactic "instantiate" (without argument). - Tactic firstorder "with" and "using" options have their meaning swapped for consistency with auto/eauto (source of incompatibility). - Tactic "generalize" now supports "at" options to specify occurrences - and "as" options to name the hypothesis. + and "as" options to name the quantified hypotheses. - New tactic "specialize H with a" or "specialize (H a)" allows to transform in-place a universally-quantified hypothesis (H : forall x, T x) into its instantiated form (H : T a). Nota: "specialize" was in fact there in earlier @@ -295,6 +332,8 @@ Tactics occurrences of a term. - Tactic "pose proof" supports name overwriting in case of specialization of an hypothesis. +- Semi-decision tactic "jp" for first-order intuitionistic logic moved to user + contributions (subsumed by "firstorder"). Program @@ -321,8 +360,8 @@ Type Classes - New "Class", "Instance" and "Program Instance" commands to define classes and instances documented in the reference manual. -- New binding construct " [ Class_1 param_1 .. param_n, Class_2 ... ] " - for binding type classes, usable everywhere. +- New binding construct "`{Class_1 param_1 .. param_n, Class_2 ...}" + for binding type classes, usable everywhere. - New command " Print Classes " and " Print Instances some_class " to print tables for typeclasses. - New default eauto hint database "typeclass_instances" used by the default @@ -346,10 +385,9 @@ Setoid rewriting Their introduction may break existing scripts that defined them as notations with different levels. - - One needs to use [Typeclasses unfold [cst]] if [cst] is used - as an abbreviation hiding products in types of morphisms, - e.g. if ones redefines [relation] and declares morphisms - whose type mentions [relation]. + - One can use [Typeclasses Opaque/Transparent [cst]] to indicate + that [cst] should not be unfolded during unification for morphism + resolution, by default all constants are transparent. - The [setoid_rewrite]'s semantics change when rewriting with a lemma: it can rewrite two different instantiations of the lemma @@ -369,12 +407,12 @@ Setoid rewriting new [Add Parametric] commands, documented in the manual. - Setoid_Theory is now an alias to Equivalence, scripts building objects - of type Setoid_Theory need to unfold (or "red") the definitions + of type Setoid_Theory need to unfold (or [red]) the definitions of Reflexive, Symmetric and Transitive in order to get the same goals as before. Scripts which introduced variables explicitely will not break. - The order of subgoals when doing [setoid_rewrite] with side-conditions - is always the same: first the new goal, then the conditions. + is now always the same: first the new goal, then the conditions. - New standard library modules Classes.Morphisms declares standard morphisms on refl/sym/trans relations. @@ -406,6 +444,9 @@ Extraction possible if several branches are identical. For instance, functions corresponding to decidability of equalities are now linear instead of quadratic. +- A new instruction Extraction Blacklist id1 .. idn allows to prevent filename + conflits with existing code, for instance when extracting module List + to Ocaml. CoqIDE @@ -425,6 +466,19 @@ Tools - New coqtop/coqc option -exclude-dir to exclude subdirs for option -R. - The binary "parser" has been renamed to "coq-parser". +coqdoc +- Improved coqdoc and dump of globalization information to give more + meta-information on identifiers. All categories of Coq definitions are + supported, which makes typesetting trivial in the generated documentation. +- A "--interpolate" option permits to use typesetting information from the + typechecked part of the file to typeset identifiers appearing in Coq escapings + inside the documentation. +- Better handling of utf8 ("--utf8" option) and respect of spaces in the source. +- Support for hyperlinking and indexing developments in the TeX output. +- New option "color" of the coqdoc style file to render identifiers using colors. +- Additional macros in the TeX ouput allowing to customize indentation and size of + empty lines. New environment "coqdoccode" for Coq code. + Miscellaneous - Coq installation provides enough files so that Ocaml's extensions need not @@ -572,7 +626,7 @@ Tactics juste a simple hypothesis name. For instance: rewrite H in H1,H2 |- * means rewrite H in H1; rewrite H in H2; rewrite H rewrite H in * |- will do try rewrite H in Hi for all hypothesis Hi <> H. -- Added "dependent rewrite term" and "dependent rewrite term in hyp" (doc TODO) +- Added "dependent rewrite term" and "dependent rewrite term in hyp". - Added "autorewrite with ... in hyp [using ...]". - Tactic "replace" now accepts a "by" tactic clause. - Added "clear - id" to clear all hypotheses except the ones depending in id. @@ -851,8 +905,7 @@ Vernacular commands - "Declare ML Module" now allows to import .cma files. This avoids to use a bunch of "Declare ML Module" statements when using several ML files. -- "Set Printing Width n" added, allows to change the size of width printing - (TODO : doc). +- "Set Printing Width n" added, allows to change the size of width printing. - "Implicit Variables Type x,y:t" (new syntax: "Implicit Types x y:t") assigns default types for binding variables. - Declarations of Hints and Notation now accept a "Local" flag not to diff --git a/COMPATIBILITY b/COMPATIBILITY index d85a5f3f..30f5daf8 100644 --- a/COMPATIBILITY +++ b/COMPATIBILITY @@ -13,6 +13,9 @@ Tactics - Add Relation and Add Morphism on polymorphic relations should now be declared with Add Parametric Relation and Add Parametric Morphism. +- The constant [flip] is automatically unfolded in the goals generated by + Add Morphism (incompatibility with 8.2 beta versions). + - The default relation chosen by setoid_replace may differ. The workaround is to enforce the choice of the setoid relation with the "using relation ..." option. @@ -48,6 +51,9 @@ Tactics Language +- Type Class syntax has completely since the 8.2beta versions. See the + documentation for the updated syntax. + - Constants hidding polymorphic inductive types are now polymorphic themselves. This may exceptionally affect the naming of introduction hypotheses if such an inductive type in Type is used on diff --git a/COPYRIGHT b/COPYRIGHT index 2cbb6fbc..7ed31f15 100644 --- a/COPYRIGHT +++ b/COPYRIGHT @@ -20,12 +20,6 @@ parsing/search.ml) Loïc Pottier, Lemme, INRIA Sophia-Antipolis (contrib/fourier) Claudio Sacerdoti Coen, HELM, University of Bologna, (contrib/xml) -Coq includes a tactic Jp based on JProver, a theorem prover for -first-order intuitionistic logic. Jprover was originally implemented -by Stephan Schmitt and then integrated into MetaPRL by Aleksey -Nogin. After this, Huang extracted the necessary ML-codes from MetaPRL -and then integrated it into Coq. - The file CREDITS contains a list of past contributors The credits section in Reference Manual introduction details contributions. @@ -38,4 +32,4 @@ The Coq development Team (march 2004) Pierre Letouzey (Université Paris Sud) Claude Marché (Université Paris Sud-INRIA) Christine Paulin (Université Paris Sud) - Clément Renard (INRIA) \ No newline at end of file + Clément Renard (INRIA) diff --git a/INSTALL.doc b/INSTALL.doc index 3eb72e08..96918b49 100644 --- a/INSTALL.doc +++ b/INSTALL.doc @@ -33,6 +33,15 @@ To produce the html documents, the following tools are needed: - hevea (e.g. 1.07 works) + +Under Debian based operating systems (Debian, Ubuntu, ...) a +working set of packages for compiling the documentation for Coq is: + + texlive texlive-latex-extra texlive-math-extra texlive-fonts-extra + texlive-lang-french texlive-humanities texlive-pictures latex-xcolor + hevea netpbm + + Compilation ----------- @@ -75,7 +84,7 @@ To install all produced documents, do: make DOCDIR=/some/directory/for/documentation install-doc -DOCDIR defauts to /usr/share/doc/coq-x.y were x.y is the version number +DOCDIR defauts to /usr/share/doc/coq diff --git a/Makefile b/Makefile index 1eb7dc85..70e9fb1f 100644 --- a/Makefile +++ b/Makefile @@ -6,7 +6,7 @@ # # GNU Lesser General Public License Version 2.1 # ####################################################################### -# $Id: Makefile 11387 2008-09-07 21:59:11Z glondu $ +# $Id: Makefile 11826 2009-01-22 06:43:35Z notin $ # Makefile for Coq @@ -32,6 +32,8 @@ export FIND_VCS_CLAUSE:='(' \ -name 'debian' -or \ -name "$${GIT_DIR}" \ ')' -prune -type f -or +export PRUNE_CHECKER := -wholename ./checker/\* -prune -or + FIND_PRINTF_P:=-print | sed 's|^\./||' export YACCFILES:=$(shell find . $(FIND_VCS_CLAUSE) '(' -name '*.mly' ')' $(FIND_PRINTF_P)) diff --git a/Makefile.build b/Makefile.build index b8d27b22..0d0125ca 100644 --- a/Makefile.build +++ b/Makefile.build @@ -6,7 +6,7 @@ # # GNU Lesser General Public License Version 2.1 # ####################################################################### -# $Id: Makefile.build 11383 2008-09-07 16:35:13Z glondu $ +# $Id: Makefile.build 11858 2009-01-26 13:27:23Z notin $ # Makefile for Coq @@ -34,11 +34,13 @@ endif NOARG: world # build and install the three subsystems: coq, coqide, pcoq -world: revision coq coqide pcoq - ifeq ($(WITHDOC),all) +world: revision coq coqide pcoq doc + install: install-coq install-coqide install-pcoq install-doc else +world: revision coq coqide pcoq + install: install-coq install-coqide install-pcoq endif @@ -67,8 +69,7 @@ LOCALINCLUDES=-I config -I tools -I tools/coqdoc \ -I contrib/omega -I contrib/romega -I contrib/micromega \ -I contrib/ring -I contrib/dp -I contrib/setoid_ring \ -I contrib/xml -I contrib/extraction \ - -I contrib/interface -I contrib/fourier \ - -I contrib/jprover -I contrib/cc \ + -I contrib/interface -I contrib/fourier -I contrib/cc \ -I contrib/funind -I contrib/firstorder \ -I contrib/field -I contrib/subtac -I contrib/rtauto @@ -174,12 +175,12 @@ states:: states/initial.coq $(COQTOPOPT): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(COQMKTOP) -opt $(OPTFLAGS) -o $@ + $(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) -o $@ $(STRIP) $@ $(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(COQMKTOP) -top $(BYTEFLAGS) -o $@ + $(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@ $(COQTOPEXE): $(ORDER_ONLY_SEP) $(BESTCOQTOP) cd bin; ln -sf coqtop.$(BEST)$(EXE) coqtop$(EXE) @@ -191,12 +192,12 @@ CHKOPTFLAGS:=$(CHKLIBS) $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) $(CHICKENOPT): checker/check.cmxa checker/main.ml $(SHOW)'OCAMLOPT -o $@' - $(HIDE)$(OCAMLOPT) $(CHKOPTFLAGS) -o $@ unix.cmxa gramlib.cmxa checker/check.cmxa checker/main.ml + $(HIDE)$(OCAMLOPT) $(CHKOPTFLAGS) -o $@ str.cmxa unix.cmxa gramlib.cmxa $^ $(STRIP) $@ $(CHICKENBYTE): checker/check.cma checker/main.ml $(SHOW)'OCAMLC -o $@' - $(HIDE)$(OCAMLC) $(CHKBYTEFLAGS) -o $@ unix.cma gramlib.cma checker/check.cma checker/main.ml + $(HIDE)$(OCAMLC) $(CHKBYTEFLAGS) -o $@ str.cma unix.cma gramlib.cma $^ $(CHICKEN): $(ORDER_ONLY_SEP) $(BESTCHICKEN) cd bin && ln -sf coqchk.$(BEST)$(EXE) coqchk$(EXE) @@ -205,13 +206,13 @@ $(CHICKEN): $(ORDER_ONLY_SEP) $(BESTCHICKEN) $(COQMKTOPBYTE): $(COQMKTOPCMO) $(SHOW)'OCAMLC -o $@' - $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ str.cma unix.cma \ - $(COQMKTOPCMO) $(OSDEPLIBS) + $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ str.cma unix.cma gramlib.cma\ + $^ $(OSDEPLIBS) $(COQMKTOPOPT): $(COQMKTOPCMX) $(SHOW)'OCAMLOPT -o $@' - $(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa unix.cmxa \ - $(COQMKTOPCMX) $(OSDEPLIBS) + $(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa unix.cmxa gramlib.cmxa\ + $^ $(OSDEPLIBS) $(STRIP) $@ $(COQMKTOP): $(ORDER_ONLY_SEP) $(BESTCOQMKTOP) @@ -228,11 +229,11 @@ scripts/tolink.ml: Makefile.build Makefile.common $(COQCBYTE): $(COQCCMO) $(COQTOPBYTE) $(BESTCOQTOP) $(SHOW)'OCAMLC -o $@' - $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ unix.cma $(COQCCMO) $(OSDEPLIBS) + $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ str.cma unix.cma gramlib.cma $(COQCCMO) $(OSDEPLIBS) $(COQCOPT): $(COQCCMX) $(COQTOPOPT) $(BESTCOQTOP) $(SHOW)'OCAMLOPT -o $@' - $(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ unix.cmxa $(COQCCMX) $(OSDEPLIBS) + $(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa unix.cmxa gramlib.cmxa $(COQCCMX) $(OSDEPLIBS) $(STRIP) $@ $(COQC): $(ORDER_ONLY_SEP) $(BESTCOQC) @@ -395,12 +396,12 @@ coqide-files: $(IDEFILES) $(COQIDEOPT): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) ide/ide.cmxa $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(COQMKTOP) -ide -opt $(OPTFLAGS) -o $@ + $(HIDE)$(COQMKTOP) -boot -ide -opt $(OPTFLAGS) -o $@ $(STRIP) $@ $(COQIDEBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) ide/ide.cma $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(COQMKTOP) -g -ide -top $(BYTEFLAGS) -o $@ + $(HIDE)$(COQMKTOP) -boot -g -ide -top $(BYTEFLAGS) -o $@ $(COQIDE): cd bin; ln -sf coqide.$(HASCOQIDE)$(EXE) coqide$(EXE) @@ -462,21 +463,21 @@ pcoq-binaries:: $(COQINTERFACE) bin/coq-interface$(EXE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(INTERFACE) $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(COQMKTOP) -top $(BYTEFLAGS) -o $@ $(INTERFACE) + $(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@ $(INTERFACE) bin/coq-interface.opt$(EXE): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(INTERFACECMX) $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(COQMKTOP) -opt $(OPTFLAGS) -o $@ $(INTERFACECMX) + $(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) -o $@ $(INTERFACECMX) bin/coq-parser$(EXE):$(LIBCOQRUN) $(PARSERCMO) $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(COQRUNBYTEFLAGS) -linkall $(BYTEFLAGS) -o $@ \ - dynlink.cma nums.cma $(LIBCOQRUN) $(CMA) $(PARSERCMO) + dynlink.cma str.cma nums.cma $(LIBCOQRUN) $(CMA) $(PARSERCMO) bin/coq-parser.opt$(EXE): $(LIBCOQRUN) $(PARSERCMX) $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) -linkall $(OPTFLAGS) -o $@ \ - $(LIBCOQRUN) nums.cmxa $(CMXA) $(PARSERCMX) + $(LIBCOQRUN) $(DYNLINKCMXA) str.cmxa nums.cmxa $(CMXA) $(PARSERCMX) pcoq-files:: $(INTERFACEVO) $(INTERFACERC) @@ -502,7 +503,7 @@ install-pcoq-manpages: validate:: $(BESTCHICKEN) $(ALLVO) $(SHOW)'COQCHK ' - $(BESTCHICKEN) -boot -o -m $(ALLMODS) + $(HIDE)$(BESTCHICKEN) -boot -o -m $(ALLMODS) check:: world cd test-suite; \ @@ -559,10 +560,10 @@ xml: $(XMLVO) $(XMLCMO) extraction: $(EXTRACTIONCMO) field: $(FIELDVO) $(FIELDCMO) fourier: $(FOURIERVO) $(FOURIERCMO) -jprover: $(JPROVERVO) $(JPROVERCMO) funind: $(FUNINDCMO) $(FUNINDVO) cc: $(CCVO) $(CCCMO) -programs subtac: $(SUBTACVO) $(SUBTACCMO) +programs: $(PROGRAMSVO) +subtac: $(SUBTACVO) $(SUBTACCMO) rtauto: $(RTAUTOVO) $(RTAUTOCMO) ########################################################################### @@ -591,7 +592,7 @@ tools:: $(TOOLS) $(DEBUGPRINTERS) $(COQDEP): $(COQDEPCMO) $(SHOW)'OCAMLC -o $@' - $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ unix.cma $(COQDEPCMO) $(OSDEPLIBS) + $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ str.cma unix.cma gramlib.cma $^ $(OSDEPLIBS) $(GALLINA): $(GALLINACMO) $(SHOW)'OCAMLC -o $@' @@ -663,16 +664,18 @@ install-library: $(MKDIR) $(FULLCOQLIB)/states $(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states $(MKDIR) $(FULLCOQLIB)/user-contrib - $(INSTALLLIB) $(LINKCMO) $(GRAMMARCMA) $(FULLCOQLIB) + $(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB) + $(INSTALLSH) $(FULLCOQLIB) $(CONFIG) $(LINKCMO) $(GRAMMARCMA) + $(INSTALLSH) $(FULLCOQLIB) $(OBJSCMO:.cmo=.cmi) ifeq ($(BEST),opt) - $(INSTALLLIB) $(LINKCMX) $(FULLCOQLIB) + $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB) + $(INSTALLSH) $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a) endif - find . $(FIND_VCS_CLAUSE) -name \*.cmi -exec $(INSTALLLIB) {} $(FULLCOQLIB) \; # csdpcert is not meant to be directly called by the user; we install # it with libraries -$(MKDIR) -p $(FULLCOQLIB)/contrib/micromega $(INSTALLBIN) $(CSDPCERT) $(FULLCOQLIB)/contrib/micromega - $(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB) + -$(INSTALLLIB) revision $(FULLCOQLIB) install-library-light: $(MKDIR) $(FULLCOQLIB) @@ -682,6 +685,7 @@ install-library-light: done $(MKDIR) $(FULLCOQLIB)/states $(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states + -$(INSTALLLIB) revision $(FULLCOQLIB) install-allreals:: for f in $(ALLREALS); do \ @@ -733,7 +737,7 @@ dev/printers.cma: $(PRINTERSCMO) parsing/grammar.cma: $(GRAMMARCMO) $(SHOW)'Testing $@' @touch test.ml4 - $(HIDE)$(OCAMLC) $(OPTFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) $(GRAMMARCMO) -impl" -impl test.ml4 -o test-grammar + $(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) $(GRAMMARCMO) -impl" -impl test.ml4 -o test-grammar @rm -f test-grammar test.* $(SHOW)'OCAMLC -a $@' $(HIDE)$(OCAMLC) $(BYTEFLAGS) $(GRAMMARCMO) -linkall -a -o $@ @@ -748,17 +752,19 @@ toplevel/mltop.cmx: toplevel/mltop.optml | toplevel/mltop.ml4.ml.d toplevel/mlto $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(OPTFLAGS) -c -impl $< -o $@ -## This works depency-wise because the dependencies of the +## This works dependency-wise because the dependencies of the ## .{opt,byte}ml files are those we deduce from the .ml4 file. ## In other words, the Byte-only code doesn't import a new module. -toplevel/mltop.byteml: toplevel/mltop.ml4 # no camlp4deps here +toplevel/mltop.byteml: toplevel/mltop.ml4 config/Makefile # no camlp4deps here $(SHOW)'CAMLP4O $<' - $(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo `$(CAMLP4USE) $<` -DByte -impl $< > $@ \ + $(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo `$(CAMLP4USE) $<` \ + -DByte -DHasDynlink -impl $< > $@ \ || ( RV=$$?; rm -f "$@"; exit $${RV} ) -toplevel/mltop.optml: toplevel/mltop.ml4 # no camlp4deps here +toplevel/mltop.optml: toplevel/mltop.ml4 config/Makefile # no camlp4deps here $(SHOW)'CAMLP4O $<' - $(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo `$(CAMLP4USE) $<` -impl $< > $@ \ + $(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo `$(CAMLP4USE) $<` \ + $(NATDYNLINKDEF) -impl $< > $@ \ || ( RV=$$?; rm -f "$@"; exit $${RV} ) # files compiled with -rectypes @@ -800,7 +806,7 @@ ifeq ($(CHECKEDOUT),gnuarch) fi endif ifeq ($(CHECKEDOUT),git) - $(HIDE)set -e; \ + $(HIDE)set -e; \ if test -x "`which git`"; then \ LANG=C; export LANG; \ GIT_BRANCH=$$(git branch -a | sed -ne '/^\* /s/^\* \(.*\)/\1/p'); \ diff --git a/Makefile.common b/Makefile.common index a752892d..1889afc8 100644 --- a/Makefile.common +++ b/Makefile.common @@ -1,3 +1,4 @@ + ####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # $@ +###################################################################### +# Macros for filtering outputs +###################################################################### + +HIDEBIBTEXINFO=| grep -v "^A level-1 auxiliary file" +SHOWMAKEINDEXERROR=egrep '^!! Input index error|^\*\* Input style error|^ --' + ###################################################################### # Common ###################################################################### @@ -75,55 +81,71 @@ doc/common/version.tex: config/Makefile # Reference Manual ###################################################################### - ### Reference Manual (printable format) # The second LATEX compilation is necessary otherwise the pages of the index # are not correct (don't know why...) - BB doc/refman/Reference-Manual.dvi: $(DOCCOMMON) $(REFMANFILES) doc/refman/Reference-Manual.tex - (cd doc/refman;\ - $(LATEX) Reference-Manual;\ - $(BIBTEX) Reference-Manual;\ - $(LATEX) Reference-Manual;\ - $(MAKEINDEX) Reference-Manual;\ - $(MAKEINDEX) Reference-Manual.tacidx -o Reference-Manual.tacind;\ - $(MAKEINDEX) Reference-Manual.comidx -o Reference-Manual.comind;\ - $(MAKEINDEX) Reference-Manual.erridx -o Reference-Manual.errind;\ - $(LATEX) Reference-Manual;\ - $(LATEX) Reference-Manual) + @(cd doc/refman;\ + $(LATEX) -interaction=batchmode Reference-Manual;\ + $(BIBTEX) -terse Reference-Manual $(HIDEBIBTEXINFO);\ + $(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\ + $(MAKEINDEX) -q Reference-Manual;\ + $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ + $(MAKEINDEX) -q Reference-Manual.tacidx -o Reference-Manual.tacind;\ + $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ + $(MAKEINDEX) -q Reference-Manual.comidx -o Reference-Manual.comind;\ + $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ + $(MAKEINDEX) -q Reference-Manual.erridx -o Reference-Manual.errind;\ + $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ + $(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\ + $(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\ + ../tools/show_latex_messages -no-overfull Reference-Manual.log) doc/refman/Reference-Manual.pdf: $(DOCCOMMON) $(REFMANFILES) doc/refman/Reference-Manual.tex - (cd doc/refman; $(PDFLATEX) Reference-Manual.tex) + (cd doc/refman;\ + $(PDFLATEX) -interaction=batchmode Reference-Manual.tex;\ + ../tools/show_latex_messages -no-overfull Reference-Manual.log) ### Reference Manual (browsable format) -doc/refman/Reference-Manual.html: doc/refman/headers.hva doc/refman/Reference-Manual.dvi # to ensure bbl file - (cd doc/refman; $(HEVEA) $(HEVEAOPTS) ./Reference-Manual.tex) +doc/refman/Reference-Manual.html: doc/refman/styles.hva doc/refman/headers.hva doc/refman/Reference-Manual.dvi # to ensure bbl file + (cd doc/refman; BIBINPUTS=.: $(HEVEA) $(HEVEAOPTS) ./styles.hva ./Reference-Manual.tex) + +doc/refman/cover.html: doc/common/styles/html/$(HTMLSTYLE)/cover.html + $(INSTALLLIB) $< doc/refman + +doc/refman/styles.hva: doc/common/styles/html/$(HTMLSTYLE)/styles.hva + $(INSTALLLIB) $< doc/refman doc/refman/html/index.html: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ - doc/refman/cover.html doc/refman/index.html + 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 -o toc.html ../Reference-Manual.html) - $(INSTALLLIB) doc/refman/cover.html doc/refman/menu.html doc/refman/html - $(INSTALLLIB) doc/refman/index.html 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 refman-quick: - (cd doc/refman; \ - $(PDFLATEX) Reference-Manual.tex; \ - $(HEVEA) $(HEVEAOPTS) ./Reference-Manual.tex) - + (cd doc/refman;\ + $(PDFLATEX) -interaction=batchmode Reference-Manual.tex;\ + ../tools/show_latex_messages -no-overfull Reference-Manual.log && \ + $(HEVEA) $(HEVEAOPTS) ./Reference-Manual.tex) ###################################################################### # Tutorial ###################################################################### doc/tutorial/Tutorial.v.dvi: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex - (cd doc/tutorial; $(LATEX) Tutorial.v) + (cd doc/tutorial;\ + $(LATEX) -interaction=batchmode Tutorial.v;\ + ../tools/show_latex_messages Tutorial.v.log) doc/tutorial/Tutorial.v.pdf: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex - (cd doc/tutorial; $(PDFLATEX) Tutorial.v.tex) + (cd doc/tutorial;\ + $(PDFLATEX) -interaction=batchmode Tutorial.v.tex;\ + ../tools/show_latex_messages Tutorial.v.log) doc/tutorial/Tutorial.v.html: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex (cd doc/tutorial; $(HEVEA) $(HEVEAOPTS) Tutorial.v) @@ -135,13 +157,16 @@ doc/tutorial/Tutorial.v.html: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex doc/faq/FAQ.v.dvi: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.tex (cd doc/faq;\ - $(LATEX) FAQ.v;\ - $(BIBTEX) FAQ.v;\ - $(LATEX) FAQ.v;\ - $(LATEX) FAQ.v) + $(LATEX) -interaction=batchmode FAQ.v;\ + $(BIBTEX) -terse FAQ.v;\ + $(LATEX) -interaction=batchmode FAQ.v > /dev/null;\ + $(LATEX) -interaction=batchmode FAQ.v > /dev/null;\ + ../tools/show_latex_messages FAQ.v.log) doc/faq/FAQ.v.pdf: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.dvi doc/faq/axioms.png - (cd doc/faq; $(PDFLATEX) FAQ.v.tex) + (cd doc/faq;\ + $(PDFLATEX) -interaction=batchmode FAQ.v.tex;\ + ../tools/show_latex_messages FAQ.v.log) doc/faq/FAQ.v.html: doc/faq/FAQ.v.dvi # to ensure FAQ.v.bbl (cd doc/faq; $(HEVEA) $(HEVEAOPTS) FAQ.v.tex) @@ -158,15 +183,24 @@ doc/faq/html/index.html: doc/faq/FAQ.v.html ### Standard library (browsable html format) -doc/stdlib/index-body.html: +ifeq ($(QUICK),1) +doc/stdlib/index-body.html: - rm -rf doc/stdlib/html $(MKDIR) doc/stdlib/html - $(COQDOC) -q -d doc/stdlib/html --multi-index --html \ + $(COQDOC) -q -d doc/stdlib/html --multi-index --html -g \ -R theories Coq $(THEORIESVO:.vo=.v) mv doc/stdlib/html/index.html doc/stdlib/index-body.html +else +doc/stdlib/index-body.html: | $(COQDOC) $(THEORIESVO) + - rm -rf doc/stdlib/html + $(MKDIR) doc/stdlib/html + $(COQDOC) -q -d doc/stdlib/html --multi-index --html -g \ + -R theories Coq $(THEORIESVO:.vo=.v) + mv doc/stdlib/html/index.html doc/stdlib/index-body.html +endif -doc/stdlib/index-list.html: doc/stdlib/index-list.html.template - COQTOP=$(COQSRC) ./doc/stdlib/make-library-index doc/stdlib/index-list.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/html/index.html: doc/stdlib/index-list.html doc/stdlib/index-body.html doc/stdlib/index-trailer.html cat doc/stdlib/index-list.html > $@ @@ -175,34 +209,46 @@ doc/stdlib/html/index.html: doc/stdlib/index-list.html doc/stdlib/index-body.htm ### Standard library (light version, full version is definitely too big) -doc/stdlib/Library.coqdoc.tex: - $(COQSRC)/$(COQDOC) -q --gallina --body-only --latex --stdout \ +ifeq ($(QUICK),1) +doc/stdlib/Library.coqdoc.tex: + $(COQDOC) -q -boot --gallina --body-only --latex --stdout \ + -R theories Coq $(THEORIESLIGHTVO:.vo=.v) >> $@ +else +doc/stdlib/Library.coqdoc.tex: | $(COQDOC) $(THEORIESLIGHTVO) + $(COQDOC) -q -boot --gallina --body-only --latex --stdout \ -R theories Coq $(THEORIESLIGHTVO:.vo=.v) >> $@ +endif doc/stdlib/Library.dvi: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.tex (cd doc/stdlib;\ - $(LATEX) Library;\ - $(LATEX) Library) + $(LATEX) -interaction=batchmode Library;\ + $(LATEX) -interaction=batchmode Library > /dev/null;\ + ../tools/show_latex_messages Library.log) doc/stdlib/Library.pdf: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.dvi - (cd doc/stdlib; $(PDFLATEX) Library) + (cd doc/stdlib;\ + $(PDFLATEX) -interaction=batchmode Library;\ + ../tools/show_latex_messages Library.log) ###################################################################### # Tutorial on inductive types ###################################################################### -doc/RecTutorial/RecTutorial.v.dvi: doc/common/version.tex doc/common/title.tex doc/RecTutorial/RecTutorial.v.tex +doc/RecTutorial/RecTutorial.dvi: doc/common/version.tex doc/common/title.tex doc/RecTutorial/RecTutorial.tex (cd doc/RecTutorial;\ - $(LATEX) RecTutorial.v;\ - $(BIBTEX) RecTutorial.v;\ - $(LATEX) RecTutorial.v;\ - $(LATEX) RecTutorial.v) + $(LATEX) -interaction=batchmode RecTutorial;\ + $(BIBTEX) -terse RecTutorial;\ + $(LATEX) -interaction=batchmode RecTutorial > /dev/null;\ + $(LATEX) -interaction=batchmode RecTutorial > /dev/null;\ + ../tools/show_latex_messages RecTutorial.log) -doc/RecTutorial/RecTutorial.v.pdf: doc/common/version.tex doc/common/title.tex doc/RecTutorial/RecTutorial.v.dvi - (cd doc/RecTutorial; $(PDFLATEX) RecTutorial.v.tex) +doc/RecTutorial/RecTutorial.pdf: doc/common/version.tex doc/common/title.tex doc/RecTutorial/RecTutorial.dvi + (cd doc/RecTutorial;\ + $(PDFLATEX) -interaction=batchmode RecTutorial.tex;\ + ../tools/show_latex_messages RecTutorial.log) -doc/RecTutorial/RecTutorial.v.html: doc/RecTutorial/RecTutorial.v.tex - (cd doc/RecTutorial; $(HEVEA) $(HEVEAOPTS) RecTutorial.v) +doc/RecTutorial/RecTutorial.html: doc/RecTutorial/RecTutorial.tex + (cd doc/RecTutorial; $(HEVEA) $(HEVEAOPTS) RecTutorial) ###################################################################### # Index file for CoqIDE @@ -210,7 +256,7 @@ doc/RecTutorial/RecTutorial.v.html: doc/RecTutorial/RecTutorial.v.tex # Not robust, improve... ide/index_urls.txt: doc/refman/html/index.html - - rm ide/index_urls.txt + @ rm -f ide/index_urls.txt cat doc/refman/html/command-index.html doc/refman/html/tactic-index.html | grep li-indexenv | grep HREF | sed -e 's@.*\(.*\).*, .*@\1,\2@' > ide/index_urls.txt @@ -224,23 +270,23 @@ install-doc-meta: $(MKDIR) $(FULLDOCDIR) $(INSTALLLIB) doc/LICENSE $(FULLDOCDIR)/LICENSE.doc -install-doc-html: doc-html +install-doc-html: $(MKDIR) $(addprefix $(FULLDOCDIR)/html/, refman stdlib faq) $(INSTALLLIB) doc/refman/html/* $(FULLDOCDIR)/html/refman $(INSTALLLIB) doc/stdlib/html/* $(FULLDOCDIR)/html/stdlib - $(INSTALLLIB) doc/RecTutorial/RecTutorial.v.html $(FULLDOCDIR)/html/RecTutorial.html + $(INSTALLLIB) doc/RecTutorial/RecTutorial.html $(FULLDOCDIR)/html/RecTutorial.html $(INSTALLLIB) doc/faq/html/* $(FULLDOCDIR)/html/faq $(INSTALLLIB) doc/tutorial/Tutorial.v.html $(FULLDOCDIR)/html/Tutorial.html -install-doc-printable: doc-pdf doc-ps +install-doc-printable: $(MKDIR) $(FULLDOCDIR)/ps $(FULLDOCDIR)/pdf $(INSTALLLIB) doc/refman/Reference-Manual.pdf \ doc/stdlib/Library.pdf $(FULLDOCDIR)/pdf $(INSTALLLIB) doc/refman/Reference-Manual.ps \ doc/stdlib/Library.ps $(FULLDOCDIR)/ps $(INSTALLLIB) doc/tutorial/Tutorial.v.pdf $(FULLDOCDIR)/pdf/Tutorial.pdf - $(INSTALLLIB) doc/RecTutorial/RecTutorial.v.pdf $(FULLDOCDIR)/pdf/RecTutorial.pdf + $(INSTALLLIB) doc/RecTutorial/RecTutorial.pdf $(FULLDOCDIR)/pdf/RecTutorial.pdf $(INSTALLLIB) doc/faq/FAQ.v.pdf $(FULLDOCDIR)/pdf/FAQ.pdf $(INSTALLLIB) doc/tutorial/Tutorial.v.ps $(FULLDOCDIR)/ps/Tutorial.ps - $(INSTALLLIB) doc/RecTutorial/RecTutorial.v.ps $(FULLDOCDIR)/ps/RecTutorial.ps + $(INSTALLLIB) doc/RecTutorial/RecTutorial.ps $(FULLDOCDIR)/ps/RecTutorial.ps $(INSTALLLIB) doc/faq/FAQ.v.ps $(FULLDOCDIR)/ps/FAQ.ps diff --git a/checker/check.ml b/checker/check.ml index 40ac604e..82df62b4 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -211,7 +211,7 @@ let locate_absolute_library dir = if loadpath = [] then raise LibUnmappedDir; try let name = string_of_id base^".vo" in - let _, file = System.where_in_path false loadpath name in + let _, file = System.where_in_path ~warn:false loadpath name in (dir, file) with Not_found -> (* Last chance, removed from the file system but still in memory *) @@ -231,7 +231,7 @@ let locate_qualified_library qid = in if loadpath = [] then raise LibUnmappedDir; let name = qid.basename^".vo" in - let path, file = System.where_in_path true loadpath name in + let path, file = System.where_in_path loadpath name in let dir = extend_dirpath (find_logical_path path) (id_of_string qid.basename) in (* Look if loaded *) diff --git a/checker/checker.ml b/checker/checker.ml index 1ed094cf..3d928933 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -43,7 +43,8 @@ let (/) = Filename.concat let get_version_date () = try - let ch = open_in (Coq_config.coqlib^"/revision") in + let coqlib = Envars.coqlib () in + let ch = open_in (Filename.concat coqlib "revision") in let ver = input_line ch in let rev = input_line ch in (ver,rev) @@ -108,13 +109,9 @@ let set_rec_include d p = check_coq_overwriting p; push_rec_include(d,p) -(* Initializes the LoadPath according to COQLIB and Coq_config *) +(* Initializes the LoadPath *) let init_load_path () = - let coqlib = - (* variable COQLIB overrides the default library *) - getenv_else "COQLIB" - (if Coq_config.local || !Flags.boot then Coq_config.coqtop - else Coq_config.coqlib) in + let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in let contrib = coqlib/"contrib" in (* first user-contrib *) @@ -323,7 +320,7 @@ let parse_args() = | "-debug" :: rem -> set_debug (); parse rem | "-where" :: _ -> - print_endline (getenv_else "COQLIB" Coq_config.coqlib); exit 0 + print_endline (Envars.coqlib ()); exit 0 | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () diff --git a/checker/declarations.ml b/checker/declarations.ml index 71b6c9ca..2cf3854a 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -562,7 +562,7 @@ type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * Univ.constraints option + | SFBalias of module_path * struct_expr_body option * Univ.constraints option | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list @@ -576,7 +576,8 @@ and struct_expr_body = | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path * Univ.constraints + With_module_body of identifier list * module_path * + struct_expr_body option * Univ.constraints | With_definition_body of identifier list * constant_body and module_body = @@ -592,13 +593,14 @@ and module_type_body = typ_alias : substitution} -let subst_with_body sub = function - | With_module_body(id,mp,cst) -> - With_module_body(id,subst_mp sub mp,cst) +let rec subst_with_body sub = function + | With_module_body(id,mp,typ_opt,cst) -> + With_module_body(id,subst_mp sub mp, + Option.smartmap (subst_struct_expr sub) typ_opt,cst) | With_definition_body(id,cb) -> With_definition_body( id,subst_const_body sub cb) -let rec subst_modtype sub mtb = +and subst_modtype sub mtb = let typ_expr' = subst_struct_expr sub mtb.typ_expr in if typ_expr'==mtb.typ_expr then mtb @@ -616,8 +618,8 @@ and subst_structure sub sign = SFBmodule (subst_module sub mb) | SFBmodtype mtb -> SFBmodtype (subst_modtype sub mtb) - | SFBalias (mp,cst) -> - SFBalias (subst_mp sub mp,cst) + | SFBalias (mp,typ_opt ,cst) -> + SFBalias (subst_mp sub mp,Option.smartmap (subst_struct_expr sub) typ_opt,cst) in List.map (fun (l,b) -> (l,subst_body b)) sign diff --git a/checker/declarations.mli b/checker/declarations.mli index fdea3383..78bf2053 100644 --- a/checker/declarations.mli +++ b/checker/declarations.mli @@ -150,7 +150,8 @@ type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * Univ.constraints option + | SFBalias of module_path * struct_expr_body option + * Univ.constraints option | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list @@ -164,7 +165,8 @@ and struct_expr_body = | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path * Univ.constraints + With_module_body of identifier list * module_path * + struct_expr_body option * Univ.constraints | With_definition_body of identifier list * constant_body and module_body = diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 379273af..af5e4f46 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -145,9 +145,9 @@ and check_with_aux_def env mtb with_decl = | _ -> error_signature_expected mtb in let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_) -> + | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl - | With_definition_body ([],_) | With_module_body ([],_,_) -> assert false + | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false in let l = label_of_id id in try @@ -173,8 +173,8 @@ and check_with_aux_def env mtb with_decl = let new_with_decl = match with_decl with With_definition_body (_,c) -> With_definition_body (idl,c) - | With_module_body (_,c,cst) -> - With_module_body (idl,c,cst) in + | With_module_body (_,c,t,cst) -> + With_module_body (idl,c,t,cst) in check_with_aux_def env' (type_of_mb env old) new_with_decl | Some msb -> error_a_generative_module_expected l @@ -192,9 +192,9 @@ and check_with_aux_mod env mtb with_decl = msid,msid',(subst_signature_msid msid (MPself(msid')) sig_b) | _ -> error_signature_expected mtb in let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_) -> + | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl - | With_definition_body ([],_) | With_module_body ([],_,_) -> assert false + | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false in let l = label_of_id id in try @@ -206,11 +206,11 @@ and check_with_aux_mod env mtb with_decl = in let env' = Modops.add_signature (MPself msid) before env in match with_decl with - | With_module_body ([],_,_) -> assert false - | With_module_body ([id], mp,_) -> + | With_module_body ([],_,_,_) -> assert false + | With_module_body ([id], mp,_,_) -> let old,alias = match spec with SFBmodule msb -> Some msb,None - | SFBalias (mp',_) -> None,Some mp' + | SFBalias (mp',_,_) -> None,Some mp' | _ -> error_not_a_module l in let mtb' = lookup_modtype mp env' in @@ -223,7 +223,7 @@ and check_with_aux_mod env mtb with_decl = anomaly "Mod_typing:no implementation and no alias" in join (map_mp (mp_rec [id]) mp) mtb'.typ_alias - | With_module_body (_::_,mp,_) -> + | With_module_body (_::_,mp,_,_) -> let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l @@ -234,8 +234,8 @@ and check_with_aux_mod env mtb with_decl = let new_with_decl = match with_decl with With_definition_body (_,c) -> With_definition_body (idl,c) - | With_module_body (_,c,cst) -> - With_module_body (idl,c,cst) in + | With_module_body (_,c,t,cst) -> + With_module_body (idl,c,t,cst) in let sub = check_with_aux_mod env' (type_of_mb env old) new_with_decl in @@ -290,7 +290,7 @@ and check_structure_field (s,env) mp lab = function let is_fun, sub = Modops.update_subst env msb mp1 in ((if is_fun then s else join s sub), Modops.add_module (MPdot(mp,lab)) msb env) - | SFBalias(mp2,cst) -> + | SFBalias(mp2,_,cst) -> (* cf Safe_typing.add_alias *) (try let mp' = MPdot(mp,lab) in diff --git a/checker/modops.ml b/checker/modops.ml index f79e52c2..27ea4d55 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -145,7 +145,7 @@ let rec eval_struct env = function (join sub_alias (map_mbid farg_id mp)) fbody_b) | SEBwith (mtb,(With_definition_body _ as wdb)) -> merge_with env mtb wdb empty_subst - | SEBwith (mtb, (With_module_body (_,mp,_) as wdb)) -> + | SEBwith (mtb, (With_module_body (_,mp,_,_) as wdb)) -> let alias_in_mp = (lookup_modtype mp env).typ_alias in merge_with env mtb wdb alias_in_mp @@ -167,8 +167,8 @@ and merge_with env mtb with_decl alias= | _ -> 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 + | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl + | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false in let l = label_of_id id in try @@ -180,15 +180,15 @@ and merge_with env mtb with_decl alias= in let new_spec,subst = match with_decl with | With_definition_body ([],_) - | With_module_body ([],_,_) -> assert false + | With_module_body ([],_,_,_) -> assert false | With_definition_body ([id],c) -> SFBconst c,None - | With_module_body ([id], mp,cst) -> + | With_module_body ([id], mp,typ_opt,cst) -> let mp' = scrape_alias mp env in - SFBalias (mp,Some cst), + SFBalias (mp,typ_opt,Some cst), Some(join (map_mp (mp_rec [id]) mp') alias) | With_definition_body (_::_,_) - | With_module_body (_::_,_,_) -> + | With_module_body (_::_,_,_,_) -> let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l @@ -196,8 +196,8 @@ and merge_with env mtb with_decl alias= let new_with_decl,subst1 = match with_decl with With_definition_body (_,c) -> With_definition_body (idl,c),None - | With_module_body (idc,mp,cst) -> - With_module_body (idl,mp,cst), + | With_module_body (idc,mp,t,cst) -> + With_module_body (idl,mp,t,cst), Some(map_mp (mp_rec idc) mp) in let subst = Option.fold_right join subst1 alias in @@ -227,7 +227,7 @@ and add_signature mp sign env = | SFBmodule mb -> add_module (MPdot (mp,l)) mb env (* adds components as well *) - | SFBalias (mp1,cst) -> + | SFBalias (mp1,_,cst) -> Environ.register_alias (MPdot(mp,l)) mp1 env | SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) mtb env @@ -257,7 +257,7 @@ and constants_of_specification env mp sign = let new_env = add_module (MPdot (mp,l)) mb env in new_env,(constants_of_modtype env (MPdot (mp,l)) (type_of_mb env mb)) @ res - | SFBalias (mp1,cst) -> + | SFBalias (mp1,_,cst) -> let new_env = register_alias (MPdot (mp,l)) mp1 env in new_env,(constants_of_modtype env (MPdot (mp,l)) (eval_struct env (SEBident mp1))) @ res @@ -323,7 +323,7 @@ and strengthen_sig env msid sign mp = match sign with (MPdot (MPself msid,l)) mb env in let rest' = strengthen_sig env' msid rest mp in item':: rest' - | ((l,SFBalias (mp1,cst)) as item) :: rest -> + | ((l,SFBalias (mp1,_,cst)) as item) :: rest -> let env' = register_alias (MPdot(MPself msid,l)) mp1 env in let rest' = strengthen_sig env' msid rest mp in item::rest' diff --git a/checker/subtyping.ml b/checker/subtyping.ml index fb95b606..7a6868fe 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -32,7 +32,7 @@ type namedobject = | IndConstr of constructor * mutual_inductive_body | Module of module_body | Modtype of module_type_body - | Alias of module_path + | Alias of module_path * struct_expr_body option (* adds above information about one mutual inductive: all types and constructors *) @@ -63,7 +63,7 @@ let make_label_map mp list = add_nameobjects_of_mib (make_kn mp empty_dirpath l) mib map | SFBmodule mb -> add_map (Module mb) | SFBmodtype mtb -> add_map (Modtype mtb) - | SFBalias (mp,cst) -> add_map (Alias mp) + | SFBalias (mp,t,cst) -> add_map (Alias (mp,t)) in List.fold_right add_one list Labmap.empty @@ -308,23 +308,23 @@ and check_signatures env (msid1,sig1) alias (msid2,sig2') = begin match info1 with | Module msb -> check_modules env msid1 l msb msb2 - | Alias mp ->let msb = + | Alias (mp,typ_opt) ->let msb = {mod_expr = Some (SEBident mp); - mod_type = Some (eval_struct env (SEBident mp)); + mod_type = typ_opt; mod_constraints = Constraint.empty; mod_alias = (lookup_modtype mp env).typ_alias; mod_retroknowledge = []} in check_modules env msid1 l msb msb2 | _ -> error_not_match l spec2 end - | SFBalias (mp,_) -> + | SFBalias (mp,typ_opt,_) -> begin match info1 with - | Alias mp1 -> check_modpath_equiv env mp mp1 + | Alias (mp1,_) -> check_modpath_equiv env mp mp1 | Module msb -> let msb1 = {mod_expr = Some (SEBident mp); - mod_type = Some (eval_struct env (SEBident mp)); + mod_type = typ_opt; mod_constraints = Constraint.empty; mod_alias = (lookup_modtype mp env).typ_alias; mod_retroknowledge = []} in diff --git a/config/Makefile.template b/config/Makefile.template index e0e7bf0b..35e2a2d7 100644 --- a/config/Makefile.template +++ b/config/Makefile.template @@ -49,7 +49,7 @@ CAMLP4BIN="CAMLP4BINDIRECTORY" CAMLVERSION=CAMLTAG # Ocaml .h directory -CAMLHLIB="CAMLLIBDIRECTORY"/caml +CAMLHLIB="CAMLLIBDIRECTORY" # Camlp4 library directory (avoid CAMLP4LIB used on Windows) CAMLP4O=CAMLP4TOOL @@ -96,6 +96,7 @@ BEST=BESTCOMPILER # Your architecture # Can be obtain by UNIX command arch ARCH=ARCHITECTURE +HASNATDYNLINK=HASNATIVEDYNLINK # Your C compiler and co CC="CCEXEC" @@ -113,6 +114,7 @@ OSDEPLIBS=OSDEPENDENTLIBS # Unix systems: # Win32 systems : .exe EXE=EXECUTEEXTENSION +DLLEXT=DLLEXTENSION # the command MKDIR (try to replace it with mkdirhier if you have problems) MKDIR=mkdir -p @@ -151,4 +153,3 @@ WITHDOC=WITHDOCOPT # make or sed are bogus and believe lines not terminating by a return # are inexistent - diff --git a/config/coq_config.mli b/config/coq_config.mli index af943509..14595fa5 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -6,19 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: coq_config.mli 11380 2008-09-07 12:27:27Z glondu $ i*) +(*i $Id: coq_config.mli 11858 2009-01-26 13:27:23Z notin $ i*) val local : bool (* local use (no installation) *) -val bindir : string (* where the binaries are installed *) val coqlib : string (* where the std library is installed *) +val coqsrc : string (* where are the sources *) -val coqtop : string (* where are the sources *) - -val camldir : string (* base directory of OCaml binaries *) +val camlbin : string (* base directory of OCaml binaries *) val camllib : string (* for Dynlink *) val camlp4 : string (* exact name of camlp4: either "camlp4" ou "camlp5" *) +val camlp4bin : string (* base directory for Camlp4/5 binaries *) val camlp4lib : string (* where is the library of Camlp4 *) val best : string (* byte/opt *) @@ -30,6 +29,7 @@ val coqrunbyteflags : string (* -custom/-dllib -lcoqrun *) (* val defined : string list (* options for lib/ocamlpp *) *) val version : string (* version number of Coq *) +val caml_version : string (* OCaml version used to compile Coq *) val date : string (* release date *) val compile_date : string (* compile date *) val vo_magic_number : int @@ -44,3 +44,5 @@ val with_geoproof : bool ref (* to (de)activate functions specific to Geoproof w val browser : string (** default web browser to use, may be overriden by environment variable COQREMOTEBROWSER *) + +val has_natdynlink : bool diff --git a/configure b/configure index 79a772ed..14ff9950 100755 --- a/configure +++ b/configure @@ -6,10 +6,10 @@ # ################################## -VERSION=8.2 +VERSION=8.2rc2 VOMAGIC=08193 STATEMAGIC=19764 -DATE="Jun. 2008" +DATE=`LANG=C date +"%B %Y"` # Create the bin/ directory if non-existent test -d bin || mkdir bin @@ -58,7 +58,7 @@ usage () { echo "-arch" printf "\tSpecifies the architecture\n" echo "-opt" - printf "\tSpecifies whether or not to generate optimized executables\n" + printf "\tSpecifies whether or not to use OCaml *.opt optimized compilers\n" echo "-fsets (all|basic)" echo "-reals (all|basic)" printf "\tSpecifies whether or not to compile full FSets/Reals library\n" @@ -88,7 +88,7 @@ usage () { # Default OCaml binaries bytecamlc=ocamlc nativecamlc=ocamlopt -ocamlmklib=ocamlmklib +ocamlmklibexec=ocamlmklib ocamlexec=ocaml ocamldepexec=ocamldep ocamldocexec=ocamldoc @@ -285,22 +285,11 @@ esac # executable extension case $ARCH in - win32) EXE=".exe";; + win32) + EXE=".exe" + DLLEXT=".dll";; *) EXE="" -esac - -# strip command - -case $ARCH in - win32) - # true -> strip : it exists under cygwin ! - STRIPCOMMAND="strip";; - *) - if [ "$coq_profile_flag" = "-p" ] || [ "$coq_debug_flag" = "-g" ]; then - STRIPCOMMAND="true" - else - STRIPCOMMAND="strip" - fi + DLLEXT=".so" esac # Is the source tree checked out from a recognised @@ -386,7 +375,8 @@ case $camldir_spec in ocamldocexec=$CAMLBIN/ocamldoc ocamllexexec=$CAMLBIN/ocamllex ocamlyaccexec=$CAMLBIN/ocamlyacc - camlmktopexec=$CAMLBIN/ocamlmktop + ocamlmktopexec=$CAMLBIN/ocamlmktop + ocamlmklibexec=$CAMLBIN/ocamlmklib camlp4oexec=$CAMLBIN/camlp4o esac @@ -405,7 +395,7 @@ esac # ("native-code program cannot do a dynamic load") if [ `uname -s` = "FreeBSD" ]; then camlp4oexec=$camlp4oexec.byte; fi -CAMLVERSION=`"$bytecamlc" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' ` +CAMLVERSION=`"$bytecamlc" -version` case $CAMLVERSION in 1.*|2.*|3.00|3.01|3.02|3.03|3.03alpha|3.04|3.05beta|3.05|3.06|3.08.0) @@ -446,9 +436,20 @@ case $CAMLVERSION in cflags="$cflags -DOCAML_307";; esac -if [ "$CAMLTAG" = "OCAML310" ] && [ "$coq_debug_flag" = "-g" ]; then - # Compilation debug flag - coq_debug_flag_opt="-g" +if [ "$coq_debug_flag" = "-g" ]; then + case $CAMLTAG in + OCAML31*) + # Compilation debug flag + coq_debug_flag_opt="-g" + ;; + esac +fi + +# Native dynlink +if test -f `"$CAMLC" -where`/dynlink.cmxa; then + HASNATDYNLINK=true +else + HASNATDYNLINK=false fi # Camlp4 / Camlp5 configuration @@ -467,26 +468,31 @@ if [ "$camlp5dir" != "" ]; then echo "Please compile Camlp5 in transitional mode." exit 1 fi -elif [ "$CAMLTAG" = "OCAML310" ]; then - if [ -x "${CAMLLIB}/camlp5" ]; then - CAMLP4LIB=+camlp5 - elif [ -x "${CAMLLIB}/site-lib/camlp5" ]; then - CAMLP4LIB=+site-lib/camlp5 - else - echo "Objective Caml 3.10 found but no Camlp5 installed." - echo "Configuration script failed!" - exit 1 - fi - CAMLP4=camlp5 - camlp4oexec=`echo $camlp4oexec | sed -e 's/4/5/'` - if [ `$camlp4oexec -pmode 2>&1` = "strict" ]; then - echo "Error: Camlp5 found, but in strict mode!" - echo "Please compile Camlp5 in transitional mode." - exit 1 - fi -else - CAMLP4=camlp4 - CAMLP4LIB=+camlp4 +else + case $CAMLTAG in + OCAML31*) + if [ -x "${CAMLLIB}/camlp5" ]; then + CAMLP4LIB=+camlp5 + elif [ -x "${CAMLLIB}/site-lib/camlp5" ]; then + CAMLP4LIB=+site-lib/camlp5 + else + echo "Objective Caml $CAMLVERSION found but no Camlp5 installed." + echo "Configuration script failed!" + exit 1 + fi + CAMLP4=camlp5 + camlp4oexec=`echo $camlp4oexec | sed -e 's/4/5/'` + if [ `$camlp4oexec -pmode 2>&1` = "strict" ]; then + echo "Error: Camlp5 found, but in strict mode!" + echo "Please compile Camlp5 in transitional mode." + exit 1 + fi + ;; + *) + CAMLP4=camlp4 + CAMLP4LIB=+camlp4 + ;; + esac fi if [ "$CAMLP4" = "camlp5" ] && `$camlp4oexec -v 2>&1 | grep -q 5.00`; then @@ -613,12 +619,16 @@ esac #CAMLOSTYPE=`config/giveostype` #rm config/giveostype +# strip command + case $ARCH in win32) # true -> strip : it exists under cygwin ! STRIPCOMMAND="strip";; *) - if [ "$coq_profile_flag" = "-p" ] || [ "$coq_debug_flag" = "-g" ]; then + if [ "$coq_profile_flag" = "-p" ] || [ "$coq_debug_flag" = "-g" ] || + [ "`uname -s`" = "Darwin" -a "$HASNATDYNLINK" = "true" ] + then STRIPCOMMAND="true" else STRIPCOMMAND="strip" @@ -673,7 +683,7 @@ case $ARCH in bindir_def=/usr/local/bin libdir_def=/usr/local/lib/coq mandir_def=/usr/local/man - docdir_def=/usr/local/share/doc + docdir_def=/usr/local/share/doc/coq emacslib_def=/usr/local/share/emacs/site-lisp coqdocdir_def=/usr/local/share/texmf/tex/latex/misc;; esac @@ -684,7 +694,7 @@ case $bindir_spec/$prefix_spec/$local in yes/*/*) BINDIR=$bindir ;; */yes/*) BINDIR=$prefix/bin ;; */*/true) BINDIR=$COQTOP/bin ;; - *) echo "Where should I install the Coq binaries [$bindir_def] ?" + *) printf "Where should I install the Coq binaries [$bindir_def]? " read BINDIR case $BINDIR in "") BINDIR=$bindir_def;; @@ -700,7 +710,7 @@ case $libdir_spec/$prefix_spec/$local in *) LIBDIR=$prefix/lib/coq ;; esac ;; */*/true) LIBDIR=$COQTOP ;; - *) echo "Where should I install the Coq library [$libdir_def] ?" + *) printf "Where should I install the Coq library [$libdir_def]? " read LIBDIR case $LIBDIR in "") LIBDIR=$libdir_def;; @@ -712,7 +722,7 @@ case $mandir_spec/$prefix_spec/$local in yes/*/*) MANDIR=$mandir;; */yes/*) MANDIR=$prefix/man ;; */*/true) MANDIR=$COQTOP/man ;; - *) echo "Where should I install the Coq man pages [$mandir_def] ?" + *) printf "Where should I install the Coq man pages [$mandir_def]? " read MANDIR case $MANDIR in "") MANDIR=$mandir_def;; @@ -722,9 +732,9 @@ esac case $docdir_spec/$prefix_spec/$local in yes/*/*) DOCDIR=$docdir;; - */yes/*) DOCDIR=$prefix/share/doc ;; + */yes/*) DOCDIR=$prefix/share/doc/coq ;; */*/true) DOCDIR=$COQTOP/man ;; - *) echo "Where should I install the Coq documentation [$docdir_def] ?" + *) printf "Where should I install the Coq documentation [$docdir_def]? " read DOCDIR case $DOCDIR in "") DOCDIR=$docdir_def;; @@ -740,7 +750,7 @@ case $emacslib_spec/$prefix_spec/$local in *) EMACSLIB=$prefix/share/emacs/site-lisp ;; esac ;; */*/true) EMACSLIB=$COQTOP/tools/emacs ;; - *) echo "Where should I install the Coq Emacs mode [$emacslib_def] ?" + *) printf "Where should I install the Coq Emacs mode [$emacslib_def]? " read EMACSLIB case $EMACSLIB in "") EMACSLIB=$emacslib_def;; @@ -756,7 +766,7 @@ case $coqdocdir_spec/$prefix_spec/$local in *) COQDOCDIR=$prefix/share/emacs/site-lisp ;; esac ;; */*/true) COQDOCDIR=$COQTOP/tools/coqdoc ;; - *) echo "Where should I install Coqdoc TeX/LaTeX files [$coqdocdir_def] ?" + *) printf "Where should I install Coqdoc TeX/LaTeX files [$coqdocdir_def]? " read COQDOCDIR case $COQDOCDIR in "") COQDOCDIR=$coqdocdir_def;; @@ -773,7 +783,7 @@ case $coqrunbyteflags_spec/$local in esac # case $emacs_spec in -# no) echo "Which Emacs command should I use to compile coq.el [$emacs_def] ?" +# no) printf "Which Emacs command should I use to compile coq.el [$emacs_def]? " # read EMACS # case $EMACS in @@ -824,7 +834,7 @@ echo " Paths for true installation:" echo " binaries will be copied in $BINDIR" echo " library will be copied in $LIBDIR" echo " man pages will be copied in $MANDIR" -echo " documentation will be copied in $MANDIR" +echo " documentation will be copied in $DOCDIR" echo " emacs mode will be copied in $EMACSLIB" echo "" @@ -848,6 +858,7 @@ case $ARCH in win32) ESCCOQTOP=`echo $COQTOP |sed -e 's|\\\|\\\\\\\|g'` ESCBINDIR=`echo $BINDIR |sed -e 's|\\\|\\\\\\\|g'` + ESCSRCDIR=`cygpath -d $COQSRC |sed -e 's|\\\|\\\\\\\|g'` ESCLIBDIR=`echo $LIBDIR |sed -e 's|\\\|\\\\\\\|g'` ESCCAMLDIR=`echo $CAMLBIN |sed -e 's|\\\|\\\\\\\|g'` ESCCAMLLIB=`echo $CAMLLIB |sed -e 's|\\\|\\\\\\\|g'` @@ -858,10 +869,13 @@ case $ARCH in ESCCAMLP4BIN=`echo $CAMLP4BIN |sed -e 's|\\\|\\\\\\\|g'` ESCCAMLP4LIB=`echo $CAMLP4LIB |sed -e 's|\\\|\\\\\\\|g'` ESCLABLGTKINCLUDES=`echo $LABLGTKINCLUDES |sed -e 's|\\\|\\\\\\\|g'` - ;; + ESCCOQRUNBYTEFLAGS=`echo $COQRUNBYTEFLAGS |sed -e 's|\\\|\\\\\\\|g'` + ESCBUILDLDPATH=`echo $BUILDLDPATH |sed -e 's|\\\|\\\\\\\|g'` +;; *) ESCCOQTOP="$COQTOP" ESCBINDIR="$BINDIR" + ESCSRCDIR="$COQSRC" ESCLIBDIR="$LIBDIR" ESCCAMLDIR="$CAMLBIN" ESCCAMLLIB="$CAMLLIB" @@ -872,27 +886,30 @@ case $ARCH in ESCCAMLP4BIN="$CAMLP4BIN" ESCCAMLP4LIB="$CAMLP4LIB" ESCLABLGTKINCLUDES="$LABLGTKINCLUDES" + ESCCOQRUNBYTEFLAGS="$COQRUNBYTEFLAGS" ;; esac mlconfig_file="$COQSRC/config/coq_config.ml" -rm -f $mlconfig_file +rm -f "$mlconfig_file" cat << END_OF_COQ_CONFIG > $mlconfig_file (* DO NOT EDIT THIS FILE: automatically generated by ../configure *) let local = $local -let coqrunbyteflags = "$COQRUNBYTEFLAGS" -let bindir = try Sys.getenv "COQBIN" with Not_found -> "$ESCBINDIR" -let coqlib = try Sys.getenv "COQLIB" with Not_found -> "$ESCLIBDIR" -let coqtop = try Sys.getenv "COQTOP" with Not_found -> "$ESCCOQTOP" -let camldir = "$ESCCAMLDIR" +let coqrunbyteflags = "$ESCCOQRUNBYTEFLAGS" +let coqlib = "$ESCLIBDIR" +let coqsrc = "$ESCSRCDIR" +let camlbin = "$ESCCAMLDIR" let camllib = "$ESCCAMLLIB" let camlp4 = "$CAMLP4" +let camlp4bin = "$ESCCAMLP4BIN" let camlp4lib = "$ESCCAMLP4LIB" let best = "$best_compiler" let arch = "$ARCH" +let has_natdynlink = $HASNATDYNLINK let osdeplibs = "$OSDEPLIBS" let version = "$VERSION" +let caml_version = "$CAMLVERSION" let date = "$DATE" let compile_date = "$COMPILEDATE" let vo_magic_number = $VOMAGIC @@ -929,12 +946,12 @@ chmod a-w "$mlconfig_file" rm -f "$COQSRC/config/Makefile" sed -e "s|LOCALINSTALLATION|$local|" \ - -e "s|XCOQRUNBYTEFLAGS|$COQRUNBYTEFLAGS|" \ + -e "s|XCOQRUNBYTEFLAGS|$ESCCOQRUNBYTEFLAGS|" \ -e "s|COQSRCDIRECTORY|$COQSRC|" \ -e "s|COQVERSION|$VERSION|" \ -e "s|BINDIRDIRECTORY|$ESCBINDIR|" \ -e "s|COQLIBDIRECTORY|$ESCLIBDIR|" \ - -e "s|BUILDLDPATH=|$BUILDLDPATH|" \ + -e "s|BUILDLDPATH=|$ESCBUILDLDPATH|" \ -e "s|MANDIRDIRECTORY|$ESCMANDIR|" \ -e "s|DOCDIRDIRECTORY|$ESCDOCDIR|" \ -e "s|EMACSLIBDIRECTORY|$ESCEMACSLIB|" \ @@ -957,16 +974,17 @@ sed -e "s|LOCALINSTALLATION|$local|" \ -e "s|CAMLANNOTATEFLAG|$coq_annotate_flag|" \ -e "s|CCOMPILEFLAGS|$cflags|" \ -e "s|BESTCOMPILER|$best_compiler|" \ + -e "s|DLLEXTENSION|$DLLEXT|" \ -e "s|EXECUTEEXTENSION|$EXE|" \ -e "s|BYTECAMLC|$bytecamlc|" \ - -e "s|OCAMLMKLIBEXEC|$ocamlmklib|" \ + -e "s|OCAMLMKLIBEXEC|$ocamlmklibexec|" \ -e "s|NATIVECAMLC|$nativecamlc|" \ -e "s|OCAMLEXEC|$ocamlexec|" \ -e "s|OCAMLDEPEXEC|$ocamldepexec|" \ -e "s|OCAMLDOCEXEC|$ocamldocexec|" \ -e "s|OCAMLLEXEXEC|$ocamllexexec|" \ -e "s|OCAMLYACCEXEC|$ocamlyaccexec|" \ - -e "s|CAMLMKTOPEXEC|$camlmktopexec|" \ + -e "s|CAMLMKTOPEXEC|$ocamlmktopexec|" \ -e "s|CCEXEC|$gcc_exec|" \ -e "s|AREXEC|$ar_exec|" \ -e "s|RANLIBEXEC|$ranlib_exec|" \ @@ -976,6 +994,7 @@ sed -e "s|LOCALINSTALLATION|$local|" \ -e "s|COQIDEOPT|$COQIDE|" \ -e "s|CHECKEDOUTSOURCETREE|$checkedout|" \ -e "s|WITHDOCOPT|$with_doc|" \ + -e "s|HASNATIVEDYNLINK|$HASNATDYNLINK|" \ "$COQSRC/config/Makefile.template" > "$COQSRC/config/Makefile" chmod a-w "$COQSRC/config/Makefile" @@ -1002,7 +1021,11 @@ fi if [ ! "$COQIDE" = "no" ]; then if grep "class view " "$lablgtkdir/gText.mli" | grep -q "\[>" ; then + if grep -q "?accepts_tab:bool" "$lablgtkdir/gText.mli" ; then + cp -f ide/undo_lablgtk_ge212.mli ide/undo.mli + else cp -f ide/undo_lablgtk_ge26.mli ide/undo.mli + fi else cp -f ide/undo_lablgtk_lt26.mli ide/undo.mli fi @@ -1017,4 +1040,4 @@ echo echo "*Warning* To compile the system for a new architecture" echo " don't forget to do a 'make archclean' before './configure'." -# $Id: configure 11380 2008-09-07 12:27:27Z glondu $ +# $Id: configure 11858 2009-01-26 13:27:23Z notin $ diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml index 871d7521..00cbbeee 100644 --- a/contrib/cc/cctac.ml +++ b/contrib/cc/cctac.ml @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: cctac.ml 10670 2008-03-14 19:30:48Z letouzey $ *) +(* $Id: cctac.ml 11671 2008-12-12 12:43:03Z herbelin $ *) (* This file is the interface between the c-c algorithm and Coq *) @@ -48,10 +48,6 @@ let _eq = constant ["Init";"Logic"] "eq" let _False = constant ["Init";"Logic"] "False" -(* decompose member of equality in an applicative format *) - -let sf_of env sigma c = family_of_sort (destSort (type_of env sigma c)) - let whd env= let infos=Closure.create_clos_infos Closure.betaiotazeta env in (fun t -> Closure.whd_val infos (Closure.inject t)) @@ -60,6 +56,10 @@ let whd_delta env= let infos=Closure.create_clos_infos Closure.betadeltaiota env in (fun t -> Closure.whd_val infos (Closure.inject t)) +(* decompose member of equality in an applicative format *) + +let sf_of env sigma c = family_of_sort (destSort (whd_delta env (type_of env sigma c))) + let rec decompose_term env sigma t= match kind_of_term (whd env t) with App (f,args)-> @@ -317,7 +317,7 @@ let refute_tac c t1 t2 p gls = [|intype;tt1;tt2|]) in let hid=pf_get_new_id (id_of_string "Heq") gls in let false_t=mkApp (c,[|mkVar hid|]) in - tclTHENS (true_cut (Name hid) neweq) + tclTHENS (assert_tac (Name hid) neweq) [proof_tac p; simplest_elim false_t] gls let convert_to_goal_tac c t1 t2 p gls = @@ -329,14 +329,14 @@ let convert_to_goal_tac c t1 t2 p gls = let identity=mkLambda (Name x,sort,mkRel 1) in let endt=mkApp (Lazy.force _eq_rect, [|sort;tt1;identity;c;tt2;mkVar e|]) in - tclTHENS (true_cut (Name e) neweq) + tclTHENS (assert_tac (Name e) neweq) [proof_tac p;exact_check endt] gls let convert_to_hyp_tac c1 t1 c2 t2 p gls = let tt2=constr_of_term t2 in let h=pf_get_new_id (id_of_string "H") gls in let false_t=mkApp (c2,[|mkVar h|]) in - tclTHENS (true_cut (Name h) tt2) + tclTHENS (assert_tac (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] gls @@ -358,7 +358,7 @@ let discriminate_tac cstr p gls = let endt=mkApp (Lazy.force _eq_rect, [|outtype;trivial;pred;identity;concl;injt|]) in let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in - tclTHENS (true_cut (Name hid) neweq) + tclTHENS (assert_tac (Name hid) neweq) [proof_tac p;exact_check endt] gls (* wrap everything *) @@ -431,6 +431,12 @@ let congruence_tac depth l = (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) cc_fail +(* Beware: reflexivity = constructor 1 = apply refl_equal + might be slow now, let's rather do something equivalent + to a "simple apply refl_equal" *) + +let simple_reflexivity () = apply (Lazy.force _refl_equal) + (* The [f_equal] tactic. It mimics the use of lemmas [f_equal], [f_equal2], etc. @@ -442,7 +448,8 @@ let f_equal gl = let cut_eq c1 c2 = let ty = refresh_universes (pf_type_of gl c1) in tclTHENTRY - (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) reflexivity + (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) + (simple_reflexivity ()) in try match kind_of_term (pf_concl gl) with | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> diff --git a/contrib/dp/dp_gappa.ml b/contrib/dp/dp_gappa.ml index 70439a97..9c035aa8 100644 --- a/contrib/dp/dp_gappa.ml +++ b/contrib/dp/dp_gappa.ml @@ -153,18 +153,18 @@ let call_gappa hl p = let gappa_out2 = temp_file "gappa2" in patch_gappa_proof gappa_out gappa_out2; remove_file gappa_out; - let cmd = sprintf "%s/coqc %s" Coq_config.bindir gappa_out2 in + let cmd = (Filename.concat (Envars.coqbin ()) "coqc") ^ " " ^ gappa_out2 in let out = Sys.command cmd in if out <> 0 then raise GappaProofFailed; let gappa_out3 = temp_file "gappa3" in let c = open_out gappa_out3 in let gappa2 = Filename.chop_suffix (Filename.basename gappa_out2) ".v" in Printf.fprintf c - "Require \"%s\". Set Printing Depth 9999999. Print %s.proof." + "Require \"%s\". Set Printing Depth 999999. Print %s.proof." (Filename.chop_suffix gappa_out2 ".v") gappa2; close_out c; let lambda = temp_file "gappa_lambda" in - let cmd = sprintf "%s/coqc %s > %s" Coq_config.bindir gappa_out3 lambda in + let cmd = (Filename.concat (Envars.coqbin ()) "coqc") ^ " " ^ gappa_out3 ^ " > " ^ lambda in let out = Sys.command cmd in if out <> 0 then raise GappaProofFailed; remove_file gappa_out2; remove_file gappa_out3; diff --git a/contrib/dp/dp_zenon.mll b/contrib/dp/dp_zenon.mll index 2fc2a5f4..e15e280d 100644 --- a/contrib/dp/dp_zenon.mll +++ b/contrib/dp/dp_zenon.mll @@ -154,7 +154,7 @@ and read_main_proof = parse 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 true (Name (id_of_string id)) c gl) + assert_tac (Name (id_of_string id)) c gl) [tclTHEN intros reflexivity; tclIDTAC] let exact_string s gl = @@ -165,7 +165,7 @@ and read_main_proof = parse let interp_lemma l gl = let ty = constr_of_string gl l.l_type in tclTHENS - (assert_tac true (Name (id_of_string l.l_id)) ty) + (assert_tac (Name (id_of_string l.l_id)) ty) [exact_string l.l_proof; tclIDTAC] gl in diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml index 5ad4a288..02173c1f 100644 --- a/contrib/extraction/common.ml +++ b/contrib/extraction/common.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: common.ml 10596 2008-02-27 15:30:11Z letouzey $ i*) +(*i $Id: common.ml 11559 2008-11-07 22:03:34Z letouzey $ i*) open Pp open Util @@ -60,14 +60,14 @@ let unquote s = let s = String.copy s in for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done; s - -let rec dottify = function - | [] -> assert false - | [s] -> unquote s - | s::[""] -> unquote s - | s::l -> (dottify l)^"."^(unquote s) -(*s Uppercase/lowercase renamings. *) +let rec dottify = function + | [] -> assert false + | [s] -> s + | s::[""] -> s + | s::l -> (dottify l)^"."^s + +(*s Uppercase/lowercase renamings. *) let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false @@ -75,9 +75,15 @@ let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id)) let uppercase_id id = id_of_string (String.capitalize (string_of_id id)) -(* [pr_upper_id id] makes 2 String.copy lesser than [pr_id (uppercase_id id)] *) -let pr_upper_id id = str (String.capitalize (string_of_id id)) +type kind = Term | Type | Cons | Mod + +let upperkind = function + | Type -> lang () = Haskell + | Term -> false + | Cons | Mod -> true +let kindcase_id k id = + if upperkind k then uppercase_id id else lowercase_id id (*s de Bruijn environments for programs *) @@ -122,111 +128,109 @@ let get_db_name n (db,_) = (*s Tables of global renamings *) -let keywords = ref Idset.empty -let set_keywords kws = keywords := kws +let register_cleanup, do_cleanup = + let funs = ref [] in + (fun f -> funs:=f::!funs), (fun () -> List.iter (fun f -> f ()) !funs) -let global_ids = ref Idset.empty -let add_global_ids s = global_ids := Idset.add s !global_ids -let global_ids_list () = Idset.elements !global_ids +type phase = Pre | Impl | Intf -let empty_env () = [], !global_ids +let set_phase, get_phase = + let ph = ref Impl in ((:=) ph), (fun () -> !ph) -let mktable () = - let h = Hashtbl.create 97 in - (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h) +let set_keywords, get_keywords = + let k = ref Idset.empty in + ((:=) k), (fun () -> !k) -let mkset () = - let h = Hashtbl.create 97 in - (fun x -> Hashtbl.add h x ()), (Hashtbl.mem h), (fun () -> Hashtbl.clear h) +let add_global_ids, get_global_ids = + let ids = ref Idset.empty in + register_cleanup (fun () -> ids := get_keywords ()); + let add s = ids := Idset.add s !ids + and get () = !ids + in (add,get) -let mktriset () = +let empty_env () = [], get_global_ids () + +let mktable autoclean = let h = Hashtbl.create 97 in - (fun x y z -> Hashtbl.add h (x,y,z) ()), - (fun x y z -> Hashtbl.mem h (x,y,z)), - (fun () -> Hashtbl.clear h) + if autoclean then register_cleanup (fun () -> Hashtbl.clear h); + (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h) -(* For each [global_reference], this table will contain the different parts - of its renaming, in [string list] form. *) -let add_renaming, get_renaming, clear_renaming = mktable () +(* A table recording objects in the first level of all MPfile *) -(* Idem for [module_path]. *) -let add_mp_renaming, get_mp_renaming, clear_mp_renaming = mktable () +let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content = + mktable false -(* A table for function modfstlev_rename *) -let add_modfstlev, get_modfstlev, clear_modfstlev = mktable () +(*s The list of external modules that will be opened initially *) -(* A set of all external objects that will have to be fully qualified *) -let add_static_clash, static_clash, clear_static_clash = mkset () +let mpfiles_add, mpfiles_mem, mpfiles_list, mpfiles_clear = + let m = ref MPset.empty in + let add mp = m:=MPset.add mp !m + and mem mp = MPset.mem mp !m + and list () = MPset.elements !m + and clear () = m:=MPset.empty + in + register_cleanup clear; + (add,mem,list,clear) -(* Two tables of triplets [kind * module_path * string]. The first one - will record the first level of all MPfile, not only the current one. - The second table will contains local renamings. *) +(*s table indicating the visible horizon at a precise moment, + i.e. the stack of structures we are inside. -type kind = Term | Type | Cons | Mod + - The sequence of [mp] parts should have the following form: + [X.Y; X; A.B.C; A.B; A; ...], i.e. each addition should either + be a [MPdot] over the last entry, or something new, mainly + [MPself], or [MPfile] at the beginning. -let add_ext_mpmem, ext_mpmem, clear_ext_mpmem = mktriset () -let add_loc_mpmem, loc_mpmem, clear_loc_mpmem = mktriset () - -(* The list of external modules that will be opened initially *) -let add_mpfiles, mem_mpfiles, list_mpfiles, clear_mpfiles = - let m = ref MPset.empty in - (fun mp -> m:= MPset.add mp !m), - (fun mp -> MPset.mem mp !m), - (fun () -> MPset.elements !m), - (fun () -> m:= MPset.empty) - -(*s table containing the visible horizon at a precise moment *) - -let visible = ref ([] : module_path list) -let pop_visible () = visible := List.tl !visible -let push_visible mp = visible := mp :: !visible -let top_visible_mp () = List.hd !visible - -(*s substitutions for printing signatures *) - -let substs = ref empty_subst -let add_subst msid mp = substs := add_msid msid mp !substs -let subst_mp mp = subst_mp !substs mp -let subst_kn kn = subst_kn !substs kn -let subst_con c = fst (subst_con !substs c) -let subst_ref = function - | ConstRef con -> ConstRef (subst_con con) - | IndRef (kn,i) -> IndRef (subst_kn kn,i) - | ConstructRef ((kn,i),j) -> ConstructRef ((subst_kn kn,i),j) - | _ -> assert false - - -let duplicate_index = ref 0 -let to_duplicate = ref Gmap.empty -let add_duplicate mp l = - incr duplicate_index; - let ren = "Coq__" ^ string_of_int (!duplicate_index) in - to_duplicate := Gmap.add (mp,l) ren !to_duplicate -let check_duplicate mp l = - let mp' = subst_mp mp in - Gmap.find (mp',l) !to_duplicate - -type reset_kind = OnlyLocal | AllButExternal | Everything - -let reset_allbutext () = - clear_loc_mpmem (); - global_ids := !keywords; - clear_renaming (); - clear_mp_renaming (); - clear_modfstlev (); - clear_static_clash (); - clear_mpfiles (); - duplicate_index := 0; - to_duplicate := Gmap.empty; - visible := []; - substs := empty_subst - -let reset_everything () = reset_allbutext (); clear_ext_mpmem () - -let reset_renaming_tables = function - | OnlyLocal -> clear_loc_mpmem () - | AllButExternal -> reset_allbutext () - | Everything -> reset_everything () + - The [content] part is used to recoard all the names already + seen at this level. + + - The [subst] part is here mainly for printing signature + (in which names are still short, i.e. relative to a [msid]). +*) + +type visible_layer = { mp : module_path; + content : ((kind*string),unit) Hashtbl.t } + +let pop_visible, push_visible, get_visible, subst_mp = + let vis = ref [] and sub = ref [empty_subst] in + register_cleanup (fun () -> vis := []; sub := [empty_subst]); + let pop () = + let v = List.hd !vis in + (* we save the 1st-level-content of MPfile for later use *) + if get_phase () = Impl && modular () && is_modfile v.mp + then add_mpfiles_content v.mp v.content; + vis := List.tl !vis; + sub := List.tl !sub + and push mp o = + vis := { mp = mp; content = Hashtbl.create 97 } :: !vis; + let s = List.hd !sub in + let s = match o with None -> s | Some msid -> add_msid msid mp s in + sub := s :: !sub + and get () = !vis + and subst mp = subst_mp (List.hd !sub) mp + in (pop,push,get,subst) + +let get_visible_mps () = List.map (function v -> v.mp) (get_visible ()) +let top_visible () = match get_visible () with [] -> assert false | v::_ -> v +let top_visible_mp () = (top_visible ()).mp +let add_visible ks = Hashtbl.add (top_visible ()).content ks () + +(* table of local module wrappers used to provide non-ambiguous names *) + +let add_duplicate, check_duplicate = + let index = ref 0 and dups = ref Gmap.empty in + register_cleanup (fun () -> index := 0; dups := Gmap.empty); + let add mp l = + incr index; + let ren = "Coq__" ^ string_of_int (!index) in + dups := Gmap.add (mp,l) ren !dups + and check mp l = Gmap.find (subst_mp mp, l) !dups + in (add,check) + +type reset_kind = AllButExternal | Everything + +let reset_renaming_tables flag = + do_cleanup (); + if flag = Everything then clear_mpfiles_content () (*S Renaming functions *) @@ -235,248 +239,200 @@ let reset_renaming_tables = function with previous [Coq_id] variable, these prefixes are duplicated if already existing. *) -let modular_rename up id = +let modular_rename k id = let s = string_of_id id in - let prefix = if up then "Coq_" else "coq_" in - let check = if up then is_upper else is_lower in - if not (check s) || - (Idset.mem id !keywords) || - (String.length s >= 4 && String.sub s 0 4 = prefix) + let prefix,is_ok = + if upperkind k then "Coq_",is_upper else "coq_",is_lower + in + if not (is_ok s) || + (Idset.mem id (get_keywords ())) || + (String.length s >= 4 && String.sub s 0 4 = prefix) then prefix ^ s else s -(*s [record_contents_fstlev] finds the names of the first-level objects - exported by the ground-level modules in [struc]. *) - -let rec record_contents_fstlev struc = - let upper_type = (lang () = Haskell) in - let addtyp mp id = add_ext_mpmem Type mp (modular_rename upper_type id) in - let addcons mp id = add_ext_mpmem Cons mp (modular_rename true id) in - let addterm mp id = add_ext_mpmem Term mp (modular_rename false id) in - let addmod mp id = add_ext_mpmem Mod mp (modular_rename true id) in - let addfix mp r = - add_ext_mpmem Term mp (modular_rename false (id_of_global r)) - in - let f mp = function - | (l,SEdecl (Dind (_,ind))) -> - Array.iter - (fun ip -> - addtyp mp ip.ip_typename; Array.iter (addcons mp) ip.ip_consnames) - ind.ind_packets - | (l,SEdecl (Dtype _)) -> addtyp mp (id_of_label l) - | (l,SEdecl (Dterm _)) -> addterm mp (id_of_label l) - | (l,SEdecl (Dfix (rv,_,_))) -> Array.iter (addfix mp) rv - | (l,SEmodule _) -> addmod mp (id_of_label l) - | (l,SEmodtype _) -> addmod mp (id_of_label l) - in - List.iter (fun (mp,sel) -> List.iter (f mp) sel) struc - (*s For monolithic extraction, first-level modules might have to be renamed with unique numbers *) -let modfstlev_rename l = - let coqid = id_of_string "Coq" in - let id = id_of_label l in - try - let coqset = get_modfstlev id in - let nextcoq = next_ident_away coqid coqset in - add_modfstlev id (nextcoq::coqset); - (string_of_id nextcoq)^"_"^(string_of_id id) - with Not_found -> - let s = string_of_id id in - if is_lower s || begins_with_CoqXX s then - (add_modfstlev id [coqid]; "Coq_"^s) - else - (add_modfstlev id []; s) - - -(*s Creating renaming for a [module_path] *) - -let rec mp_create_renaming mp = - try get_mp_renaming mp - with Not_found -> - let ren = match mp with - | _ when not (modular ()) && at_toplevel mp -> [""] - | MPdot (mp,l) -> - let lmp = mp_create_renaming mp in - if lmp = [""] then (modfstlev_rename l)::lmp - else (modular_rename true (id_of_label l))::lmp - | MPself msid -> [modular_rename true (id_of_msid msid)] - | MPbound mbid -> [modular_rename true (id_of_mbid mbid)] - | MPfile _ when not (modular ()) -> assert false - | MPfile _ -> [string_of_modfile mp] - in add_mp_renaming mp ren; ren - -(* [clash mp0 s mpl] checks if [mp0-s] can be printed as [s] when - [mpl] is the context of visible modules. More precisely, we check if - there exists a [mp] in [mpl] that contains [s]. +let modfstlev_rename = + let add_prefixes,get_prefixes,_ = mktable true in + fun l -> + let coqid = id_of_string "Coq" in + let id = id_of_label l in + try + let coqset = get_prefixes id in + let nextcoq = next_ident_away coqid coqset in + add_prefixes id (nextcoq::coqset); + (string_of_id nextcoq)^"_"^(string_of_id id) + with Not_found -> + let s = string_of_id id in + if is_lower s || begins_with_CoqXX s then + (add_prefixes id [coqid]; "Coq_"^s) + else + (add_prefixes id []; s) + +(*s Creating renaming for a [module_path] : first, the real function ... *) + +let rec mp_renaming_fun mp = match mp with + | _ when not (modular ()) && at_toplevel mp -> [""] + | MPdot (mp,l) -> + let lmp = mp_renaming mp in + if lmp = [""] then (modfstlev_rename l)::lmp + else (modular_rename Mod (id_of_label l))::lmp + | MPself msid -> [modular_rename Mod (id_of_msid msid)] + | MPbound mbid -> [modular_rename Mod (id_of_mbid mbid)] + | MPfile _ when not (modular ()) -> assert false (* see [at_toplevel] above *) + | MPfile _ -> + assert (get_phase () = Pre); + let current_mpfile = (list_last (get_visible ())).mp in + if mp <> current_mpfile then mpfiles_add mp; + [string_of_modfile mp] + +(* ... and its version using a cache *) + +and mp_renaming = + let add,get,_ = mktable true in + fun x -> try get x with Not_found -> let y = mp_renaming_fun x in add x y; y + +(*s Renamings creation for a [global_reference]: we build its fully-qualified + name in a [string list] form (head is the short name). *) + +let ref_renaming_fun (k,r) = + let mp = subst_mp (modpath_of_r r) in + let l = mp_renaming mp in + let s = + if l = [""] (* this happens only at toplevel of the monolithic case *) + then + let globs = Idset.elements (get_global_ids ()) in + let id = next_ident_away (kindcase_id k (safe_id_of_global r)) globs in + string_of_id id + else modular_rename k (safe_id_of_global r) + in + add_global_ids (id_of_string s); + s::l + +(* Cached version of the last function *) + +let ref_renaming = + let add,get,_ = mktable true in + fun x -> try get x with Not_found -> let y = ref_renaming_fun x in add x y; y + +(* [visible_clash mp0 (k,s)] checks if [mp0-s] of kind [k] + can be printed as [s] in the current context of visible + modules. More precisely, we check if there exists a + visible [mp] that contains [s]. The verification stops if we encounter [mp=mp0]. *) -let rec clash mem mp0 s = function +let rec clash mem mp0 ks = function | [] -> false | mp :: _ when mp = mp0 -> false - | mp :: mpl -> mem mp s || clash mem mp0 s mpl - -(*s Initial renamings creation, for modular extraction. *) - -let create_modular_renamings struc = - let current_module = fst (List.hd struc) in - let { typ = ty ; trm = tr ; cons = co } = struct_get_references_set struc - in - (* 1) creates renamings of objects *) - let add upper r = - let mp = modpath_of_r r in - let l = mp_create_renaming mp in - let s = modular_rename upper (id_of_global r) in - add_global_ids (id_of_string s); - add_renaming r (s::l); - begin try - let mp = modfile_of_mp mp in if mp <> current_module then add_mpfiles mp - with Not_found -> () - end; - in - Refset.iter (add (lang () = Haskell)) ty; - Refset.iter (add true) co; - Refset.iter (add false) tr; - - (* 2) determines the opened libraries. *) - let used_modules = list_mpfiles () in - let used_modules' = List.rev used_modules in - let str_list = List.map string_of_modfile used_modules' - in - let rec check_elsewhere mpl sl = match mpl, sl with - | [], [] -> [] - | mp::mpl, _::sl -> - if List.exists (ext_mpmem Mod mp) sl then - check_elsewhere mpl sl - else mp :: (check_elsewhere mpl sl) - | _ -> assert false - in - let opened_modules = check_elsewhere used_modules' str_list in - clear_mpfiles (); - List.iter add_mpfiles opened_modules; - - (* 3) determines the potential clashes *) - let needs_qualify k r = - let mp = modpath_of_r r in - if (is_modfile mp) && mp <> current_module && - (clash (ext_mpmem k) mp (List.hd (get_renaming r)) opened_modules) - then add_static_clash r - in - Refset.iter (needs_qualify Type) ty; - Refset.iter (needs_qualify Term) tr; - Refset.iter (needs_qualify Cons) co; - List.rev opened_modules - -(*s Initial renamings creation, for monolithic extraction. *) - -let create_mono_renamings struc = - let { typ = ty ; trm = tr ; cons = co } = struct_get_references_list struc in - let add upper r = - let mp = modpath_of_r r in - let l = mp_create_renaming mp in - let mycase = if upper then uppercase_id else lowercase_id in - let id = - if l = [""] then - next_ident_away (mycase (id_of_global r)) (global_ids_list ()) - else id_of_string (modular_rename upper (id_of_global r)) - in - add_global_ids id; - add_renaming r ((string_of_id id)::l) - in - List.iter (add (lang () = Haskell)) (List.rev ty); - List.iter (add false) (List.rev tr); - List.iter (add true) (List.rev co); - [] - -let create_renamings struc = - if modular () then create_modular_renamings struc - else create_mono_renamings struc - - + | mp :: _ when mem mp ks -> true + | _ :: mpl -> clash mem mp0 ks mpl + +let mpfiles_clash mp0 ks = + clash (fun mp -> Hashtbl.mem (get_mpfiles_content mp)) mp0 ks + (List.rev (mpfiles_list ())) + +let visible_clash mp0 ks = + let rec clash = function + | [] -> false + | v :: _ when v.mp = mp0 -> false + | v :: _ when Hashtbl.mem v.content ks -> true + | _ :: vis -> clash vis + in clash (get_visible ()) + +(* After the 1st pass, we can decide which modules will be opened initially *) + +let opened_libraries () = + if not (modular ()) then [] + else + let used = mpfiles_list () in + let rec check_elsewhere avoid = function + | [] -> [] + | mp :: mpl -> + let clash s = Hashtbl.mem (get_mpfiles_content mp) (Mod,s) in + if List.exists clash avoid + then check_elsewhere avoid mpl + else mp :: check_elsewhere (string_of_modfile mp :: avoid) mpl + in + let opened = check_elsewhere [] used in + mpfiles_clear (); + List.iter mpfiles_add opened; + opened + (*s On-the-fly qualification issues for both monolithic or modular extraction. *) -let pp_global k r = - let ls = get_renaming r in - assert (List.length ls > 1); - let s = List.hd ls in - let mp = modpath_of_r r in - if mp = top_visible_mp () then +(* First, a function that factorize the printing of both [global_reference] + and module names for ocaml. When [k=Mod] then [olab=None], otherwise it + contains the label of the reference to print. + Invariant: [List.length ls >= 2], simpler situations are handled elsewhere. *) + +let pp_gen k mp ls olab = + try (* what is the largest prefix of [mp] that belongs to [visible]? *) + let prefix = common_prefix_from_list mp (get_visible_mps ()) in + let delta = mp_length mp - mp_length prefix in + assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *) + let ls = list_firstn (delta + if k = Mod then 0 else 1) ls in + let s,ls' = list_sep_last ls in + (* Reference r / module path mp is of the form [.s.]. + Difficulty: in ocaml the prefix part cannot be used for + qualification (we are inside it) and the rest of the long + name may be hidden. + Solution: we duplicate the _definition_ of r / mp in a Coq__XXX module *) + let k' = if ls' = [] then k else Mod in + if visible_clash prefix (k',s) then + let front = if ls' = [] && k <> Mod then [s] else ls' in + let lab = (* label associated with s *) + if delta = 0 && k <> Mod then Option.get olab + else get_nth_label_mp delta mp + in + try dottify (front @ [check_duplicate prefix lab]) + with Not_found -> + assert (get_phase () = Pre); (* otherwise it's too late *) + add_duplicate prefix lab; dottify ls + else dottify ls + with Not_found -> + (* [mp] belongs to a closed module, not one of [visible]. *) + let base = base_mp mp in + let base_s,ls1 = list_sep_last ls in + let s,ls2 = list_sep_last ls1 in + (* [List.rev ls] is [base_s :: s :: List.rev ls2] *) + let k' = if ls2 = [] then k else Mod in + if modular () && (mpfiles_mem base) && + (not (mpfiles_clash base (k',s))) && + (not (visible_clash base (k',s))) + then (* Standard situation of an object in another file: *) + (* Thanks to the "open" of this file we remove its name *) + dottify ls1 + else if visible_clash base (Mod,base_s) then + error_module_clash base_s + else dottify ls + +let pp_global k r = + let ls = ref_renaming (k,r) in + assert (List.length ls > 1); + let s = List.hd ls in + let mp = subst_mp (modpath_of_r r) in + if mp = top_visible_mp () then (* simpliest situation: definition of r (or use in the same context) *) (* we update the visible environment *) - (add_loc_mpmem k mp s; unquote s) - else match lang () with + (add_visible (k,s); unquote s) + else match lang () with | Scheme -> unquote s (* no modular Scheme extraction... *) - | Haskell -> - (* for the moment we always qualify in modular Haskell *) - if modular () then dottify ls else s - | Ocaml -> - try (* has [mp] something in common with one of [!visible] ? *) - let prefix = common_prefix_from_list mp !visible in - let delta = mp_length mp - mp_length prefix in - let ls = list_firstn (delta+1) ls in - (* Difficulty: in ocaml we cannot qualify more than [ls], - but this (not-so-long) name can in fact be hidden. Solution: - duplication of the _definition_ of r in a Coq__XXX module *) - let s,ls' = list_sep_last ls in - let k' = if ls' = [] then k else Mod in - if clash (loc_mpmem k') prefix s !visible then - let front = if ls' = [] then [s] else ls' in - let l = get_nth_label delta r in - try dottify (front @ [check_duplicate prefix l]) - with Not_found -> add_duplicate prefix l; dottify ls - else dottify ls - with Not_found -> - (* [mp] belongs to a closed module, not one of [!visible]. *) - let base = base_mp mp in - let base_s,ls1 = list_sep_last ls in - let s,ls2 = list_sep_last ls1 in - let k' = if ls2 = [] then k else Mod in - if modular () && (mem_mpfiles base) && - not (static_clash r) && - (* k' = Mod can't clash in an opened module, see earlier check *) - not (clash (loc_mpmem k') base s !visible) - then (* Standard situation of an object in another file: *) - (* Thanks to the "open" of this file we remove its name *) - dottify ls1 - else if clash (loc_mpmem Mod) base base_s !visible then - error_module_clash base_s - else dottify ls - + | Haskell -> if modular () then dottify ls else s + (* for the moment we always qualify in modular Haskell... *) + | Ocaml -> pp_gen k mp ls (Some (label_of_r r)) + (* The next function is used only in Ocaml extraction...*) -let pp_module mp = - let ls = mp_create_renaming mp in - if List.length ls = 1 then dottify ls - else match mp with - | MPdot (mp0,_) when mp0 = top_visible_mp () -> +let pp_module mp = + let mp = subst_mp mp in + let ls = mp_renaming mp in + if List.length ls = 1 then dottify ls + else match mp with + | MPdot (mp0,_) when mp0 = top_visible_mp () -> (* simpliest situation: definition of mp (or use in the same context) *) (* we update the visible environment *) - let s = List.hd ls in - add_loc_mpmem Mod mp0 s; s - | _ -> - try (* has [mp] something in common with one of those in [!visible] ? *) - let prefix = common_prefix_from_list mp !visible in - assert (mp <> prefix); (* no use of mp as whole module from itself *) - let delta = mp_length mp - mp_length prefix in - let ls = list_firstn delta ls in - (* Difficulty: in ocaml we cannot qualify more than [ls], - but this (not-so-long) name can in fact be hidden. Solution: - duplication of the _definition_ of mp via a Coq__XXX module *) - let s,ls' = list_sep_last ls in - if clash (loc_mpmem Mod) prefix s !visible then - let l = get_nth_label_mp delta mp in - try dottify (ls' @ [check_duplicate prefix l]) - with Not_found -> add_duplicate prefix l; dottify ls - else dottify ls - with Not_found -> - (* [mp] belongs to a closed module, not one of [!visible]. *) - let base = base_mp mp in - let base_s,ls' = list_sep_last ls in - let s = fst (list_sep_last ls) in - if modular () && (mem_mpfiles base) && - not (clash (loc_mpmem Mod) base s !visible) - then dottify ls' - else if clash (loc_mpmem Mod) base base_s !visible then - error_module_clash base_s - else dottify ls + let s = List.hd ls in + add_visible (Mod,s); s + | _ -> pp_gen Mod mp ls None + diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli index 5cd26584..b7e70414 100644 --- a/contrib/extraction/common.mli +++ b/contrib/extraction/common.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: common.mli 10232 2007-10-17 12:32:10Z letouzey $ i*) +(*i $Id: common.mli 11559 2008-11-07 22:03:34Z letouzey $ i*) open Names open Libnames @@ -24,11 +24,6 @@ val pr_binding : identifier list -> std_ppcmds val rename_id : identifier -> Idset.t -> identifier -val lowercase_id : identifier -> identifier -val uppercase_id : identifier -> identifier - -val pr_upper_id : identifier -> std_ppcmds - type env = identifier list * Idset.t val empty_env : unit -> env @@ -37,9 +32,12 @@ val rename_tvars: Idset.t -> identifier list -> identifier list val push_vars : identifier list -> env -> identifier list * env val get_db_name : int -> env -> identifier -val record_contents_fstlev : ml_structure -> unit +type phase = Pre | Impl | Intf -val create_renamings : ml_structure -> module_path list +val set_phase : phase -> unit +val get_phase : unit -> phase + +val opened_libraries : unit -> module_path list type kind = Term | Type | Cons | Mod @@ -47,14 +45,12 @@ val pp_global : kind -> global_reference -> string val pp_module : module_path -> string val top_visible_mp : unit -> module_path -val push_visible : module_path -> unit +val push_visible : module_path -> mod_self_id option -> unit val pop_visible : unit -> unit -val add_subst : mod_self_id -> module_path -> unit - val check_duplicate : module_path -> label -> string -type reset_kind = OnlyLocal | AllButExternal | Everything +type reset_kind = AllButExternal | Everything val reset_renaming_tables : reset_kind -> unit diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml index 311b42c0..49a86200 100644 --- a/contrib/extraction/extract_env.ml +++ b/contrib/extraction/extract_env.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extract_env.ml 10794 2008-04-15 00:12:06Z letouzey $ i*) +(*i $Id: extract_env.ml 11846 2009-01-22 18:55:10Z letouzey $ i*) open Term open Declarations @@ -83,8 +83,8 @@ module type VISIT = sig end module Visit : VISIT = struct - (* Thanks to C.S.C, what used to be in a single KNset should now be split - into a KNset (for inductives and modules names) and a Cset for constants + (* What used to be in a single KNset should now be split into a KNset + (for inductives and modules names) and a Cset for constants (and still the remaining MPset) *) type must_visit = { mutable kn : KNset.t; mutable con : Cset.t; mutable mp : MPset.t } @@ -140,6 +140,30 @@ let factor_fix env l cb msb = labels, recd, msb'' end +let build_mb expr typ_opt = + { mod_expr = Some expr; + mod_type = typ_opt; + mod_constraints = Univ.Constraint.empty; + mod_alias = Mod_subst.empty_subst; + mod_retroknowledge = [] } + +let my_type_of_mb env mb = + match mb.mod_type with + | Some mtb -> mtb + | None -> Modops.eval_struct env (Option.get mb.mod_expr) + +(** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. + To check with Elie. *) + +let env_for_mtb_with env mtb idl = + let msid,sig_b = match Modops.eval_struct env mtb with + | SEBstruct(msid,sig_b) -> msid,sig_b + | _ -> assert false + in + let l = label_of_id (List.hd idl) in + let before = fst (list_split_at (fun (l',_) -> l=l') sig_b) in + Modops.add_signature (MPself msid) before env + (* From a [structure_body] (i.e. a list of [structure_field_body]) to specifications. *) @@ -151,7 +175,7 @@ let rec extract_sfb_spec env mp = function let specs = extract_sfb_spec env mp msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end - | (l,SFBmind cb) :: msig -> + | (l,SFBmind _) :: msig -> let kn = make_kn mp empty_dirpath l in let s = Sind (kn, extract_inductive env kn) in let specs = extract_sfb_spec env mp msig in @@ -159,45 +183,52 @@ let rec extract_sfb_spec env mp = function else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmodule mb) :: msig -> let specs = extract_sfb_spec env mp msig in - let mtb = Modops.type_of_mb env mb in - let spec = extract_seb_spec env (mb.mod_type<>None) mtb in + let spec = extract_seb_spec env (my_type_of_mb env mb) in (l,Smodule spec) :: specs | (l,SFBmodtype mtb) :: msig -> let specs = extract_sfb_spec env mp msig in - (l,Smodtype (extract_seb_spec env true(*?*) mtb.typ_expr)) :: specs - | (l,SFBalias(mp1,_))::msig -> - extract_sfb_spec env mp - ((l,SFBmodule {mod_expr = Some (SEBident mp1); - mod_type = None; - mod_constraints = Univ.Constraint.empty; - mod_alias = Mod_subst.empty_subst; - mod_retroknowledge = []})::msig) + (l,Smodtype (extract_seb_spec env mtb.typ_expr)) :: specs + | (l,SFBalias(mp1,typ_opt,_))::msig -> + let mb = build_mb (SEBident mp1) typ_opt in + extract_sfb_spec env mp ((l,SFBmodule mb) :: msig) (* From [struct_expr_body] to specifications *) +(* Invariant: the [seb] given to [extract_seb_spec] should either come: + - from a [mod_type] or [type_expr] field + - from the output of [Modops.eval_struct]. + This way, any encountered [SEBident] should be a true module type. + For instance, [my_type_of_mb] ensures this invariant. +*) -and extract_seb_spec env truetype = function - | SEBident kn when truetype -> Visit.add_mp kn; MTident kn +and extract_seb_spec env = function + | SEBident mp -> Visit.add_mp mp; MTident mp | SEBwith(mtb',With_definition_body(idl,cb))-> - let mtb''= extract_seb_spec env truetype mtb' in - (match extract_with_type env cb with (* cb peut contenir des kn *) + let env' = env_for_mtb_with env mtb' idl in + let mtb''= extract_seb_spec env mtb' in + (match extract_with_type env' cb with (* cb peut contenir des kn *) | None -> mtb'' | Some (vl,typ) -> MTwith(mtb'',ML_With_type(idl,vl,typ))) - | SEBwith(mtb',With_module_body(idl,mp,_))-> + | SEBwith(mtb',With_module_body(idl,mp,_,_))-> Visit.add_mp mp; - MTwith(extract_seb_spec env truetype mtb', + MTwith(extract_seb_spec env mtb', ML_With_module(idl,mp)) +(* TODO: On pourrait peut-etre oter certaines eta-expansion, du genre: + | SEBfunctor(mbid,_,SEBapply(m,SEBident (MPbound mbid2),_)) + when mbid = mbid2 -> extract_seb_spec env m + (* faudrait alors ajouter un test de non-apparition de mbid dans mb *) +*) | SEBfunctor (mbid, mtb, mtb') -> let mp = MPbound mbid in let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in - MTfunsig (mbid, extract_seb_spec env true mtb.typ_expr, - extract_seb_spec env' truetype mtb') + MTfunsig (mbid, extract_seb_spec env mtb.typ_expr, + extract_seb_spec env' mtb') | SEBstruct (msid, msig) -> let mp = MPself msid in let env' = Modops.add_signature mp msig env in MTsig (msid, extract_sfb_spec env' mp msig) - | (SEBapply _|SEBident _ (*when not truetype*)) as mtb -> - extract_seb_spec env truetype (Modops.eval_struct env mtb) + | SEBapply _ as mtb -> + extract_seb_spec env (Modops.eval_struct env mtb) (* From a [structure_body] (i.e. a list of [structure_field_body]) @@ -248,19 +279,11 @@ let rec extract_sfb env mp all = function let ms = extract_sfb env mp all msb in let mp = MPdot (mp,l) in if all || Visit.needed_mp mp then - (l,SEmodtype (extract_seb_spec env true(*?*) mtb.typ_expr)) :: ms - else ms - | (l,SFBalias (mp1,cst)) :: msb -> - let ms = extract_sfb env mp all msb in - let mp = MPdot (mp,l) in - if all || Visit.needed_mp mp then - (l,SEmodule (extract_module env mp true - {mod_expr = Some (SEBident mp1); - mod_type = None; - mod_constraints= Univ.Constraint.empty; - mod_alias = empty_subst; - mod_retroknowledge = []})) :: ms + (l,SEmodtype (extract_seb_spec env mtb.typ_expr)) :: ms else ms + | (l,SFBalias (mp1,typ_opt,_)) :: msb -> + let mb = build_mb (SEBident mp1) typ_opt in + extract_sfb env mp all ((l,SFBmodule mb) :: msb) (* From [struct_expr_body] to implementations *) @@ -274,7 +297,7 @@ and extract_seb env mpo all = function | SEBfunctor (mbid, mtb, meb) -> let mp = MPbound mbid in let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in - MEfunctor (mbid, extract_seb_spec env true mtb.typ_expr, + MEfunctor (mbid, extract_seb_spec env mtb.typ_expr, extract_seb env' None true meb) | SEBstruct (msid, msb) -> let mp,msb = match mpo with @@ -288,17 +311,8 @@ and extract_seb env mpo all = function and extract_module env mp all mb = (* [mb.mod_expr <> None ], since we look at modules from outside. *) (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *) - let meb = Option.get mb.mod_expr in - let mtb = match mb.mod_type with - | None -> Modops.eval_struct env meb - | Some mt -> mt - in - (* Because of the "with" construct, the module type can be [MTBsig] with *) - (* a msid different from the one of the module. Here is the patch. *) - (* PL 26/02/2008: is this still relevant ? - let mtb = replicate_msid meb mtb in *) - { ml_mod_expr = extract_seb env (Some mp) all meb; - ml_mod_type = extract_seb_spec env (mb.mod_type<>None) mtb } + { ml_mod_expr = extract_seb env (Some mp) all (Option.get mb.mod_expr); + ml_mod_type = extract_seb_spec env (my_type_of_mb env mb) } let unpack = function MEstruct (_,sel) -> sel | _ -> assert false @@ -345,28 +359,38 @@ let mono_filename f = (* Builds a suitable filename from a module id *) -let module_filename m = - let d = descr () in - let f = if d.capital_file then String.capitalize else String.uncapitalize in - let fn = f (string_of_id m) in - Some (fn^d.file_suffix), Option.map ((^) fn) d.sig_suffix, m +let module_filename fc = + let d = descr () in + let fn = if d.capital_file then fc else String.uncapitalize fc + in + Some (fn^d.file_suffix), Option.map ((^) fn) d.sig_suffix, id_of_string fc (*s Extraction of one decl to stdout. *) let print_one_decl struc mp decl = - let d = descr () in - reset_renaming_tables AllButExternal; - ignore (create_renamings struc); - push_visible mp; - msgnl (d.pp_decl decl); + let d = descr () in + reset_renaming_tables AllButExternal; + set_phase Pre; + ignore (d.pp_struct struc); + set_phase Impl; + push_visible mp None; + msgnl (d.pp_decl decl); pop_visible () (*s Extraction of a ml struct to a file. *) -let print_structure_to_file (fn,si,mo) struc = - let d = descr () in - reset_renaming_tables AllButExternal; - let used_modules = create_renamings struc in +let formatter dry file = + if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) + else match file with + | None -> !Pp_control.std_ft + | Some cout -> + let ft = Pp_control.with_output_to cout in + Option.iter (Format.pp_set_margin ft) (Pp_control.get_margin ()); + ft + +let print_structure_to_file (fn,si,mo) dry struc = + let d = descr () in + reset_renaming_tables AllButExternal; let unsafe_needs = { mldummy = struct_ast_search ((=) MLdummy) struc; tdummy = struct_type_search Mlutil.isDummy struc; @@ -375,40 +399,39 @@ let print_structure_to_file (fn,si,mo) struc = if lang () <> Haskell then false else struct_ast_search (function MLmagic _ -> true | _ -> false) struc } in - (* print the implementation *) - let cout = Option.map open_out fn in - let ft = match cout with - | None -> !Pp_control.std_ft - | Some cout -> Pp_control.with_output_to cout in - begin try - msg_with ft (d.preamble mo used_modules unsafe_needs); - if lang () = Ocaml then begin - (* for computing objects to duplicate *) - let devnull = Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) in - msg_with devnull (d.pp_struct struc); - reset_renaming_tables OnlyLocal; - end; + (* First, a dry run, for computing objects to rename or duplicate *) + set_phase Pre; + let devnull = formatter true None in + msg_with devnull (d.pp_struct struc); + let opened = opened_libraries () in + (* Print the implementation *) + let cout = if dry then None else Option.map open_out fn in + let ft = formatter dry cout in + begin try + (* The real printing of the implementation *) + set_phase Impl; + msg_with ft (d.preamble mo opened unsafe_needs); msg_with ft (d.pp_struct struc); Option.iter close_out cout; with e -> Option.iter close_out cout; raise e end; - Option.iter info_file fn; - (* print the signature *) - Option.iter - (fun si -> + if not dry then Option.iter info_file fn; + (* Now, let's print the signature *) + Option.iter + (fun si -> let cout = open_out si in - let ft = Pp_control.with_output_to cout in - begin try - msg_with ft (d.sig_preamble mo used_modules unsafe_needs); - reset_renaming_tables OnlyLocal; + let ft = formatter false (Some cout) in + begin try + set_phase Intf; + msg_with ft (d.sig_preamble mo opened unsafe_needs); msg_with ft (d.pp_sig (signature_of_structure struc)); close_out cout; with e -> close_out cout; raise e end; info_file si) - si + (if dry then None else si) (*********************************************) @@ -426,51 +449,56 @@ let init modular = reset (); if modular && lang () = Scheme then error_scheme () +(* From a list of [reference], let's retrieve whether they correspond + to modules or [global_reference]. Warn the user if both is possible. *) + +let rec locate_ref = function + | [] -> [],[] + | r::l -> + let q = snd (qualid_of_reference r) in + let mpo = try Some (Nametab.locate_module q) with Not_found -> None + and ro = try Some (Nametab.locate q) with Not_found -> None in + match mpo, ro with + | None, None -> Nametab.error_global_not_found q + | None, Some r -> let refs,mps = locate_ref l in r::refs,mps + | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps + | Some mp, Some r -> + warning_both_mod_and_cst q mp r; + let refs,mps = locate_ref l in refs,mp::mps (*s Recursive extraction in the Coq toplevel. The vernacular command is \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when extracting to a file with the command: \verb!Extraction "file"! [qualid1] ... [qualidn]. *) -let full_extraction f qualids = - init false; - let rec find = function - | [] -> [],[] - | q::l -> - let refs,mps = find l in - try - let mp = Nametab.locate_module (snd (qualid_of_reference q)) in - if is_modfile mp then error_MPfile_as_mod mp true; - refs,(mp::mps) - with Not_found -> (Nametab.global q)::refs, mps - in - let refs,mps = find qualids in - let struc = optimize_struct refs (mono_environment refs mps) in - warning_axioms (); - print_structure_to_file (mono_filename f) struc; +let full_extr f (refs,mps) = + init false; + List.iter (fun mp -> if is_modfile mp then error_MPfile_as_mod mp true) mps; + let struc = optimize_struct refs (mono_environment refs mps) in + warning_axioms (); + print_structure_to_file (mono_filename f) false struc; reset () +let full_extraction f lr = full_extr f (locate_ref lr) + (*s Simple extraction in the Coq toplevel. The vernacular command is \verb!Extraction! [qualid]. *) -let simple_extraction qid = - init false; - try - let mp = Nametab.locate_module (snd (qualid_of_reference qid)) in - if is_modfile mp then error_MPfile_as_mod mp true; - full_extraction None [qid] - with Not_found -> - let r = Nametab.global qid in - if is_custom r then - msgnl (str "User defined extraction:" ++ spc () ++ - str (find_custom r) ++ fnl ()) - else - let struc = optimize_struct [r] (mono_environment [r] []) in - let d = get_decl_in_structure r struc in - warning_axioms (); - print_one_decl struc (modpath_of_r r) d; - reset () +let simple_extraction r = match locate_ref [r] with + | ([], [mp]) as p -> full_extr None p + | [r],[] -> + init false; + if is_custom r then + msgnl (str "User defined extraction:" ++ spc () ++ + str (find_custom r) ++ fnl ()) + else + let struc = optimize_struct [r] (mono_environment [r] []) in + let d = get_decl_in_structure r struc in + warning_axioms (); + print_one_decl struc (modpath_of_r r) d; + reset () + | _ -> assert false (*s (Recursive) Extraction of a library. The vernacular command is @@ -489,19 +517,16 @@ let extraction_library is_rec m = if Visit.needed_mp mp then (mp, unpack (extract_seb env (Some mp) true meb)) :: l else l - in - let struc = List.fold_left select [] l in - let struc = optimize_struct [] struc in - warning_axioms (); - record_contents_fstlev struc; - let rec print = function - | [] -> () - | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l - | (MPfile dir, sel) as e :: l -> - let short_m = snd (split_dirpath dir) in - print_structure_to_file (module_filename short_m) [e]; - print l + in + let struc = List.fold_left select [] l in + let struc = optimize_struct [] struc in + warning_axioms (); + let print = function + | (MPfile dir as mp, sel) as e -> + let dry = not is_rec && dir <> dir_m in + let s = string_of_modfile mp in + print_structure_to_file (module_filename s) dry [e] | _ -> assert false - in - print struc; + in + List.iter print struc; reset () diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml index fdc84a64..fa006c1c 100644 --- a/contrib/extraction/extraction.ml +++ b/contrib/extraction/extraction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraction.ml 10497 2008-02-01 12:18:37Z soubiran $ i*) +(*i $Id: extraction.ml 11459 2008-10-16 16:29:07Z letouzey $ i*) (*i*) open Util @@ -876,19 +876,17 @@ let extract_constant_spec env kn cb = let t = snd (record_constant_type env kn (Some typ)) in Sval (r, type_expunge env t) -let extract_with_type env cb = - let typ = Typeops.type_of_constant_type env cb.const_type in - match flag_of_type env typ with - | (_ , Default) -> None - | (Logic, TypeScheme) ->Some ([],Tdummy Ktype) - | (Info, TypeScheme) -> - let s,vl = type_sign_vl env typ in - (match cb.const_body with - | None -> assert false - | Some body -> - let db = db_from_sign s in - let t = extract_type_scheme env db (force body) (List.length s) - in Some ( vl, t) ) +let extract_with_type env cb = + let typ = Typeops.type_of_constant_type env cb.const_type in + match flag_of_type env typ with + | (Info, TypeScheme) -> + let s,vl = type_sign_vl env typ in + let body = Option.get cb.const_body in + let db = db_from_sign s in + let t = extract_type_scheme env db (force body) (List.length s) in + Some (vl, t) + | _ -> None + let extract_inductive env kn = let ind = extract_ind env kn in diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4 index cb95808d..345cb307 100644 --- a/contrib/extraction/g_extraction.ml4 +++ b/contrib/extraction/g_extraction.ml4 @@ -27,7 +27,13 @@ END open Table open Extract_env +let pr_language = function + | Ocaml -> str "Ocaml" + | Haskell -> str "Haskell" + | Scheme -> str "Scheme" + VERNAC ARGUMENT EXTEND language +PRINTED BY pr_language | [ "Ocaml" ] -> [ Ocaml ] | [ "Haskell" ] -> [ Haskell ] | [ "Scheme" ] -> [ Scheme ] @@ -83,6 +89,23 @@ VERNAC COMMAND EXTEND ResetExtractionInline -> [ reset_extraction_inline () ] END +VERNAC COMMAND EXTEND ExtractionBlacklist +(* Force Extraction to not use some filenames *) +| [ "Extraction" "Blacklist" ne_ident_list(l) ] + -> [ extraction_blacklist l ] +END + +VERNAC COMMAND EXTEND PrintExtractionBlacklist +| [ "Print" "Extraction" "Blacklist" ] + -> [ print_extraction_blacklist () ] +END + +VERNAC COMMAND EXTEND ResetExtractionBlacklist +| [ "Reset" "Extraction" "Blacklist" ] + -> [ reset_extraction_blacklist () ] +END + + (* Overriding of a Coq object by an ML one *) VERNAC COMMAND EXTEND ExtractionConstant | [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ] diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml index 0ef225c0..3f0366e6 100644 --- a/contrib/extraction/haskell.ml +++ b/contrib/extraction/haskell.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: haskell.ml 10233 2007-10-17 23:29:08Z letouzey $ i*) +(*i $Id: haskell.ml 11559 2008-11-07 22:03:34Z letouzey $ i*) (*s Production of Haskell syntax. *) @@ -22,6 +22,9 @@ open Common (*s Haskell renaming issues. *) +let pr_lower_id id = str (String.uncapitalize (string_of_id id)) +let pr_upper_id id = str (String.capitalize (string_of_id id)) + let keywords = List.fold_right (fun s -> Idset.add (id_of_string s)) [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; @@ -62,8 +65,6 @@ let pp_abst = function prlist_with_sep (fun () -> (str " ")) pr_id l ++ str " ->" ++ spc ()) -let pr_lower_id id = pr_id (lowercase_id id) - (*s The pretty-printer for haskell syntax *) let pp_global k r = @@ -313,7 +314,7 @@ let pp_structure_elem = function let pp_struct = let pp_sel (mp,sel) = - push_visible mp; + push_visible mp None; let p = prlist_strict pp_structure_elem sel in pop_visible (); p in diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml index 0c906712..68adeb81 100644 --- a/contrib/extraction/modutil.ml +++ b/contrib/extraction/modutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.ml 11262 2008-07-24 20:59:29Z letouzey $ i*) +(*i $Id: modutil.ml 11602 2008-11-18 00:08:33Z letouzey $ i*) open Names open Declarations @@ -18,23 +18,9 @@ open Table open Mlutil open Mod_subst -(*S Functions upon modules missing in [Modops]. *) - -(*s Change a msid in a module type, to follow a module expr. - Because of the "with" construct, the module type of a module can be a - [MTBsig] with a msid different from the one of the module. *) - -let rec replicate_msid meb mtb = match meb,mtb with - | SEBfunctor (_, _, meb), SEBfunctor (mbid, mtb1, mtb2) -> - let mtb' = replicate_msid meb mtb2 in - if mtb' == mtb2 then mtb else SEBfunctor (mbid, mtb1, mtb') - | SEBstruct (msid, _), SEBstruct (msid1, msig) when msid <> msid1 -> - let msig' = Modops.subst_signature_msid msid1 (MPself msid) msig in - if msig' == msig then SEBstruct (msid, msig) else SEBstruct (msid, msig') - | _ -> mtb - (*S Functions upon ML modules. *) -let rec msid_of_mt = function + +let rec msid_of_mt = function | MTident mp -> begin match Modops.eval_struct (Global.env()) (SEBident mp) with | SEBstruct(msid,_) -> MPself msid @@ -42,12 +28,7 @@ let rec msid_of_mt = function end | MTwith(mt,_)-> msid_of_mt mt | _ -> anomaly "Extraction:the With operator isn't applied to a name" - -let make_mp_with mp idl = - let idl_rev = List.rev idl in - let idl' = List.rev (List.tl idl_rev) in - (List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) - mp idl') + (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a [ml_structure]. *) @@ -57,13 +38,12 @@ let struct_iter do_decl do_spec s = | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' | MTwith (mt,ML_With_type(idl,l,t))-> let mp_mt = msid_of_mt mt in - let mp = make_mp_with mp_mt idl in - let gr = ConstRef ( - (make_con mp empty_dirpath - (label_of_id ( - List.hd (List.rev idl))))) in - mt_iter mt;do_decl - (Dtype(gr,l,t)) + let l',idl' = list_sep_last idl in + let mp_w = + List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl' + in + let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in + mt_iter mt; do_decl (Dtype(r,l,t)) | MTwith (mt,_)->mt_iter mt | MTsig (_, sign) -> List.iter spec_iter sign and spec_iter = function @@ -143,41 +123,6 @@ let spec_iter_references do_term do_cons do_type = function | Stype (r,_,ot) -> do_type r; Option.iter (type_iter_references do_type) ot | Sval (r,t) -> do_term r; type_iter_references do_type t -let struct_iter_references do_term do_cons do_type = - struct_iter - (decl_iter_references do_term do_cons do_type) - (spec_iter_references do_term do_cons do_type) - -(*s Get all references used in one [ml_structure], either in [list] or [set]. *) - -type 'a kinds = { mutable typ : 'a ; mutable trm : 'a; mutable cons : 'a } - -let struct_get_references empty add struc = - let o = { typ = empty ; trm = empty ; cons = empty } in - let do_type r = o.typ <- add r o.typ in - let do_term r = o.trm <- add r o.trm in - let do_cons r = o.cons <- add r o.cons in - struct_iter_references do_term do_cons do_type struc; o - -let struct_get_references_set = struct_get_references Refset.empty Refset.add - -module Orefset = struct - type t = { set : Refset.t ; list : global_reference list } - let empty = { set = Refset.empty ; list = [] } - let add r o = - if Refset.mem r o.set then o - else { set = Refset.add r o.set ; list = r :: o.list } - let set o = o.set - let list o = o.list -end - -let struct_get_references_list struc = - let o = struct_get_references Orefset.empty Orefset.add struc in - { typ = Orefset.list o.typ; - trm = Orefset.list o.trm; - cons = Orefset.list o.cons } - - (*s Searching occurrences of a particular term (no lifting done). *) exception Found @@ -411,6 +356,7 @@ let optimize_struct to_appear struc = let opt_struc = List.map (fun (mp,lse) -> (mp, optim_se true to_appear subst lse)) struc in + let opt_struc = List.filter (fun (_,lse) -> lse<>[]) opt_struc in try if modular () then raise NoDepCheck; reset_needed (); diff --git a/contrib/extraction/modutil.mli b/contrib/extraction/modutil.mli index 85d58a4b..e279261d 100644 --- a/contrib/extraction/modutil.mli +++ b/contrib/extraction/modutil.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.mli 10620 2008-03-05 10:54:41Z letouzey $ i*) +(*i $Id: modutil.mli 11602 2008-11-18 00:08:33Z letouzey $ i*) open Names open Declarations @@ -15,12 +15,6 @@ open Libnames open Miniml open Mod_subst -(*s Functions upon modules missing in [Modops]. *) - -(* Change a msid in a module type, to follow a module expr. *) - -val replicate_msid : struct_expr_body -> struct_expr_body -> struct_expr_body - (*s Functions upon ML modules. *) val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool @@ -30,15 +24,11 @@ type do_ref = global_reference -> unit val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit -val struct_iter_references : do_ref -> do_ref -> do_ref -> ml_structure -> unit - -type 'a kinds = { mutable typ : 'a ; mutable trm : 'a; mutable cons : 'a } - -val struct_get_references_set : ml_structure -> Refset.t kinds -val struct_get_references_list : ml_structure -> global_reference list kinds val signature_of_structure : ml_structure -> ml_signature +val msid_of_mt : ml_module_type -> module_path + val get_decl_in_structure : global_reference -> ml_structure -> ml_decl (* Some transformations of ML terms. [optimize_struct] simplify diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml index 64c80a2a..0166d854 100644 --- a/contrib/extraction/ocaml.ml +++ b/contrib/extraction/ocaml.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ocaml.ml 10592 2008-02-27 14:16:07Z letouzey $ i*) +(*i $Id: ocaml.ml 11559 2008-11-07 22:03:34Z letouzey $ i*) (*s Production of Ocaml syntax. *) @@ -25,22 +25,6 @@ open Declarations (*s Some utility functions. *) -let rec msid_of_mt = function - | MTident mp -> begin - match Modops.eval_struct (Global.env()) (SEBident mp) with - | SEBstruct(msid,_) -> MPself msid - | _ -> anomaly "Extraction:the With can't be applied to a funsig" - end - | MTwith(mt,_)-> msid_of_mt mt - | _ -> anomaly "Extraction:the With operator isn't applied to a name" - -let make_mp_with mp idl = - let idl_rev = List.rev idl in - let idl' = List.rev (List.tl idl_rev) in - (List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) - mp idl') - - let pp_tvar id = let s = string_of_id id in if String.length s < 2 || s.[1]<>'\'' @@ -107,12 +91,18 @@ let sig_preamble _ used_modules usf = (*s The pretty-printer for Ocaml syntax*) -let pp_global k r = - if is_inline_custom r then str (find_custom r) +(* Beware of the side-effects of [pp_global] and [pp_modname]. + They are used to update table of content for modules. Many [let] + below should not be altered since they force evaluation order. +*) + +let pp_global k r = + if is_inline_custom r then str (find_custom r) else str (Common.pp_global k r) let pp_modname mp = str (Common.pp_module mp) + let is_infix r = is_inline_custom r && (let s = find_custom r in @@ -462,7 +452,7 @@ let pp_ind co kn ind = if i >= Array.length ind.ind_packets then mt () else let ip = (kn,i) in - let ip_equiv = ind.ind_equiv, 0 in + let ip_equiv = ind.ind_equiv, i in let p = ind.ind_packets.(i) in if is_custom (IndRef ip) then pp (i+1) else begin @@ -607,52 +597,49 @@ and pp_module_type ol = function | MTident kn -> pp_modname kn | MTfunsig (mbid, mt, mt') -> - let name = pp_modname (MPbound mbid) in let typ = pp_module_type None mt in + let name = pp_modname (MPbound mbid) in let def = pp_module_type None mt' in str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MTsig (msid, sign) -> - let tvm = top_visible_mp () in - Option.iter (fun l -> add_subst msid (MPdot (tvm, l))) ol; - let mp = MPself msid in - push_visible mp; + let tvm = top_visible_mp () in + let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in + (* References in [sign] are in short form (relative to [msid]). + In push_visible, [msid-->mp] is added to the current subst. *) + push_visible mp (Some msid); let l = map_succeed pp_specif sign in pop_visible (); str "sig " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ fnl () ++ str "end" | MTwith(mt,ML_With_type(idl,vl,typ)) -> - let l = rename_tvars keywords vl in - let ids = pp_parameters l in + let ids = pp_parameters (rename_tvars keywords vl) in let mp_mt = msid_of_mt mt in - let mp = make_mp_with mp_mt idl in - let gr = ConstRef ( - (make_con mp empty_dirpath - (label_of_id ( - List.hd (List.rev idl))))) in - push_visible mp_mt; - let s = pp_module_type None mt ++ - str " with type " ++ - pp_global Type gr ++ - ids in - pop_visible(); - s ++ str "=" ++ spc () ++ - pp_type false vl typ + let l,idl' = list_sep_last idl in + let mp_w = + List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl' + in + let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l)) + in + push_visible mp_mt None; + let s = + pp_module_type None mt ++ str " with type " ++ + pp_global Type r ++ ids + in + pop_visible(); + s ++ str "=" ++ spc () ++ pp_type false vl typ | MTwith(mt,ML_With_module(idl,mp)) -> - let mp_mt=msid_of_mt mt in - push_visible mp_mt; - let s = - pp_module_type None mt ++ - str " with module " ++ - (pp_modname - (List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) - mp_mt idl)) - ++ str " = " - in - pop_visible (); - s ++ (pp_modname mp) - - + let mp_mt = msid_of_mt mt in + let mp_w = + List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) mp_mt idl + in + push_visible mp_mt None; + let s = + pp_module_type None mt ++ str " with module " ++ pp_modname mp_w + in + pop_visible (); + s ++ str " = " ++ pp_modname mp + let is_short = function MEident _ | MEapply _ -> true | _ -> false let rec pp_structure_elem = function @@ -664,10 +651,16 @@ let rec pp_structure_elem = function pp_alias_decl ren d with Not_found -> pp_decl d) | (l,SEmodule m) -> + let typ = + (* virtual printing of the type, in order to have a correct mli later*) + if Common.get_phase () = Pre then + str ": " ++ pp_module_type (Some l) m.ml_mod_type + else mt () + in let def = pp_module_expr (Some l) m.ml_mod_expr in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 - (str "module " ++ name ++ str " = " ++ + (str "module " ++ name ++ typ ++ str " = " ++ (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in @@ -694,33 +687,34 @@ and pp_module_expr ol = function | MEstruct (msid, sel) -> let tvm = top_visible_mp () in let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in - push_visible mp; + (* No need to update the subst with [Some msid] below : names are + already in long form (see [subst_structure] in [Extract_env]). *) + push_visible mp None; let l = map_succeed pp_structure_elem sel in pop_visible (); str "struct " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ fnl () ++ str "end" -let pp_struct s = - let pp mp s = - push_visible mp; - let p = pp_structure_elem s ++ fnl2 () in - pop_visible (); p +let do_struct f s = + let pp s = try f s ++ fnl2 () with Failure "empty phrase" -> mt () in - prlist_strict - (fun (mp,sel) -> prlist_strict identity (map_succeed (pp mp) sel)) s - -let pp_signature s = - let pp mp s = - push_visible mp; - let p = pp_specif s ++ fnl2 () in - pop_visible (); p - in - prlist_strict - (fun (mp,sign) -> prlist_strict identity (map_succeed (pp mp) sign)) s + let ppl (mp,sel) = + push_visible mp None; + let p = prlist_strict pp sel in + (* for monolithic extraction, we try to simulate the unavailability + of [MPfile] in names by artificially nesting these [MPfile] *) + (if modular () then pop_visible ()); p + in + let p = prlist_strict ppl s in + (if not (modular ()) then repeat (List.length s) pop_visible ()); + p + +let pp_struct s = do_struct pp_structure_elem s + +let pp_signature s = do_struct pp_specif s -let pp_decl d = - try pp_decl d with Failure "empty phrase" -> mt () +let pp_decl d = try pp_decl d with Failure "empty phrase" -> mt () let ocaml_descr = { keywords = keywords; diff --git a/contrib/extraction/scheme.ml b/contrib/extraction/scheme.ml index 600f64db..f4941a9c 100644 --- a/contrib/extraction/scheme.ml +++ b/contrib/extraction/scheme.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: scheme.ml 10233 2007-10-17 23:29:08Z letouzey $ i*) +(*i $Id: scheme.ml 11559 2008-11-07 22:03:34Z letouzey $ i*) (*s Production of Scheme syntax. *) @@ -183,7 +183,7 @@ let pp_structure_elem = function let pp_struct = let pp_sel (mp,sel) = - push_visible mp; + push_visible mp None; let p = prlist_strict pp_structure_elem sel in pop_visible (); p in diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml index 10f669e1..c675a744 100644 --- a/contrib/extraction/table.ml +++ b/contrib/extraction/table.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: table.ml 11262 2008-07-24 20:59:29Z letouzey $ i*) +(*i $Id: table.ml 11844 2009-01-22 16:45:06Z letouzey $ i*) open Names open Term @@ -52,7 +52,7 @@ let is_modfile = function | MPfile _ -> true | _ -> false -let string_of_modfile = function +let raw_string_of_modfile = function | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f))) | _ -> assert false @@ -76,24 +76,15 @@ let rec prefixes_mp mp = match mp with | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') | _ -> MPset.singleton mp -let rec get_nth_label_mp n mp = match mp with - | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp +let rec get_nth_label_mp n = function + | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp | _ -> failwith "get_nth_label: not enough MPdot" -let get_nth_label n r = - if n=0 then label_of_r r else get_nth_label_mp n (modpath_of_r r) - -let rec common_prefix prefixes_mp1 mp2 = - if MPset.mem mp2 prefixes_mp1 then mp2 - else match mp2 with - | MPdot (mp,_) -> common_prefix prefixes_mp1 mp - | _ -> raise Not_found - let common_prefix_from_list mp0 mpl = - let prefixes_mp0 = prefixes_mp mp0 in + let prefixes = prefixes_mp mp0 in let rec f = function | [] -> raise Not_found - | mp1 :: l -> try common_prefix prefixes_mp0 mp1 with Not_found -> f l + | mp :: l -> if MPset.mem mp prefixes then mp else f l in f mpl let rec parse_labels ll = function @@ -185,39 +176,39 @@ let modular_ref = ref false let set_modular b = modular_ref := b let modular () = !modular_ref -(*s Tables synchronization. *) - -let reset_tables () = - init_terms (); init_types (); init_inductives (); init_recursors (); - init_projs (); init_axioms () - (*s Printing. *) (* The following functions work even on objects not in [Global.env ()]. WARNING: for inductive objects, an extract_inductive must have been done before. *) -let id_of_global = function +let safe_id_of_global = function | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l | IndRef (kn,i) -> (snd (lookup_ind kn)).ind_packets.(i).ip_typename | ConstructRef ((kn,i),j) -> (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1) | _ -> assert false -let pr_global r = - try Printer.pr_global r - with _ -> pr_id (id_of_global r) +let safe_pr_global r = + try Printer.pr_global r + with _ -> pr_id (safe_id_of_global r) (* idem, but with qualification, and only for constants. *) -let pr_long_global r = - try Printer.pr_global r +let safe_pr_long_global r = + try Printer.pr_global r with _ -> match r with - | ConstRef kn -> - let mp,_,l = repr_con kn in + | ConstRef kn -> + let mp,_,l = repr_con kn in str ((string_of_mp mp)^"."^(string_of_label l)) | _ -> assert false +let pr_long_mp mp = + let lid = repr_dirpath (Nametab.dir_of_mp mp) in + str (String.concat "." (List.map string_of_id (List.rev lid))) + +let pr_long_global ref = pr_sp (Nametab.sp_of_global ref) + (*S Warning and Error messages. *) let err s = errorlabstrm "Extraction" s @@ -229,7 +220,7 @@ let warning_axioms () = let s = if List.length info_axioms = 1 then "axiom" else "axioms" in msg_warning (str ("The following "^s^" must be realized in the extracted code:") - ++ hov 1 (spc () ++ prlist_with_sep spc pr_global info_axioms) + ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms) ++ str "." ++ fnl ()) end; let log_axioms = Refset.elements !log_axioms in @@ -239,15 +230,27 @@ let warning_axioms () = in msg_warning (str ("The following logical "^s^" encountered:") ++ - hov 1 (spc () ++ prlist_with_sep spc pr_global log_axioms ++ str ".\n") ++ + hov 1 + (spc () ++ prlist_with_sep spc safe_pr_global log_axioms ++ str ".\n") + ++ str "Having invalid logical axiom in the environment when extracting" ++ spc () ++ str "may lead to incorrect or non-terminating ML terms." ++ fnl ()) end +let warning_both_mod_and_cst q mp r = + msg_warning + (str "The name " ++ pr_qualid q ++ str " is ambiguous, " ++ + str "do you mean module " ++ + pr_long_mp mp ++ + str " or object " ++ + pr_long_global r ++ str " ?" ++ fnl () ++ + str "First choice is assumed, for the second one please use " ++ + str "fully qualified name." ++ fnl ()) + let error_axiom_scheme r i = err (str "The type scheme axiom " ++ spc () ++ - pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ + safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ str " type variable(s).") let check_inside_module () = @@ -265,10 +268,10 @@ let check_inside_section () = str "Close it and try again.") let error_constant r = - err (pr_global r ++ str " is not a constant.") + err (safe_pr_global r ++ str " is not a constant.") let error_inductive r = - err (pr_global r ++ spc () ++ str "is not an inductive type.") + err (safe_pr_global r ++ spc () ++ str "is not an inductive type.") let error_nb_cons () = err (str "Not the right number of constructors.") @@ -284,21 +287,21 @@ let error_scheme () = err (str "No Scheme modular extraction available yet.") let error_not_visible r = - err (pr_global r ++ str " is not directly visible.\n" ++ + err (safe_pr_global r ++ str " is not directly visible.\n" ++ str "For example, it may be inside an applied functor." ++ str "Use Recursive Extraction to get the whole environment.") let error_MPfile_as_mod mp b = let s1 = if b then "asked" else "required" in let s2 = if b then "extract some objects of this module or\n" else "" in - err (str ("Extraction of file "^(string_of_modfile mp)^ + err (str ("Extraction of file "^(raw_string_of_modfile mp)^ ".v as a module is "^s1^".\n"^ "Monolithic Extraction cannot deal with this situation.\n"^ "Please "^s2^"use (Recursive) Extraction Library instead.\n")) -let error_record r = - err (str "Record " ++ pr_global r ++ str " has an anonymous field." ++ fnl () ++ - str "To help extraction, please use an explicit name.") +let error_record r = + err (str "Record " ++ safe_pr_global r ++ str " has an anonymous field." ++ + fnl () ++ str "To help extraction, please use an explicit name.") let check_loaded_modfile mp = match base_mp mp with | MPfile dp -> if not (Library.library_is_loaded dp) then @@ -481,11 +484,11 @@ let print_extraction_inline () = (str "Extraction Inline:" ++ fnl () ++ Refset.fold (fun r p -> - (p ++ str " " ++ pr_long_global r ++ fnl ())) i' (mt ()) ++ + (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) i' (mt ()) ++ str "Extraction NoInline:" ++ fnl () ++ Refset.fold (fun r p -> - (p ++ str " " ++ pr_long_global r ++ fnl ())) n (mt ())) + (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) n (mt ())) (* Reset part *) @@ -498,6 +501,73 @@ let (reset_inline,_) = let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) +(*s Extraction Blacklist of filenames not to use while extracting *) + +let blacklist_table = ref Idset.empty + +let modfile_ids = ref [] +let modfile_mps = ref MPmap.empty + +let reset_modfile () = + modfile_ids := Idset.elements !blacklist_table; + modfile_mps := MPmap.empty + +let string_of_modfile mp = + try MPmap.find mp !modfile_mps + with Not_found -> + let id = id_of_string (raw_string_of_modfile mp) in + let id' = next_ident_away id !modfile_ids in + let s' = string_of_id id' in + modfile_ids := id' :: !modfile_ids; + modfile_mps := MPmap.add mp s' !modfile_mps; + s' + +let add_blacklist_entries l = + blacklist_table := + List.fold_right (fun s -> Idset.add (id_of_string (String.capitalize s))) + l !blacklist_table + +(* Registration of operations for rollback. *) + +let (blacklist_extraction,_) = + declare_object + {(default_object "Extraction Blacklist") with + cache_function = (fun (_,l) -> add_blacklist_entries l); + load_function = (fun _ (_,l) -> add_blacklist_entries l); + export_function = (fun x -> Some x); + classify_function = (fun (_,o) -> Libobject.Keep o); + subst_function = (fun (_,_,x) -> x) + } + +let _ = declare_summary "Extraction Blacklist" + { freeze_function = (fun () -> !blacklist_table); + unfreeze_function = ((:=) blacklist_table); + init_function = (fun () -> blacklist_table := Idset.empty); + survive_module = true; + survive_section = true } + +(* Grammar entries. *) + +let extraction_blacklist l = + let l = List.rev_map string_of_id l in + Lib.add_anonymous_leaf (blacklist_extraction l) + +(* Printing part *) + +let print_extraction_blacklist () = + msgnl + (prlist_with_sep fnl pr_id (Idset.elements !blacklist_table)) + +(* Reset part *) + +let (reset_blacklist,_) = + declare_object + {(default_object "Reset Extraction Blacklist") with + cache_function = (fun (_,_)-> blacklist_table := Idset.empty); + load_function = (fun _ (_,_)-> blacklist_table := Idset.empty); + export_function = (fun x -> Some x)} + +let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ()) (*s Extract Constant/Inductive. *) @@ -575,3 +645,9 @@ let extract_inductive r (s,l) = | _ -> error_inductive g + +(*s Tables synchronization. *) + +let reset_tables () = + init_terms (); init_types (); init_inductives (); init_recursors (); + init_projs (); init_axioms (); reset_modfile () diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli index 4dbccd08..5ef7139e 100644 --- a/contrib/extraction/table.mli +++ b/contrib/extraction/table.mli @@ -6,20 +6,20 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: table.mli 11262 2008-07-24 20:59:29Z letouzey $ i*) +(*i $Id: table.mli 11844 2009-01-22 16:45:06Z letouzey $ i*) open Names open Libnames open Miniml open Declarations -val id_of_global : global_reference -> identifier -val pr_long_global : global_reference -> Pp.std_ppcmds - +val safe_id_of_global : global_reference -> identifier (*s Warning and Error messages. *) val warning_axioms : unit -> unit +val warning_both_mod_and_cst : + qualid -> module_path -> global_reference -> unit val error_axiom_scheme : global_reference -> int -> 'a val error_constant : global_reference -> 'a val error_inductive : global_reference -> 'a @@ -55,7 +55,6 @@ val modfile_of_mp : module_path -> module_path val common_prefix_from_list : module_path -> module_path list -> module_path val add_labels_mp : module_path -> label list -> module_path val get_nth_label_mp : int -> module_path -> label -val get_nth_label : int -> global_reference -> label val labels_of_ref : global_reference -> module_path * label list (*s Some table-related operations *) @@ -142,6 +141,11 @@ val extract_constant_inline : bool -> reference -> string list -> string -> unit val extract_inductive : reference -> string * string list -> unit +(*s Table of blacklisted filenames *) + +val extraction_blacklist : identifier list -> unit +val reset_extraction_blacklist : unit -> unit +val print_extraction_blacklist : unit -> unit diff --git a/contrib/firstorder/rules.ml b/contrib/firstorder/rules.ml index b8b56548..cc7b19e0 100644 --- a/contrib/firstorder/rules.ml +++ b/contrib/firstorder/rules.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: rules.ml 11094 2008-06-10 19:35:23Z herbelin $ *) +(* $Id: rules.ml 11512 2008-10-27 12:28:36Z herbelin $ *) open Util open Names @@ -213,4 +213,4 @@ let normalize_evaluables= None->unfold_in_concl (Lazy.force defined_connectives) | Some ((_,id),_)-> unfold_in_hyp (Lazy.force defined_connectives) - ((Rawterm.all_occurrences_expr,id),Tacexpr.InHypTypeOnly)) + ((Rawterm.all_occurrences_expr,id),InHypTypeOnly)) diff --git a/contrib/fourier/Fourier.v b/contrib/fourier/Fourier.v index 1a1a5055..024aa1c3 100644 --- a/contrib/fourier/Fourier.v +++ b/contrib/fourier/Fourier.v @@ -6,16 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Fourier.v 9178 2006-09-26 11:18:22Z barras $ *) +(* $Id: Fourier.v 11672 2008-12-12 14:45:09Z herbelin $ *) (* "Fourier's method to solve linear inequations/equations systems.".*) -Declare ML Module "quote". -Declare ML Module "ring". -Declare ML Module "fourier". -Declare ML Module "fourierR". -Declare ML Module "field". - Require Export Fourier_util. Require Export LegacyField. Require Export DiscrR. diff --git a/contrib/fourier/fourier.ml b/contrib/fourier/fourier.ml index ed804e94..195d8605 100644 --- a/contrib/fourier/fourier.ml +++ b/contrib/fourier/fourier.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: fourier.ml 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: fourier.ml 11671 2008-12-12 12:43:03Z herbelin $ *) (* Méthode d'élimination de Fourier *) (* Référence: @@ -202,4 +202,4 @@ let test2=[ deduce test2;; unsolvable test2;; -*) \ No newline at end of file +*) diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml index bd335d30..9f3e412a 100644 --- a/contrib/funind/functional_principles_proofs.ml +++ b/contrib/funind/functional_principles_proofs.ml @@ -136,7 +136,7 @@ let change_hyp_with_using msg hyp_id t tac : tactic = fun g -> let prov_id = pf_get_new_id hyp_id g in tclTHENS - ((* observe_tac msg *) (forward (Some (tclCOMPLETE tac)) (dummy_loc,Genarg.IntroIdentifier prov_id) t)) + ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac))) [tclTHENLIST [ (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); @@ -388,7 +388,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = in (* observe_tac "rec hyp " *) (tclTHENS - (assert_as true (dummy_loc, Genarg.IntroIdentifier rec_pte_id) t_x) + (assert_tac (Name rec_pte_id) t_x) [ (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); (* observe_tac "prove rec hyp" *) @@ -571,7 +571,7 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id fun g -> let prov_hid = pf_get_new_id hid g in tclTHENLIST[ - forward None (dummy_loc,Genarg.IntroIdentifier prov_hid) (mkApp(mkVar hid,args)); + pose_proof (Name prov_hid) (mkApp(mkVar hid,args)); thin [hid]; h_rename [prov_hid,hid] ] g @@ -1347,7 +1347,7 @@ let build_clause eqs = { Tacexpr.onhyps = Some (List.map - (fun id -> (Rawterm.all_occurrences_expr,id),Tacexpr.InHyp) + (fun id -> (Rawterm.all_occurrences_expr,id),InHyp) eqs ); Tacexpr.concl_occs = Rawterm.no_occurrences_expr @@ -1399,7 +1399,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = false (true,5) [Lazy.force refl_equal] - [Auto.Hint_db.empty false] + [Auto.Hint_db.empty empty_transparent_state false] ) ) ) @@ -1495,10 +1495,9 @@ let prove_principle_for_gen ((* observe_tac "prove_rec_arg_acc" *) (tclCOMPLETE (tclTHEN - (forward - (Some ((fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g))) - (dummy_loc,Genarg.IntroIdentifier wf_thm_id) - (mkApp (delayed_force well_founded,[|input_type;relation|]))) + (assert_by (Name wf_thm_id) + (mkApp (delayed_force well_founded,[|input_type;relation|])) + (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)) ( (* observe_tac *) (* "apply wf_thm" *) @@ -1559,10 +1558,10 @@ let prove_principle_for_gen (List.rev_map (fun (na,_,_) -> Nameops.out_name na) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); - (* observe_tac "" *) (forward - (Some (prove_rec_arg_acc)) - (dummy_loc,Genarg.IntroIdentifier acc_rec_arg_id) + (* observe_tac "" *) (assert_by + (Name acc_rec_arg_id) (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) + (prove_rec_arg_acc) ); (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml index 16076479..b03bdf31 100644 --- a/contrib/funind/functional_principles_types.ml +++ b/contrib/funind/functional_principles_types.ml @@ -552,13 +552,31 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent | _ -> anomaly "" in let (_,(const,_,_)) = - build_functional_principle false - first_type - (Array.of_list sorts) - this_block_funs - 0 - (prove_princ_for_struct false 0 (Array.of_list funs)) - (fun _ _ _ -> ()) + try + build_functional_principle false + first_type + (Array.of_list sorts) + this_block_funs + 0 + (prove_princ_for_struct false 0 (Array.of_list funs)) + (fun _ _ _ -> ()) + with e -> + begin + begin + try + let id = Pfedit.get_current_proof_name () in + let s = string_of_id id in + let n = String.length "___________princ_________" in + if String.length s >= n + then if String.sub s 0 n = "___________princ_________" + then Pfedit.delete_current_proof () + else () + else () + with _ -> () + end; + raise (Defining_principle e) + end + in incr i; let opacity = diff --git a/contrib/funind/g_indfun.ml4 b/contrib/funind/g_indfun.ml4 index d435f513..a79b46d9 100644 --- a/contrib/funind/g_indfun.ml4 +++ b/contrib/funind/g_indfun.ml4 @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (*i camlp4deps: "parsing/grammar.cma" i*) +open Util open Term open Names open Pp @@ -128,25 +129,52 @@ ARGUMENT EXTEND auto_using' | [ ] -> [ [] ] END +let pr_rec_annotation2_aux s r id l = + str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++ + Util.pr_opt Nameops.pr_id id ++ + Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}" + +let pr_rec_annotation2 = function + | Struct id -> str "{struct" ++ Nameops.pr_id id ++ str "}" + | Wf(r,id,l) -> pr_rec_annotation2_aux "wf" r id l + | Mes(r,id,l) -> pr_rec_annotation2_aux "measure" r id l + VERNAC ARGUMENT EXTEND rec_annotation2 +PRINTED BY pr_rec_annotation2 [ "{" "struct" ident(id) "}"] -> [ Struct id ] | [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ] | [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] END +let pr_binder2 (idl,c) = + str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++ + str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")" VERNAC ARGUMENT EXTEND binder2 - [ "(" ne_ident_list(idl) ":" lconstr(c) ")"] -> - [ - LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) ] +PRINTED BY pr_binder2 + [ "(" ne_ident_list(idl) ":" lconstr(c) ")"] -> [ (idl,c) ] END +let make_binder2 (idl,c) = + LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) + +let pr_rec_definition2 (id,bl,annot,type_,def) = + Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++ + Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++ + Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++ + Ppconstr.pr_lconstr_expr def VERNAC ARGUMENT EXTEND rec_definition2 - [ ident(id) binder2_list( bl) - rec_annotation2_opt(annot) ":" lconstr( type_) +PRINTED BY pr_rec_definition2 + [ ident(id) binder2_list(bl) + rec_annotation2_opt(annot) ":" lconstr(type_) ":=" lconstr(def)] -> - [let names = List.map snd (Topconstr.names_of_local_assums bl) in + [ (id,bl,annot,type_,def) ] +END + +let make_rec_definitions2 (id,bl,annot,type_,def) = + let bl = List.map make_binder2 bl in + let names = List.map snd (Topconstr.names_of_local_assums bl) in let check_one_name () = if List.length names > 1 then Util.user_err_loc @@ -173,52 +201,73 @@ VERNAC ARGUMENT EXTEND rec_definition2 | Some an -> check_exists_args an in - ((Util.dummy_loc,id), ni, bl, type_, def) ] - END - - -VERNAC ARGUMENT EXTEND rec_definitions2 -| [ rec_definition2(rd) ] -> [ [rd] ] -| [ rec_definition2(hd) "with" rec_definitions2(tl) ] -> [ hd::tl ] -END + ((Util.dummy_loc,id), ni, bl, type_, def) VERNAC COMMAND EXTEND Function - ["Function" rec_definitions2(recsl)] -> + ["Function" ne_rec_definition2_list_sep(recsl,"with")] -> [ - do_generate_principle false recsl; + do_generate_principle false (List.map make_rec_definitions2 recsl); ] END +let pr_fun_scheme_arg (princ_name,fun_name,s) = + Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ + Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ + Ppconstr.pr_rawsort s VERNAC ARGUMENT EXTEND fun_scheme_arg +PRINTED BY pr_fun_scheme_arg | [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] END -VERNAC ARGUMENT EXTEND fun_scheme_args -| [ fun_scheme_arg(fa) ] -> [ [fa] ] -| [ fun_scheme_arg(fa) "with" fun_scheme_args(fas) ] -> [fa::fas] -END + +let warning_error names e = + match e with + | Building_graph e -> + Pp.msg_warning + (str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ + if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) + | Defining_principle e -> + Pp.msg_warning + (str "Cannot define principle(s) for "++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ + if do_observe () then Cerrors.explain_exn e else mt ()) + | _ -> anomaly "" + VERNAC COMMAND EXTEND NewFunctionalScheme - ["Functional" "Scheme" fun_scheme_args(fas) ] -> + ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] -> [ - try - Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - match fas with - | (_,fun_name,_)::_ -> - begin - begin - make_graph (Nametab.global fun_name) - end - ; - try Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - Util.error ("Cannot generate induction principle(s)") - end - | _ -> assert false (* we can only have non empty list *) + begin + try + Functional_principles_types.build_scheme fas + with Functional_principles_types.No_graph_found -> + begin + match fas with + | (_,fun_name,_)::_ -> + begin + begin + make_graph (Nametab.global fun_name) + end + ; + try Functional_principles_types.build_scheme fas + with Functional_principles_types.No_graph_found -> + Util.error ("Cannot generate induction principle(s)") + | e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e + + end + | _ -> assert false (* we can only have non empty list *) + end + | e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e + + end ] END (***** debug only ***) @@ -307,9 +356,9 @@ let mkEq typ c1 c2 = let poseq_unsafe idunsafe cstr gl = let typ = Tacmach.pf_type_of gl cstr in tclTHEN - (Tactics.letin_tac None (Name idunsafe) cstr allClauses) + (Tactics.letin_tac None (Name idunsafe) cstr None allClauses) (tclTHENFIRST - (Tactics.assert_as true (Util.dummy_loc,IntroAnonymous) (mkEq typ (mkVar idunsafe) cstr)) + (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) Tactics.reflexivity) gl diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml index 79ef0097..b6b2cbd1 100644 --- a/contrib/funind/indfun.ml +++ b/contrib/funind/indfun.ml @@ -168,7 +168,7 @@ let build_newrecursive if Impargs.is_implicit_args() then Impargs.compute_implicits env0 arity else [] in - let impls' =(recname,([],impl,Notation.compute_arguments_scope arity))::impls in + let impls' =(recname,(Constrintern.Recursive,[],impl,Notation.compute_arguments_scope arity))::impls in (Environ.push_named (recname,None,arity) env, impls')) (env0,[]) lnameargsardef in let recdef = @@ -612,7 +612,9 @@ let rec add_args id new_args b = CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2)) | CCast(loc,b1,CastCoerce) -> CCast(loc,add_args id new_args b1,CastCoerce) + | CRecord _ -> anomaly "add_args : CRecord" | CNotation _ -> anomaly "add_args : CNotation" + | CGeneralization _ -> anomaly "add_args : CGeneralization" | CPrim _ -> b | CDelimiters _ -> anomaly "add_args : CDelimiters" | CDynamic _ -> anomaly "add_args : CDynamic" diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml index 4010b49d..a3c169b7 100644 --- a/contrib/funind/indfun_common.ml +++ b/contrib/funind/indfun_common.ml @@ -238,20 +238,19 @@ let with_full_print f a = and old_strict_implicit_args = Impargs.is_strict_implicit_args () and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in - let old_dump = !Flags.dump in Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; Impargs.make_contextual_implicit_args false; Impargs.make_contextual_implicit_args false; - Flags.dump := false; + Dumpglob.pause (); try let res = f a in Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; - Flags.dump := old_dump; + Dumpglob.continue (); res with | e -> @@ -259,7 +258,7 @@ let with_full_print f a = Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; - Flags.dump := old_dump; + Dumpglob.continue (); raise e diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml index f62d70ab..5c8f0871 100644 --- a/contrib/funind/invfun.ml +++ b/contrib/funind/invfun.ml @@ -445,10 +445,10 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem in tclTHENSEQ [ observe_tac "intro args_names" (tclMAP h_intro args_names); - observe_tac "principle" (forward - (Some (h_exact f_principle)) - (dummy_loc,Genarg.IntroIdentifier principle_id) - princ_type); + observe_tac "principle" (assert_by + (Name principle_id) + princ_type + (h_exact f_principle)); tclTHEN_i (observe_tac "functional_induction" ( fun g -> diff --git a/contrib/funind/merge.ml b/contrib/funind/merge.ml index ec456aae..9bbd165d 100644 --- a/contrib/funind/merge.ml +++ b/contrib/funind/merge.ml @@ -855,7 +855,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = [rawlist], named ident. FIXME: params et cstr_expr (arity) *) let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift - (rawlist:(identifier * rawconstr) list):inductive_expr = + (rawlist:(identifier * rawconstr) list) = let lident = dummy_loc, shift.ident in let bindlist , cstr_expr = (* params , arities *) merge_rec_params_and_arity prms1 prms2 shift mkSet in @@ -863,7 +863,7 @@ let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift List.map (* zeta_normalize t ? *) (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t)) rawlist in - lident , bindlist , cstr_expr , lcstor_expr + lident , bindlist , Some cstr_expr , lcstor_expr diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml index 08a97fd2..09b7fbdf 100644 --- a/contrib/funind/rawterm_to_relation.ml +++ b/contrib/funind/rawterm_to_relation.ml @@ -1192,7 +1192,7 @@ let do_build_inductive let rel_ind i ext_rel_constructors = ((dummy_loc,relnames.(i)), rel_params, - rel_arities.(i), + Some rel_arities.(i), ext_rel_constructors),None in let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in @@ -1224,9 +1224,14 @@ let do_build_inductive | UserError(s,msg) as e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + rel_inds + in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () ++ + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,repacked_rel_inds)) + ++ fnl () ++ msg in observe (msg); @@ -1234,9 +1239,14 @@ let do_build_inductive | e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + rel_inds + in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () ++ + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,repacked_rel_inds)) + ++ fnl () ++ Cerrors.explain_exn e in observe msg; diff --git a/contrib/funind/recdef.ml b/contrib/funind/recdef.ml index 5bd7a6b2..6dc0d5bf 100644 --- a/contrib/funind/recdef.ml +++ b/contrib/funind/recdef.ml @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: recdef.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: recdef.ml 11671 2008-12-12 12:43:03Z herbelin $ *) open Term open Termops @@ -740,7 +740,6 @@ let termination_proof_header is_mes input_type ids args_id relation (observe_tac "first assert" (assert_tac - true (* the assert thm is in first subgoal *) (Name wf_rec_arg) (mkApp (delayed_force acc_rel, [|input_type;relation;mkVar rec_arg_id|]) @@ -753,7 +752,6 @@ let termination_proof_header is_mes input_type ids args_id relation (observe_tac "second assert" (assert_tac - true (Name wf_thm) (mkApp (delayed_force well_founded,[|input_type;relation|])) ) @@ -1157,12 +1155,12 @@ let rec introduce_all_values_eq cont_tac functional termine [] -> let heq2 = next_global_ident_away true heq_id ids in tclTHENLIST - [forward None (dummy_loc,IntroIdentifier heq2) + [pose_proof (Name heq2) (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|])); simpl_iter (onHyp heq2); unfold_in_hyp [((true,[1]), evaluable_of_global_reference (global_of_constr functional))] - ((all_occurrences_expr, heq2), Tacexpr.InHyp); + ((all_occurrences_expr, heq2), InHyp); tclTHENS (fun gls -> let t_eq = compute_renamed_type gls (mkVar heq2) in diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli index 32338523..2eb2c381 100644 --- a/contrib/interface/ascent.mli +++ b/contrib/interface/ascent.mli @@ -76,7 +76,7 @@ and ct_COMMAND = | CT_go of ct_INT_OR_LOCN | CT_guarded | CT_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST - | CT_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST + | CT_hint_extern of ct_INT * ct_FORMULA_OPT * ct_TACTIC_COM * ct_ID_LIST | CT_hintrewrite of ct_ORIENTATION * ct_FORMULA_NE_LIST * ct_ID * ct_TACTIC_COM | CT_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST | CT_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml index 767a7dd6..483453cb 100644 --- a/contrib/interface/blast.ml +++ b/contrib/interface/blast.ml @@ -148,6 +148,8 @@ let pp_string x = (* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) (***************************************************************************) +let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) + let unify_e_resolve (c,clenv) gls = let clenv' = connect_clenv gls clenv in let _ = clenv_unique_resolver false clenv' gls in @@ -190,12 +192,11 @@ and e_my_find_search db_list local_db hdc concl = tclTHEN (unify_e_resolve (term,cl)) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> Auto.conclPattern concl - (Option.get p) tacast + | Extern tacast -> Auto.conclPattern concl p tacast in - (free_try tac,fmt_autotactic t)) + (free_try tac,pr_autotactic t)) (*i - fun gls -> pPNL (fmt_autotactic t); Format.print_flush (); + fun gls -> pPNL (pr_autotactic t); Format.print_flush (); try tac gls with e when Logic.catchable_exception(e) -> (Format.print_string "Fail\n"; @@ -207,14 +208,14 @@ and e_my_find_search db_list local_db hdc concl = and e_trivial_resolve db_list local_db gl = try - Auto.priority + priority (e_my_find_search db_list local_db - (List.hd (head_constr_bound gl [])) gl) + (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = try List.map snd (e_my_find_search db_list local_db - (List.hd (head_constr_bound gl [])) gl) + (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id)) @@ -406,13 +407,12 @@ and my_find_search db_list local_db hdc concl = (unify_resolve st (term,cl)) (trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> - conclPattern concl (Option.get p) tacast)) + | Extern tacast -> conclPattern concl p tacast)) tacl and trivial_resolve db_list local_db cl = try - let hdconstr = List.hd (head_constr_bound cl []) in + let hdconstr = fst (head_constr_bound cl) in priority (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) with Bound | Not_found -> @@ -424,7 +424,7 @@ and trivial_resolve db_list local_db cl = let possible_resolve db_list local_db cl = try - let hdconstr = List.hd (head_constr_bound cl []) in + let hdconstr = fst (head_constr_bound cl) in List.map snd (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) with Bound | Not_found -> @@ -432,8 +432,8 @@ let possible_resolve db_list local_db cl = let decomp_unary_term c gls = let typc = pf_type_of gls c in - let hd = List.hd (head_constr typc) in - if Hipattern.is_conjunction hd then + let t = head_constr typc in + if Hipattern.is_conjunction (applist t) then simplest_case c gls else errorlabstrm "Auto.decomp_unary_term" (str "not a unary type") @@ -473,7 +473,7 @@ let rec search_gen decomp n db_list local_db extra_sign goal = let hintl = try [make_apply_entry (pf_env g') (project g') - (true,false) + (true,true,false) None (mkVar hid,htyp)] with Failure _ -> [] diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4 index a4dc0eac..51dce4f7 100644 --- a/contrib/interface/centaur.ml4 +++ b/contrib/interface/centaur.ml4 @@ -545,8 +545,12 @@ let solve_hook n = let abort_hook s = output_results_nl (ctf_AbortedMessage !global_request_id s) let interp_search_about_item = function - | SearchRef qid -> GlobSearchRef (Nametab.global qid) - | SearchString s -> GlobSearchString s + | SearchSubPattern pat -> + let _,pat = Constrintern.intern_constr_pattern Evd.empty (Global.env()) pat in + GlobSearchSubPattern pat + | SearchString (s,_) -> + warning "Notation case not taken into account"; + GlobSearchString s let pcoq_search s l = (* LEM: I don't understand why this is done in this way (redoing the @@ -559,12 +563,12 @@ let pcoq_search s l = begin match s with | SearchAbout sl -> raw_search_about (filter_by_module_from_list l) add_search - (List.map interp_search_about_item sl) + (List.map (on_snd interp_search_about_item) sl) | SearchPattern c -> - let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in raw_pattern_search (filter_by_module_from_list l) add_search pat | SearchRewrite c -> - let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in raw_search_rewrite (filter_by_module_from_list l) add_search pat; | SearchHead locqid -> filtered_search @@ -579,7 +583,7 @@ let rec hyp_pattern_filter pat name a c = | Prod(_, hyp, c2) -> (try (* let _ = msgnl ((str "WHOLE ") ++ (Printer.pr_lconstr c)) in - let _ = msgnl ((str "PAT ") ++ (Printer.pr_pattern pat)) in *) + let _ = msgnl ((str "PAT ") ++ (Printer.pr_constr_pattern pat)) in *) if Matching.is_matching pat hyp then (msgnl (str "ok"); true) else @@ -589,7 +593,7 @@ let rec hyp_pattern_filter pat name a c = | _ -> false;; let hyp_search_pattern c l = - let _, pat = interp_constrpattern Evd.empty (Global.env()) c in + let _, pat = intern_constr_pattern Evd.empty (Global.env()) c in ctv_SEARCH_LIST := []; gen_filtered_search (fun s a c -> (filter_by_module_from_list l s a c && @@ -638,8 +642,8 @@ let pcoq_term_pr = { * Except with right bool/env which I'll get :) *) pr_lconstr_expr = (fun c -> fFORMULA (xlate_formula c) ++ str "(pcoq_lconstr_expr of " ++ (default_term_pr.pr_lconstr_expr c) ++ str ")"); - pr_pattern_expr = (fun c -> str "pcoq_pattern_expr\n" ++ (default_term_pr.pr_pattern_expr c)); - pr_lpattern_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_lpattern_expr c)) + pr_constr_pattern_expr = (fun c -> str "pcoq_pattern_expr\n" ++ (default_term_pr.pr_constr_pattern_expr c)); + pr_lconstr_pattern_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_lconstr_pattern_expr c)) } let start_pcoq_trees () = diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml index 8096bc31..c2ab2dc8 100644 --- a/contrib/interface/dad.ml +++ b/contrib/interface/dad.ml @@ -99,7 +99,7 @@ let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 = with Failure s -> failwith "internal" in let _, constr_pat = - interp_constrpattern Evd.empty (Global.env()) + intern_constr_pattern Evd.empty (Global.env()) ((*ct_to_ast*) pat) in let subst = matches constr_pat term_to_match in if (is_prefix p_f (p_r@p1)) & (is_prefix p_l (p_r@p2)) then diff --git a/contrib/interface/depends.ml b/contrib/interface/depends.ml index 203bc9e3..e59de34a 100644 --- a/contrib/interface/depends.ml +++ b/contrib/interface/depends.ml @@ -67,6 +67,7 @@ let explore_tree pfs = | Move (bool, identifier, identifier') -> "Move" | Rename (identifier, identifier') -> "Rename" | Change_evars -> "Change_evars" + | Order _ -> "Order" in let pt = proof_of_pftreestate pfs in (* We expect 0 *) @@ -280,8 +281,8 @@ let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of | TacExact c | TacExactNoCheck c | TacVmCastNoCheck c -> depends_of_'constr c acc - | TacApply (_, _, [cb]) -> depends_of_'constr_with_bindings cb acc - | TacApply (_, _, _) -> failwith "TODO" + | TacApply (_, _, [cb], None) -> depends_of_'constr_with_bindings cb acc + | TacApply (_, _, _, _) -> failwith "TODO" | TacElim (_, cwb, cwbo) -> depends_of_'constr_with_bindings cwb (Option.fold_right depends_of_'constr_with_bindings cwbo acc) @@ -420,6 +421,7 @@ and depends_of_prim_rule pr acc = match pr with | Move _ -> acc | Rename _ -> acc | Change_evars -> acc + | Order _ -> acc let rec depends_of_pftree pt acc = match pt.ref with diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml index 6b17e739..0dc8f024 100644 --- a/contrib/interface/name_to_ast.ml +++ b/contrib/interface/name_to_ast.ml @@ -107,10 +107,10 @@ let convert_one_inductive sp tyi = let env = Global.env () in let envpar = push_rel_context params env in let sp = sp_of_global (IndRef (sp, tyi)) in - (((dummy_loc,basename sp), + (((false,(dummy_loc,basename sp)), convert_env(List.rev params), - (extern_constr true envpar arity), - convert_constructors envpar cstrnames cstrtypes), None);; + Some (extern_constr true envpar arity), Vernacexpr.Inductive_kw , + Constructors (convert_constructors envpar cstrnames cstrtypes)), None);; (* This function converts a Mutual inductive definition to a Coqast.t. It is obtained directly from print_mutual in pretty.ml. However, all @@ -121,7 +121,7 @@ let mutual_to_ast_list sp mib = let _, l = Array.fold_right (fun mi (n,l) -> (n+1, (convert_one_inductive sp n)::l)) mipv (0, []) in - VernacInductive (mib.mind_finite, l) + VernacInductive ((if mib.mind_finite then Decl_kinds.Finite else Decl_kinds.CoFinite), l) :: (implicit_args_to_ast_list sp mipv);; let constr_to_ast v = diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml index bf8614b4..1bbab5fe 100644 --- a/contrib/interface/parse.ml +++ b/contrib/interface/parse.ml @@ -330,7 +330,7 @@ let add_path_action reqid string_arg = let print_version_action () = msgnl (mt ()); - msgnl (str "$Id: parse.ml 9476 2007-01-10 15:44:44Z lmamane $");; + msgnl (str "$Id: parse.ml 11749 2009-01-05 14:01:04Z notin $");; let load_syntax_action reqid module_name = msg (str "loading " ++ str module_name ++ str "... "); @@ -370,7 +370,7 @@ Libobject.relax true; (let coqdir = try Sys.getenv "COQDIR" with Not_found -> - let coqdir = Coq_config.coqlib in + let coqdir = Envars.coqlib () in if Sys.file_exists coqdir then coqdir else diff --git a/contrib/interface/paths.ml b/contrib/interface/paths.ml index b1244d15..a157ca92 100644 --- a/contrib/interface/paths.ml +++ b/contrib/interface/paths.ml @@ -23,4 +23,4 @@ let rec lex_smaller p1 p2 = match p1,p2 with [], _ -> true | a::tl1, b::tl2 when a < b -> true | a::tl1, b::tl2 when a = b -> lex_smaller tl1 tl2 -| _ -> false;; \ No newline at end of file +| _ -> false;; diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml index 65eadf13..01747aa5 100644 --- a/contrib/interface/pbp.ml +++ b/contrib/interface/pbp.ml @@ -171,7 +171,7 @@ let make_pbp_atomic_tactic = function | PbpRight -> TacAtom (zz, TacRight (false,NoBindings)) | PbpIntros l -> TacAtom (zz, TacIntroPattern l) | PbpLApply h -> TacAtom (zz, TacLApply (make_var h)) - | PbpApply h -> TacAtom (zz, TacApply (true,false,[make_var h,NoBindings])) + | PbpApply h -> TacAtom (zz, TacApply (true,false,[make_var h,NoBindings],None)) | PbpElim (hyp_name, names) -> let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in TacAtom diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml index 4b9c1332..cf861642 100644 --- a/contrib/interface/showproof.ml +++ b/contrib/interface/showproof.ml @@ -1202,7 +1202,8 @@ let rec natural_ntree ig ntree = | TacExtend (_,"InductionIntro",[a]) -> let id=(out_gen wit_ident a) in natural_induction ig lh g gs ge id ltree true - | TacApply (_,false,[c,_]) -> natural_apply ig lh g gs (snd c) ltree + | TacApply (_,false,[c,_],None) -> + natural_apply ig lh g gs (snd c) ltree | TacExact c -> natural_exact ig lh g gs (snd c) ltree | TacCut c -> natural_cut ig lh g gs (snd c) ltree | TacExtend (_,"CutIntro",[a]) -> diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml index 551ad3a3..94609009 100644 --- a/contrib/interface/vtp.ml +++ b/contrib/interface/vtp.ml @@ -246,7 +246,7 @@ and fCOMMAND = function fNODE "hint_destruct" 6 | CT_hint_extern(x1, x2, x3, x4) -> fINT x1 ++ - fFORMULA x2 ++ + fFORMULA_OPT x2 ++ fTACTIC_COM x3 ++ fID_LIST x4 ++ fNODE "hint_extern" 4 diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index da4908e5..e3cd56a0 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -7,6 +7,7 @@ open Names;; open Ascent;; open Genarg;; open Rawterm;; +open Termops;; open Tacexpr;; open Vernacexpr;; open Decl_kinds;; @@ -274,9 +275,11 @@ let rec xlate_match_pattern = CT_coerce_NUM_to_MATCH_PATTERN (CT_int_encapsulator(Bigint.to_string n)) | CPatPrim (_,String _) -> xlate_error "CPatPrim (String): TODO" - | CPatNotation(_, s, l) -> + | CPatNotation(_, s, (l,[])) -> CT_pattern_notation(CT_string s, CT_match_pattern_list(List.map xlate_match_pattern l)) + | CPatNotation(_, s, (l,_)) -> + xlate_error "CPatNotation (recursive notation): TODO" ;; @@ -373,6 +376,7 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function (xlate_formula f, List.map xlate_formula_expl l')) | CApp(_, (_,f), l) -> CT_appc(xlate_formula f, xlate_formula_expl_ne_list l) + | CRecord (_,_,_) -> xlate_error "CRecord: TODO" | CCases (_, _, _, [], _) -> assert false | CCases (_, _, ret_type, tm::tml, eqns)-> CT_cases(CT_matched_formula_ne_list(xlate_matched_formula tm, @@ -392,7 +396,9 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function xlate_formula b1, xlate_formula b2) | CSort(_, s) -> CT_coerce_SORT_TYPE_to_FORMULA(xlate_sort s) - | CNotation(_, s, l) -> notation_to_formula s (List.map xlate_formula l) + | CNotation(_, s,(l,[])) -> notation_to_formula s (List.map xlate_formula l) + | CNotation(_, s,(l,_)) -> xlate_error "CNotation (recursive): TODO" + | CGeneralization(_,_,_,_) -> xlate_error "CGeneralization: TODO" | CPrim (_, Numeral i) -> CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bigint.to_string i)) | CPrim (_, String _) -> xlate_error "CPrim (String): TODO" @@ -642,12 +648,14 @@ let is_tactic_special_case = function let xlate_context_pattern = function | Term v -> CT_coerce_FORMULA_to_CONTEXT_PATTERN (xlate_formula v) - | Subterm (idopt, v) -> + | Subterm (b, idopt, v) -> (* TODO: application pattern *) CT_context(xlate_ident_opt idopt, xlate_formula v) let xlate_match_context_hyps = function - | Hyp (na,b) -> CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b);; + | Hyp (na,b) -> CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b) + | Def (na,b,t) -> xlate_error "TODO: Let hyps" + (* CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b, xlate_context_pattern t);; *) let xlate_arg_to_id_opt = function Some id -> CT_coerce_ID_to_ID_OPT(CT_ident (string_of_id id)) @@ -1155,12 +1163,12 @@ and xlate_tac = xlate_error "TODO: trivial using" | TacReduce (red, l) -> CT_reduce (xlate_red_tactic red, xlate_clause l) - | TacApply (true,false,[c,bindl]) -> + | TacApply (true,false,[c,bindl],None) -> CT_apply (xlate_formula c, xlate_bindings bindl) - | TacApply (true,true,[c,bindl]) -> + | TacApply (true,true,[c,bindl],None) -> CT_eapply (xlate_formula c, xlate_bindings bindl) - | TacApply (_,_,_) -> - xlate_error "TODO: simple (e)apply and iterated apply" + | TacApply (_,_,_,_) -> + xlate_error "TODO: simple (e)apply and iterated apply and apply in" | TacConstructor (false,n_or_meta, bindl) -> let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error "" in CT_constructor (CT_int n, xlate_bindings bindl) @@ -1248,13 +1256,13 @@ and xlate_tac = but the structures are different *) xlate_clause cl) | TacLetTac (na, c, cl, false) -> xlate_error "TODO: remember" - | TacAssert (None, (_,IntroIdentifier id), c) -> + | TacAssert (None, Some (_,IntroIdentifier id), c) -> CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (None, (_,IntroAnonymous), c) -> + | TacAssert (None, None, c) -> CT_assert(xlate_id_opt ((0,0),Anonymous), xlate_formula c) - | TacAssert (Some (TacId []), (_,IntroIdentifier id), c) -> + | TacAssert (Some (TacId []), Some (_,IntroIdentifier id), c) -> CT_truecut(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (Some (TacId []), (_,IntroAnonymous), c) -> + | TacAssert (Some (TacId []), None, c) -> CT_truecut(xlate_id_opt ((0,0),Anonymous), xlate_formula c) | TacAssert _ -> xlate_error "TODO: assert with 'as' and 'by' and pose proof with 'as'" @@ -1302,11 +1310,13 @@ and coerce_genarg_to_TARG x = (CT_coerce_ID_to_ID_OR_INT id)) | IntroPatternArgType -> xlate_error "TODO" - | IdentArgType -> + | IdentArgType true -> let id = xlate_ident (out_gen rawwit_ident x) in CT_coerce_FORMULA_OR_INT_to_TARG (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT (CT_coerce_ID_to_ID_OR_INT id)) + | IdentArgType false -> + xlate_error "TODO" | VarArgType -> let id = xlate_ident (snd (out_gen rawwit_var x)) in CT_coerce_FORMULA_OR_INT_to_TARG @@ -1400,11 +1410,13 @@ let coerce_genarg_to_VARG x = (CT_coerce_ID_to_ID_OPT id)) | IntroPatternArgType -> xlate_error "TODO" - | IdentArgType -> + | IdentArgType true -> let id = xlate_ident (out_gen rawwit_ident x) in CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT id)) + | IdentArgType false -> + xlate_error "TODO" | VarArgType -> let id = xlate_ident (snd (out_gen rawwit_var x)) in CT_coerce_ID_OPT_OR_ALL_to_VARG @@ -1489,7 +1501,7 @@ let build_constructors l = CT_constr_list (List.map f l) let build_record_field_list l = - let build_record_field (coe,d) = match d with + let build_record_field ((coe,d),not) = match d with | AssumExpr (id,c) -> if coe then CT_recconstr_coercion (xlate_id_opt id, xlate_formula c) else @@ -1735,6 +1747,8 @@ let rec xlate_vernac = (fst::rest) -> CT_formula_ne_list(fst,rest) | _ -> assert false in CT_hintrewrite(ct_orient, f_ne_list, CT_ident base, xlate_tactic t) + | VernacCreateHintDb (local,dbname,b) -> + xlate_error "TODO: VernacCreateHintDb" | VernacHints (local,dbnames,h) -> let dblist = CT_id_list(List.map (fun x -> CT_ident x) dbnames) in (match h with @@ -1749,7 +1763,10 @@ let rec xlate_vernac = CT_hints(CT_ident "Constructors", CT_id_ne_list(n1, names), dblist) | HintsExtern (n, c, t) -> - CT_hint_extern(CT_int n, xlate_formula c, xlate_tactic t, dblist) + let pat = match c with + | None -> CT_coerce_ID_OPT_to_FORMULA_OPT (CT_coerce_NONE_to_ID_OPT CT_none) + | Some c -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula c) + in CT_hint_extern(CT_int n, pat, xlate_tactic t, dblist) | HintsImmediate l -> let f1, formulas = match List.map xlate_formula l with a :: tl -> a, tl @@ -1768,7 +1785,7 @@ let rec xlate_vernac = | HintsImmediate _ -> CT_hints_immediate(l', dblist) | _ -> assert false) | HintsResolve l -> - let f1, formulas = match List.map xlate_formula (List.map snd l) with + let f1, formulas = match List.map xlate_formula (List.map pi3 l) with a :: tl -> a, tl | _ -> failwith "" in let l' = CT_formula_ne_list(f1, formulas) in @@ -1793,6 +1810,16 @@ let rec xlate_vernac = CT_id_ne_list(n1, names), dblist) else CT_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist) + | HintsTransparency (l,b) -> + let n1, names = match List.map loc_qualid_to_ct_ID l with + n1 :: names -> n1, names + | _ -> failwith "" in + let ty = if b then "Transparent" else "Opaque" in + if local then + CT_local_hints(CT_ident ty, + CT_id_ne_list(n1, names), dblist) + else + CT_hints(CT_ident ty, CT_id_ne_list(n1, names), dblist) | HintsDestruct(id, n, loc, f, t) -> let dl = match loc with ConclLocation() -> CT_conclusion_location @@ -1859,7 +1886,8 @@ let rec xlate_vernac = | PrintHint id -> CT_print_hint (CT_coerce_ID_to_ID_OPT (loc_qualid_to_ct_ID id)) | PrintHintGoal -> CT_print_hint ctv_ID_OPT_NONE - | PrintLoadPath -> CT_print_loadpath + | PrintLoadPath None -> CT_print_loadpath + | PrintLoadPath _ -> xlate_error "TODO: Print LoadPath dir" | PrintMLLoadPath -> CT_ml_print_path | PrintMLModules -> CT_ml_print_modules | PrintGraph -> CT_print_graph @@ -1878,7 +1906,6 @@ let rec xlate_vernac = xlate_error "TODO: Print TypeClasses" | PrintInspect n -> CT_inspect (CT_int n) | PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s) - | PrintSetoids -> CT_print_setoids | PrintTables -> CT_print_tables | PrintModuleType a -> CT_print_module_type (loc_qualid_to_ct_ID a) | PrintModule a -> CT_print_module (loc_qualid_to_ct_ID a) @@ -1927,37 +1954,44 @@ let rec xlate_vernac = | SearchRewrite c -> CT_search_rewrite(xlate_formula c, translated_restriction) | SearchAbout (a::l) -> - let xlate_search_about_item it = + let xlate_search_about_item (b,it) = + if not b then xlate_error "TODO: negative searchabout constraint"; match it with - SearchRef x -> + SearchSubPattern (CRef x) -> CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) - | SearchString s -> - CT_coerce_STRING_to_ID_OR_STRING(CT_string s) in + | SearchString (s,None) -> + CT_coerce_STRING_to_ID_OR_STRING(CT_string s) + | SearchString _ | SearchSubPattern _ -> + xlate_error + "TODO: search subpatterns or notation with explicit scope" + in CT_search_about (CT_id_or_string_ne_list(xlate_search_about_item a, List.map xlate_search_about_item l), translated_restriction) | SearchAbout [] -> assert false) - | (*Record from tactics/Record.v *) - VernacRecord - (_, (add_coercion, (_,s)), binders, c1, - rec_constructor_or_none, field_list) -> - let record_constructor = - xlate_ident_opt (Option.map snd rec_constructor_or_none) in - CT_record - ((if add_coercion then CT_coercion_atm else - CT_coerce_NONE_to_COERCION_OPT(CT_none)), - xlate_ident s, xlate_binder_list binders, - xlate_formula c1, record_constructor, - build_record_field_list field_list) +(* | (\*Record from tactics/Record.v *\) *) +(* VernacRecord *) +(* (_, (add_coercion, (_,s)), binders, c1, *) +(* rec_constructor_or_none, field_list) -> *) +(* let record_constructor = *) +(* xlate_ident_opt (Option.map snd rec_constructor_or_none) in *) +(* CT_record *) +(* ((if add_coercion then CT_coercion_atm else *) +(* CT_coerce_NONE_to_COERCION_OPT(CT_none)), *) +(* xlate_ident s, xlate_binder_list binders, *) +(* xlate_formula (Option.get c1), record_constructor, *) +(* build_record_field_list field_list) *) | VernacInductive (isind, lmi) -> - let co_or_ind = if isind then "Inductive" else "CoInductive" in - let strip_mutind (((_,s), parameters, c, constructors), notopt) = + let co_or_ind = if Decl_kinds.recursivity_flag_of_kind isind then "Inductive" else "CoInductive" in + let strip_mutind = function + (((_, (_,s)), parameters, c, _, Constructors constructors), notopt) -> CT_ind_spec - (xlate_ident s, xlate_binder_list parameters, xlate_formula c, + (xlate_ident s, xlate_binder_list parameters, xlate_formula (Option.get c), build_constructors constructors, - translate_opt_notation_decl notopt) in + translate_opt_notation_decl notopt) + | _ -> xlate_error "TODO: Record notation in (Co)Inductive" in CT_mind_decl (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi)) | VernacFixpoint ([],_) -> xlate_error "mutual recursive" @@ -2116,7 +2150,7 @@ let rec xlate_vernac = (* Type Classes *) | VernacDeclareInstance _|VernacContext _| - VernacInstance (_, _, _, _, _)|VernacClass (_, _, _, _, _) -> + VernacInstance (_, _, _, _, _) -> xlate_error "TODO: Type Classes commands" | VernacResetName id -> CT_reset (xlate_ident (snd id)) diff --git a/contrib/jprover/README b/contrib/jprover/README deleted file mode 100644 index ec654a03..00000000 --- a/contrib/jprover/README +++ /dev/null @@ -1,76 +0,0 @@ -An intuitionistic first-order theorem prover -- JProver. - -Usage: - -Require JProver. -Jp [num]. - -Whem [num] is provided, proof is done automatically with -the multiplicity limit [num], otherwise no limit is forced -and JProver may not terminate. - -Example: - -Require JProver. -Coq < Goal (P:Prop) P->P. -1 subgoal - -============================ - (P:Prop)P->P - -Unnamed_thm < Jp 1. -Proof is built. -Subtree proved! ------------------------------------------ - -Description: -JProver is a theorem prover for first-order intuitionistic logic. -It is originally implemented by Stephan Schmitt and then integrated into -MetaPRL by Aleksey Nogin (see jall.ml). After this, Huang extracted the -necessary ML-codes from MetaPRL and then integrated it into Coq. -The MetaPRL URL is http://metaprl.org/. For more information on -integrating JProver into interactive proof assistants, please refer to - - "Stephan Schmitt, Lori Lorigo, Christoph Kreitz, and Aleksey Nogin, - Jprover: Integrating connection-based theorem proving into interactive - proof assistants. In International Joint Conference on Automated - Reasoning, volume 2083 of Lecture Notes in Artificial Intelligence, - pages 421-426. Springer-Verlag, 2001" - - http://www.cs.cornell.edu/nogin/papers/jprover.html - - -Structure of this directory: -This directory contains - - README ------ this file - jall.ml ------ the main module of JProver - jtunify.ml ------ string unification procedures for jall.ml - jlogic.ml ------ interface module of jall.ml - jterm.ml - opname.ml ------ implement the infrastructure for jall.ml - jprover.ml4 ------ the interface of jall.ml to Coq - JProver.v ------ declaration for Coq - Makefile ------ the makefile - go ------ batch file to load JProver to Coq dynamically - - -Comments: -1. The original is located in meta-prl/refiner/reflib of the -MetaPRL directory. Some parts of this file are modified by Huang. - -2. is also located in meta-prl/refiner/reflib with no modification. - -3. is modified from meta-prl/refiner/reflib/jlogic_sig.mlz. - -4. and are modified from the standard term module -of MetaPRL in meta-prl/refiner/term_std. - -5. The Jp tactic currently cannot prove formula such as - ((x:nat) (P x)) -> (EX y:nat| (P y)), which requires extra constants -in the domain when the left-All rule is applied. - - - -by Huang Guan-Shieng (Guan-Shieng.Huang@lri.fr), March 2002. - - diff --git a/contrib/jprover/jall.ml b/contrib/jprover/jall.ml deleted file mode 100644 index a9ebe5b6..00000000 --- a/contrib/jprover/jall.ml +++ /dev/null @@ -1,4599 +0,0 @@ -(* - * JProver first-order automated prover. See the interface file - * for more information and a list of references for JProver. - * - * ---------------------------------------------------------------- - * - * This file is part of MetaPRL, a modular, higher order - * logical framework that provides a logical programming - * environment for OCaml and other languages. - * - * See the file doc/index.html for information on Nuprl, - * OCaml, and more information about this system. - * - * Copyright (C) 2000 Stephan Schmitt - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - * - * Author: Stephan Schmitt - * Modified by: Aleksey Nogin - *) - -open Jterm -open Opname -open Jlogic -open Jtunify - -let ruletable = Jlogic.ruletable - -let free_var_op = make_opname ["free_variable"; "Jprover"] -let jprover_op = make_opname ["jprover"; "string"] - -module JProver (JLogic : JLogicSig) = -struct - type polarity = I | O - - type connective = And | Or | Neg | Imp | All | Ex | At | Null - - type ptype = Alpha | Beta | Gamma | Delta | Phi | Psi | PNull - - type stype = - Alpha_1 | Alpha_2 | Beta_1 | Beta_2 | Gamma_0 | Delta_0 - | Phi_0 | Psi_0 | PNull_0 - - type pos = {name : string; - address : int list; - op : connective; - pol : polarity; - pt : ptype; - st : stype; - label : term} - - type 'pos ftree = - Empty - | NodeAt of 'pos - | NodeA of 'pos * ('pos ftree) array - - type atom = {aname : string; - aaddress : int list; - aprefix : string list; - apredicate : operator; - apol : polarity; - ast : stype; - alabel : term} - - type atom_relations = atom * atom list * atom list -(* all atoms except atom occur in [alpha_set] and [beta_set] of atom*) - -(* beta proofs *) - - type bproof = BEmpty - | RNode of string list * bproof - | CNode of (string * string) - | BNode of string * (string list * bproof) * (string list * bproof) - | AtNode of string * (string * string) - -(* Assume only constants for instantiations, not adapted to terms yet *) - type inf = rule * term * term - -(* proof tree for pretty print and permutation *) - type 'inf ptree = - PEmpty - | PNodeAx of 'inf - | PNodeA of 'inf * 'inf ptree - | PNodeB of 'inf * 'inf ptree * 'inf ptree - - module OrderedAtom = - struct - type t = atom - let compare a1 a2 = if (a1.aname) = (a2.aname) then 0 else - if (a1.aname) < (a2.aname) then -1 else 1 - end - - module AtomSet = Set.Make(OrderedAtom) - - module OrderedString = - struct - type t = string - let compare a1 a2 = if a1 = a2 then 0 else - if a1 < a2 then -1 else 1 - end - - module StringSet = Set.Make(OrderedString) - -(*i let _ = - show_loading "Loading Jall%t" i*) - - let debug_jprover = - create_debug (**) - { debug_name = "jprover"; - debug_description = "Display Jprover operations"; - debug_value = false - } - - let jprover_bug = Invalid_argument "Jprover bug (Jall module)" - -(*****************************************************************) - -(************* printing function *************************************) - -(************ printing T-string unifiers ****************************) - -(* ******* printing ********** *) - - let rec list_to_string s = - match s with - [] -> "" - | f::r -> - f^"."^(list_to_string r) - - let rec print_eqlist eqlist = - match eqlist with - [] -> - print_endline "" - | (atnames,f)::r -> - let (s,t) = f in - let ls = list_to_string s - and lt = list_to_string t in - begin - print_endline ("Atom names: "^(list_to_string atnames)); - print_endline (ls^" = "^lt); - print_eqlist r - end - - let print_equations eqlist = - begin - Format.open_box 0; - Format.force_newline (); - print_endline "Equations:"; - print_eqlist eqlist; - Format.force_newline (); - end - - let rec print_subst sigma = - match sigma with - [] -> - print_endline "" - | f::r -> - let (v,s) = f in - let ls = list_to_string s in - begin - print_endline (v^" = "^ls); - print_subst r - end - - let print_tunify sigma = - let (n,subst) = sigma in - begin - print_endline " "; - print_endline ("MaxVar = "^(string_of_int (n-1))); - print_endline " "; - print_endline "Substitution:"; - print_subst subst; - print_endline " " - end - -(*****************************************************) - -(********* printing atoms and their relations ***********************) - - let print_stype st = - match st with - Alpha_1 -> Format.print_string "Alpha_1" - | Alpha_2 -> Format.print_string "Alpha_2" - | Beta_1 -> Format.print_string "Beta_1" - | Beta_2 -> Format.print_string "Beta_2" - | Gamma_0 -> Format.print_string "Gamma_0" - | Delta_0 -> Format.print_string "Delta_0" - | Phi_0 -> Format.print_string "Phi_0" - | Psi_0 -> Format.print_string "Psi_0" - | PNull_0 -> Format.print_string "PNull_0" - - let print_pol pol = - if pol = O then - Format.print_string "O" - else - Format.print_string "I" - - let rec print_address int_list = - match int_list with - [] -> - Format.print_string "" - | hd::rest -> - begin - Format.print_int hd; - print_address rest - end - - let rec print_prefix prefix_list = - match prefix_list with - [] -> Format.print_string "" - | f::r -> - begin - Format.print_string f; - print_prefix r - end - - let print_atom at tab = - let ({aname=x; aaddress=y; aprefix=z; apredicate=p; apol=a; ast=b; alabel=label}) = at in - begin - Format.print_string ("{aname="^x^"; address="); - print_address y; - Format.print_string "; "; - Format.force_newline (); - Format.print_break (tab+1) (tab+1); - Format.print_string "prefix="; - print_prefix z; - Format.print_string "; predicate=; "; - Format.print_break (tab+1) (tab+1); - Format.print_break (tab+1) (tab+1); - Format.print_string "pol="; - print_pol a; - Format.print_string "; stype="; - print_stype b; - Format.print_string "; arguments=[]"; - Format.print_string "\n alabel="; - print_term stdout label; - Format.print_string "}" - end - - let rec print_atom_list set tab = - match set with - [] -> Format.print_string "" - | (f::r) -> - begin - Format.force_newline (); - Format.print_break (tab) (tab); - print_atom f tab; - print_atom_list r (tab) - end - - let rec print_atom_info atom_relation = - match atom_relation with - [] -> Format.print_string "" - | (a,b,c)::r -> - begin - Format.print_string "atom:"; - Format.force_newline (); - Format.print_break 3 3; - print_atom a 3; - Format.force_newline (); - Format.print_break 0 0; - Format.print_string "alpha_set:"; - print_atom_list b 3; - Format.force_newline (); - Format.print_break 0 0; - Format.print_string "beta_set:"; - print_atom_list c 3; - Format.force_newline (); - Format.force_newline (); - Format.print_break 0 0; - print_atom_info r - end - -(*************** print formula tree, tree ordering etc. ***********) - - let print_ptype pt = - match pt with - Alpha -> Format.print_string "Alpha" - | Beta -> Format.print_string "Beta" - | Gamma -> Format.print_string "Gamma" - | Delta -> Format.print_string "Delta" - | Phi -> Format.print_string "Phi" - | Psi -> Format.print_string "Psi" - | PNull -> Format.print_string "PNull" - - let print_op op = - match op with - At -> Format.print_string "Atom" - | Neg -> Format.print_string "Neg" - | And -> Format.print_string "And" - | Or -> Format.print_string "Or" - | Imp -> Format.print_string "Imp" - | Ex -> Format.print_string "Ex" - | All -> Format.print_string "All" - | Null -> Format.print_string "Null" - - let print_position position tab = - let ({name=x; address=y; op=z; pol=a; pt=b; st=c; label=t}) = position in - begin - Format.print_string ("{name="^x^"; address="); - print_address y; - Format.print_string "; "; - Format.force_newline (); - Format.print_break (tab+1) 0; -(* Format.print_break 0 3; *) - Format.print_string "op="; - print_op z; - Format.print_string "; pol="; - print_pol a; - Format.print_string "; ptype="; - print_ptype b; - Format.print_string "; stype="; - print_stype c; - Format.print_string ";"; - Format.force_newline (); - Format.print_break (tab+1) 0; - Format.print_string "label="; - Format.print_break 0 0; - Format.force_newline (); - Format.print_break tab 0; - print_term stdout t; - Format.print_string "}" - end - - let rec pp_ftree_list tree_list tab = - let rec pp_ftree ftree new_tab = - let dummy = String.make (new_tab-2) ' ' in - match ftree with - Empty -> Format.print_string "" - | NodeAt(position) -> - begin - Format.force_newline (); - Format.print_break new_tab 0; - print_string (dummy^"AtomNode: "); -(* Format.force_newline (); - Format.print_break 0 3; -*) - print_position position new_tab; - Format.force_newline (); - Format.print_break new_tab 0 - end - | NodeA(position,subtrees) -> - let tree_list = Array.to_list subtrees in - begin - Format.force_newline (); - Format.print_break new_tab 0; - Format.print_break 0 0; - print_string (dummy^"InnerNode: "); - print_position position new_tab; - Format.force_newline (); - Format.print_break 0 0; - pp_ftree_list tree_list (new_tab-3) - end - in - let new_tab = tab+5 in - match tree_list with - [] -> Format.print_string "" - | first::rest -> - begin - pp_ftree first new_tab; - pp_ftree_list rest tab - end - - let print_ftree ftree = - begin - Format.open_box 0; - Format.print_break 3 0; - pp_ftree_list [ftree] 0; - Format.print_flush () - end - - let rec stringlist_to_string stringlist = - match stringlist with - [] -> "." - | f::r -> - let rest_s = stringlist_to_string r in - (f^"."^rest_s) - - let rec print_stringlist slist = - match slist with - [] -> - Format.print_string "" - | f::r -> - begin - Format.print_string (f^"."); - print_stringlist r - end - - let rec pp_bproof_list tree_list tab = - let rec pp_bproof ftree new_tab = - let dummy = String.make (new_tab-2) ' ' in - match ftree with - BEmpty -> Format.print_string "" - | CNode((c1,c2)) -> - begin - Format.open_box 0; - Format.force_newline (); - Format.print_break (new_tab-10) 0; - Format.open_box 0; - Format.force_newline (); - Format.print_string (dummy^"CloseNode: connection = ("^c1^","^c2^")"); - Format.print_flush(); -(* Format.force_newline (); - Format.print_break 0 3; -*) - Format.open_box 0; - Format.print_break new_tab 0; - Format.print_flush() - end - | AtNode(posname,(c1,c2)) -> - begin - Format.open_box 0; - Format.force_newline (); - Format.print_break (new_tab-10) 0; - Format.open_box 0; - Format.force_newline (); - Format.print_string (dummy^"AtNode: pos = "^posname^" conneciton = ("^c1^","^c2^")"); - Format.print_flush(); -(* Format.force_newline (); - Format.print_break 0 3; -*) - Format.open_box 0; - Format.print_break new_tab 0; - Format.print_flush() - end - | RNode(alpha_layer,bproof) -> - let alpha_string = stringlist_to_string alpha_layer in - begin - Format.open_box 0; - Format.force_newline (); - Format.print_break new_tab 0; - Format.print_break 0 0; - Format.force_newline (); - Format.print_flush(); - Format.open_box 0; - print_string (dummy^"RootNode: "^alpha_string); - Format.print_flush(); - Format.open_box 0; - Format.print_break 0 0; - Format.print_flush(); - pp_bproof_list [bproof] (new_tab-3) - end - | BNode(posname,(alph1,bproof1),(alph2,bproof2)) -> - let alpha_string1 = stringlist_to_string alph1 - and alpha_string2 = stringlist_to_string alph2 in - begin - Format.open_box 0; - Format.force_newline (); - Format.print_break new_tab 0; - Format.print_break 0 0; - Format.force_newline (); - Format.print_flush(); - Format.open_box 0; - print_string (dummy^"BetaNode: pos = "^posname^" layer1 = "^alpha_string1^" layer2 = "^alpha_string2); - Format.print_flush(); - Format.open_box 0; - Format.print_break 0 0; - Format.print_flush(); - pp_bproof_list [bproof1;bproof2] (new_tab-3) - end - in - let new_tab = tab+5 in - match tree_list with - [] -> Format.print_string "" - | first::rest -> - begin - pp_bproof first new_tab; - pp_bproof_list rest tab - end - - let rec print_pairlist pairlist = - match pairlist with - [] -> Format.print_string "" - | (a,b)::rest -> - begin - Format.print_break 1 1; - Format.print_string ("("^a^","^b^")"); - print_pairlist rest - end - - let print_beta_proof bproof = - begin - Format.open_box 0; - Format.force_newline (); - Format.force_newline (); - Format.print_break 3 0; - pp_bproof_list [bproof] 0; - Format.force_newline (); - Format.force_newline (); - Format.force_newline (); - Format.print_flush () - end - - let rec print_treelist treelist = - match treelist with - [] -> - print_endline "END"; - | f::r -> - begin - print_ftree f; - Format.open_box 0; - print_endline ""; - print_endline ""; - print_endline "NEXT TREE"; - print_endline ""; - print_endline ""; - print_treelist r; - Format.print_flush () - end - - let rec print_set_list set_list = - match set_list with - [] -> "" - | f::r -> - (f.aname)^" "^(print_set_list r) - - let print_set set = - let set_list = AtomSet.elements set in - if set_list = [] then "empty" - else - print_set_list set_list - - let print_string_set set = - let set_list = StringSet.elements set in - print_stringlist set_list - - let rec print_list_sets list_of_sets = - match list_of_sets with - [] -> Format.print_string "" - | (pos,fset)::r -> - begin - Format.print_string (pos^": "); (* first element = node which successors depend on *) - print_stringlist (StringSet.elements fset); - Format.force_newline (); - print_list_sets r - end - - let print_ordering list_of_sets = - begin - Format.open_box 0; - print_list_sets list_of_sets; - Format.print_flush () - end - - let rec print_triplelist triplelist = - match triplelist with - [] -> Format.print_string "" - | ((a,b),i)::rest -> - begin - Format.print_break 1 1; - Format.print_string ("(("^a^","^b^"),"^(string_of_int i)^")"); - print_triplelist rest - end - - let print_pos_n pos_n = - Format.print_int pos_n - - let print_formula_info ftree ordering pos_n = - begin - print_ftree ftree; - Format.open_box 0; - Format.force_newline (); - print_ordering ordering; - Format.force_newline (); - Format.force_newline (); - Format.print_string "number of positions: "; - print_pos_n pos_n; - Format.force_newline (); - print_endline ""; - print_endline ""; - Format.print_flush () - end - -(* print sequent proof tree *) - - let pp_rule (pos,r,formula,term) tab = - let rep = ruletable r in - if List.mem rep ["Alll";"Allr";"Exl";"Exr"] then - begin - Format.open_box 0; -(* Format.force_newline (); *) - Format.print_break tab 0; - Format.print_string (pos^": "^rep^" "); - Format.print_flush (); -(* Format.print_break tab 0; - Format.force_newline (); - Format.print_break tab 0; -*) - - Format.open_box 0; - print_term stdout formula; - Format.print_flush (); - Format.open_box 0; - Format.print_string " "; - Format.print_flush (); - Format.open_box 0; - print_term stdout term; - Format.force_newline (); - Format.force_newline (); - Format.print_flush () - end - else - begin - Format.open_box 0; - Format.print_break tab 0; - Format.print_string (pos^": "^rep^" "); - Format.print_flush (); - Format.open_box 0; -(* Format.print_break tab 0; *) - Format.force_newline (); -(* Format.print_break tab 0; *) - print_term stdout formula; - Format.force_newline () - end - - let last addr = - if addr = "" - then "" - else - String.make 1 (String.get addr (String.length addr-1)) - - let rest addr = - if addr = "" - then "" - else - String.sub addr 0 ((String.length addr) - 1) - - let rec get_r_chain addr = - if addr = "" then - 0 - else - let l = last addr in - if l = "l" then - 0 - else (* l = "r" *) - let rs = rest addr in - 1 + (get_r_chain rs) - - let rec tpp seqtree tab addr = - match seqtree with - | PEmpty -> raise jprover_bug - | PNodeAx(rule) -> - let (pos,r,p,pa) = rule in - begin - pp_rule (pos,r,p,pa) tab; -(* Format.force_newline (); *) -(* let mult = get_r_chain addr in *) -(* Format.print_break 100 (tab - (3 * mult)) *) - end - | PNodeA(rule,left) -> - let (pos,r,p,pa) = rule in - begin - pp_rule (pos,r,p,pa) tab; - tpp left tab addr - end - | PNodeB(rule,left,right) -> - let (pos,r,p,pa) = rule in - let newtab = tab + 3 in - begin - pp_rule (pos,r,p,pa) tab; -(* Format.force_newline (); *) -(* Format.print_break 100 newtab; *) - (tpp left newtab (addr^"l")); - (tpp right newtab (addr^"r")) - end - - let tt seqtree = - begin - Format.open_box 0; - tpp seqtree 0 ""; - Format.force_newline (); - Format.close_box (); - Format.print_newline () - end - -(************ END printing functions *********************************) - -(************ Beta proofs and redundancy deletion **********************) - - let rec remove_dups_connections connection_list = - match connection_list with - [] -> [] - | (c1,c2)::r -> - if (List.mem (c1,c2) r) or (List.mem (c2,c1) r) then - (* only one direction variant of a connection stays *) - remove_dups_connections r - else - (c1,c2)::(remove_dups_connections r) - - let rec remove_dups_list list = - match list with - [] -> [] - | f::r -> - if List.mem f r then - remove_dups_list r - else - f::(remove_dups_list r) - - let beta_pure alpha_layer connections beta_expansions = - let (l1,l2) = List.split connections in - let test_list = l1 @ l2 @ beta_expansions in - begin -(* Format.open_box 0; - print_endline ""; - print_stringlist alpha_layer; - Format.print_flush(); - Format.open_box 0; - print_endline ""; - print_stringlist test_list; - print_endline ""; - Format.print_flush(); -*) - not (List.exists (fun x -> (List.mem x test_list)) alpha_layer) - end - - let rec apply_bproof_purity bproof = - match bproof with - BEmpty -> - raise jprover_bug - | CNode((c1,c2)) -> - bproof,[(c1,c2)],[] - | AtNode(_,(c1,c2)) -> - bproof,[(c1,c2)],[] - | RNode(alpha_layer,subproof) -> - let (opt_subproof,min_connections,beta_expansions) = - apply_bproof_purity subproof in - (RNode(alpha_layer,opt_subproof),min_connections,beta_expansions) - | BNode(pos,(alph1,subp1),(alph2,subp2)) -> - let (opt_subp1,min_conn1,beta_exp1) = apply_bproof_purity subp1 in - if beta_pure alph1 min_conn1 beta_exp1 then - begin -(* print_endline ("Left layer of "^pos); *) - (opt_subp1,min_conn1,beta_exp1) - end - else - let (opt_subp2,min_conn2,beta_exp2) = apply_bproof_purity subp2 in - if beta_pure alph2 min_conn2 beta_exp2 then - begin -(* print_endline ("Right layer of "^pos); *) - (opt_subp2,min_conn2,beta_exp2) - end - else - let min_conn = remove_dups_connections (min_conn1 @ min_conn2) - and beta_exp = remove_dups_list ([pos] @ beta_exp1 @ beta_exp2) in - (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2)),min_conn,beta_exp) - - let bproof_purity bproof = - let (opt_bproof,min_connections,_) = apply_bproof_purity bproof in - opt_bproof,min_connections - -(*********** split permutation *****************) - - let rec apply_permutation bproof rep_name direction act_blayer = - match bproof with - BEmpty | RNode(_,_) -> - raise jprover_bug - | AtNode(cx,(c1,c2)) -> - bproof,act_blayer - | CNode((c1,c2)) -> - bproof,act_blayer - | BNode(pos,(alph1,subp1),(alph2,subp2)) -> - if rep_name = pos then - let (new_blayer,replace_branch) = - if direction = "left" then - (alph1,subp1) - else (* direciton = "right" *) - (alph2,subp2) - in - (match replace_branch with - CNode((c1,c2)) -> - (AtNode(c1,(c1,c2))),new_blayer (* perform atom expansion at c1 *) - | _ -> - replace_branch,new_blayer - ) - else - let pproof1,new_blayer1 = apply_permutation subp1 rep_name direction act_blayer in - let pproof2,new_blayer2 = apply_permutation subp2 rep_name direction new_blayer1 in - (BNode(pos,(alph1,pproof1),(alph2,pproof2))),new_blayer2 - - let split_permutation pname opt_bproof = - match opt_bproof with - RNode(alayer,BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) -> - if pos = pname then -(* if topmost beta expansion agrees with pname, then *) -(* only split the beta proof and give back the two subproofs *) - let (osubp1,min_con1) = bproof_purity opt_subp1 - and (osubp2,min_con2) = bproof_purity opt_subp2 in -(* there will be no purity reductions in the beta subproofs. We use this *) -(* predicate to collect the set of used leaf-connections in each subproof*) - ((RNode((alayer @ alph1),osubp1),min_con1), - (RNode((alayer @ alph2),osubp2),min_con2) - ) -(* we combine the branch after topmost beta expansion at pos into one root alpha layer *) -(* -- the beta expansion node pos will not be needed in this root layer *) - else - let perm_bproof1,balph1 = apply_permutation - (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) pname "left" [] - and perm_bproof2,balph2 = apply_permutation - (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) pname "right" [] in - - begin -(* print_endline " "; - print_beta_proof perm_bproof1; - print_endline" " ; - print_beta_proof perm_bproof2; - print_endline" "; -*) - let (osubp1,min_con1) = bproof_purity perm_bproof1 - and (osubp2,min_con2) = bproof_purity perm_bproof2 in - ((RNode((alayer @ balph1),osubp1),min_con1), - (RNode((alayer @ balph2),osubp2),min_con2) - ) - end -(* we combine the branch after the NEW topmost beta expansion at bpos *) -(* into one root alpha layer -- the beta expansion node bpos will not be *) -(* needed in this root layer *) - | _ -> - raise jprover_bug - -(*********** END split permutation *****************) - - let rec list_del list_el el_list = - match el_list with - [] -> - raise jprover_bug - | f::r -> - if list_el = f then - r - else - f::(list_del list_el r) - - let rec list_diff del_list check_list = - match del_list with - [] -> - [] - | f::r -> - if List.mem f check_list then - list_diff r check_list - else - f::(list_diff r check_list) - -(* let rec compute_alpha_layer ftree_list = - match ftree_list with - [] -> - [],[],[] - | f::r -> - (match f with - Empty -> - raise jprover_bug - | NodeAt(pos) -> - let pn = pos.name - and (rnode,ratom,borderings) = compute_alpha_layer r in - ((pn::rnode),(pn::ratom),borderings) - | NodeA(pos,suctrees) -> - let pn = pos.name in - if pos.pt = Beta then - let (rnode,ratom,borderings) = compute_alpha_layer r in - ((pn::rnode),(ratom),(f::borderings)) - else - let suclist = Array.to_list suctrees in - compute_alpha_layer (suclist @ r) - ) - - let rec compute_connection alpha_layer union_atoms connections = - match connections with - [] -> ("none","none") - | (c,d)::r -> - if (List.mem c union_atoms) & (List.mem d union_atoms) then - let (c1,c2) = - if List.mem c alpha_layer then - (c,d) - else - if List.mem d alpha_layer then - (d,c) (* then, d is supposed to occur in [alpha_layer] *) - else - raise (Invalid_argument "Jprover bug: connection match failure") - in - (c1,c2) - else - compute_connection alpha_layer union_atoms r - - let get_beta_suctrees btree = - match btree with - Empty | NodeAt(_) -> raise jprover_bug - | NodeA(pos,suctrees) -> - let b1tree = suctrees.(0) - and b2tree = suctrees.(1) in - (pos.name,b1tree,b2tree) - - let rec build_beta_proof alpha_layer union_atoms beta_orderings connections = - let (c1,c2) = compute_connection alpha_layer union_atoms connections in -(* [c1] is supposed to occur in the lowmost alpha layer of the branch, *) -(* i.e. [aplha_layer] *) - if (c1,c2) = ("none","none") then - (match beta_orderings with - [] -> raise jprover_bug - | btree::r -> - let (beta_pos,suctree1,suctree2) = get_beta_suctrees btree in - let (alpha_layer1, atoms1, bordering1) = compute_alpha_layer [suctree1] - and (alpha_layer2, atoms2, bordering2) = compute_alpha_layer [suctree2] in - let bproof1,beta1,closure1 = - build_beta_proof alpha_layer1 (atoms1 @ union_atoms) - (bordering1 @ r) connections - in - let bproof2,beta2,closure2 = - build_beta_proof alpha_layer2 (atoms2 @ union_atoms) - (bordering2 @ r) connections in - (BNode(beta_pos,(alpha_layer1,bproof1),(alpha_layer2,bproof2))),(1+beta1+beta2),(closure1+closure2) - ) - else - CNode((c1,c2)),0,1 - - let construct_beta_proof ftree connections = - let (root_node,root_atoms,beta_orderings) = compute_alpha_layer [ftree] - in - let beta_proof,beta_exp,closures = - build_beta_proof root_node root_atoms beta_orderings connections in - (RNode(root_node,beta_proof)),beta_exp,closures -*) - - -(* *********** New Version with direct computation from extension proof **** *) -(* follows a DIRECT step from proof histories via pr-connection orderings to opt. beta-proofs *) - - let rec compute_alpha_layer ftree_list = - match ftree_list with - [] -> - [] - | f::r -> - (match f with - Empty -> - raise jprover_bug - | NodeAt(pos) -> - let rnode = compute_alpha_layer r in - (pos.name::rnode) - | NodeA(pos,suctrees) -> - if pos.pt = Beta then - let rnode = compute_alpha_layer r in - (pos.name::rnode) - else - let suclist = Array.to_list suctrees in - compute_alpha_layer (suclist @ r) - ) - - let rec compute_beta_difference c1_context c2_context act_context = - match c1_context,c2_context with - ([],c2_context) -> - (list_diff c2_context act_context) -(* both connection partners in the same submatrix; [c1] already isolated *) - | ((fc1::rc1),[]) -> - [] (* [c2] is a reduction step, i.e. isolated before [c1] *) - | ((fc1::rc1),(fc2::rc2)) -> - if fc1 = fc2 then (* common initial beta-expansions *) - compute_beta_difference rc1 rc2 act_context - else - (list_diff c2_context act_context) - - let rec non_closed beta_proof_list = - match beta_proof_list with - [] -> - false - | bpf::rbpf -> - (match bpf with - RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | BEmpty -> true - | CNode(_) -> non_closed rbpf - | BNode(pos,(_,bp1),(_,bp2)) -> non_closed ([bp1;bp2] @ rbpf) - ) - - let rec cut_context pos context = - match context with - [] -> - raise (Invalid_argument "Jprover bug: invalid context element") - | (f,num)::r -> - if pos = f then - context - else - cut_context pos r - - let compute_tree_difference beta_proof c1_context = - match beta_proof with - RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | CNode(_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | BEmpty -> c1_context - | BNode(pos,_,_) -> -(* print_endline ("actual root: "^pos); *) - cut_context pos c1_context - - let print_context conn bcontext = - begin - Format.open_box 0; - Format.print_string conn; - Format.print_string ": "; - List.iter (fun x -> let (pos,num) = x in Format.print_string (pos^" "^(string_of_int num)^"")) bcontext; - print_endline " "; - Format.print_flush () - end - - let rec build_opt_beta_proof beta_proof ext_proof beta_atoms beta_layer_list act_context = - let rec add_c2_tree (c1,c2) c2_diff_context = - match c2_diff_context with - [] -> - (CNode(c1,c2),0) - | (f,num)::c2_diff_r -> - let next_beta_proof,next_exp = - add_c2_tree (c1,c2) c2_diff_r in - let (layer1,layer2) = List.assoc f beta_layer_list in - let new_bproof = - if num = 1 then - BNode(f,(layer1,next_beta_proof),(layer2,BEmpty)) - else (* num = 2*) - BNode(f,(layer1,BEmpty),(layer2,next_beta_proof)) - in - (new_bproof,(next_exp+1)) - in - let rec add_beta_expansions (c1,c2) rest_ext_proof c1_diff_context c2_diff_context new_act_context = - match c1_diff_context with - [] -> - let (n_c1,n_c2) = - if c2_diff_context = [] then (* make sure that leaf-connection is first element *) - (c1,c2) - else - (c2,c1) - in - let c2_bproof,c2_exp = add_c2_tree (n_c1,n_c2) c2_diff_context in - if c2_exp <> 0 then (* at least one open branch was generated to isloate [c2] *) - begin -(* print_endline "start with new beta-proof"; *) - let new_bproof,new_exp,new_closures,new_rest_proof = - build_opt_beta_proof c2_bproof rest_ext_proof beta_atoms beta_layer_list (act_context @ new_act_context) in - (new_bproof,(new_exp+c2_exp),(new_closures+1),new_rest_proof) - end - else - begin -(* print_endline "proceed with old beta-proof"; *) - (c2_bproof,c2_exp,1,rest_ext_proof) - end - | (f,num)::c1_diff_r -> - let (layer1,layer2) = List.assoc f beta_layer_list in - let next_beta_proof,next_exp,next_closures,next_ext_proof = - add_beta_expansions (c1,c2) rest_ext_proof c1_diff_r c2_diff_context new_act_context in - let new_bproof = - if num = 1 then - BNode(f,(layer1,next_beta_proof),(layer2,BEmpty)) - else (* num = 2*) - BNode(f,(layer1,BEmpty),(layer2,next_beta_proof)) - in - (new_bproof,(next_exp+1),next_closures,next_ext_proof) - - in - let rec insert_connection beta_proof (c1,c2) rest_ext_proof c1_diff_context c2_diff_context act_context = - begin -(* print_context c1 c1_diff_context; - print_endline ""; - print_context c2 c2_diff_context; - print_endline ""; -*) - match beta_proof with - RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | CNode(_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | BEmpty -> - add_beta_expansions (c1,c2) rest_ext_proof c1_diff_context c2_diff_context act_context - | BNode(pos,(layer1,sproof1),(layer2,sproof2)) -> -(* print_endline (c1^" "^c2^" "^pos); *) - (match c1_diff_context with - [] -> - raise (Invalid_argument "Jprover bug: invalid beta-proof") - | (f,num)::rest_context -> (* f = pos must hold!! *) - if num = 1 then - let (next_bproof,next_exp,next_closure,next_ext_proof) = - insert_connection sproof1 (c1,c2) rest_ext_proof rest_context c2_diff_context act_context in - (BNode(pos,(layer1,next_bproof),(layer2,sproof2)),next_exp,next_closure,next_ext_proof) - else (* num = 2 *) - let (next_bproof,next_exp,next_closure,next_ext_proof) = - insert_connection sproof2 (c1,c2) rest_ext_proof rest_context c2_diff_context act_context in - (BNode(pos,(layer1,sproof1),(layer2,next_bproof)),next_exp,next_closure,next_ext_proof) - ) - end - - in - match ext_proof with - [] -> - beta_proof,0,0,[] - | (c1,c2)::rproof -> -(* print_endline ("actual connection: "^c1^" "^c2); *) - let c1_context = List.assoc c1 beta_atoms - and c2_context = List.assoc c2 beta_atoms in - let c2_diff_context = compute_beta_difference c1_context c2_context act_context - and c1_diff_context = compute_tree_difference beta_proof c1_context in (* wrt. actual beta-proof *) - let (next_beta_proof,next_exp,next_closures,next_ext_proof) = - insert_connection beta_proof (c1,c2) rproof c1_diff_context c2_diff_context c1_diff_context in - if non_closed [next_beta_proof] then (* at least one branch was generated to isolate [c1] *) - let rest_beta_proof,rest_exp,rest_closures,rest_ext_proof = - build_opt_beta_proof next_beta_proof next_ext_proof beta_atoms beta_layer_list act_context in - rest_beta_proof,(next_exp+rest_exp),(next_closures+rest_closures),rest_ext_proof - else - next_beta_proof,next_exp,next_closures,next_ext_proof - - let rec annotate_atoms beta_context atlist treelist = - let rec annotate_tree beta_context tree atlist = - match tree with - Empty -> - (atlist,[],[]) - | NodeAt(pos) -> - if List.mem pos.name atlist then - let new_atlist = list_del pos.name atlist in - (new_atlist,[(pos.name,beta_context)],[]) - else - (atlist,[],[]) - | NodeA(pos,suctrees) -> - if pos.pt = Beta then - let s1,s2 = suctrees.(0),suctrees.(1) in - let alayer1 = compute_alpha_layer [s1] - and alayer2 = compute_alpha_layer [s2] - and new_beta_context1 = beta_context @ [(pos.name,1)] - and new_beta_context2 = beta_context @ [(pos.name,2)] in - let atlist1,annotates1,blayer_list1 = - annotate_atoms new_beta_context1 atlist [s1] in - let atlist2,annotates2,blayer_list2 = - annotate_atoms new_beta_context2 atlist1 [s2] - in - (atlist2,(annotates1 @ annotates2),((pos.name,(alayer1,alayer2))::(blayer_list1 @ blayer_list2))) - else - annotate_atoms beta_context atlist (Array.to_list suctrees) - in - match treelist with - [] -> (atlist,[],[]) - | f::r -> - let (next_atlist,f_annotates,f_beta_layers) = annotate_tree beta_context f atlist in - let (rest_atlist,rest_annotates,rest_beta_layers) = (annotate_atoms beta_context next_atlist r) - in - (rest_atlist, (f_annotates @ rest_annotates),(f_beta_layers @ rest_beta_layers)) - - let construct_opt_beta_proof ftree ext_proof = - let con1,con2 = List.split ext_proof in - let con_atoms = remove_dups_list (con1 @ con2) in - let (empty_atoms,beta_atoms,beta_layer_list) = annotate_atoms [] con_atoms [ftree] in - let root_node = compute_alpha_layer [ftree] in - let (beta_proof,beta_exp,closures,_) = - build_opt_beta_proof BEmpty ext_proof beta_atoms beta_layer_list [] in - (RNode(root_node,beta_proof)),beta_exp,closures - -(************* permutation ljmc -> lj *********************************) - -(* REAL PERMUTATION STAFF *) - - let subf1 n m subrel = List.mem ((n,m),1) subrel - let subf2 n m subrel = List.mem ((n,m),2) subrel - let tsubf n m tsubrel = List.mem (n,m) tsubrel - -(* Transforms all normal form layers in an LJ proof *) - - let rec modify prooftree (subrel,tsubrel) = - match prooftree with - PEmpty -> - raise jprover_bug - | PNodeAx((pos,inf,form,term)) -> - prooftree,pos - | PNodeA((pos,inf,form,term),left) -> - let t,qpos = modify left (subrel,tsubrel) in - if List.mem inf [Impr;Negr;Allr] then - PNodeA((pos,inf,form,term),t),pos (* layer bound *) - else if qpos = "Orl-True" then - PNodeA((pos,inf,form,term),t),qpos - else if List.mem inf [Andl;Alll;Exl] then - PNodeA((pos,inf,form,term),t),qpos (* simply propagation *) - else if inf = Exr then - if (subf1 pos qpos subrel) then - PNodeA((pos,inf,form,term),t),pos - else t,qpos - else if inf = Negl then - if (subf1 pos qpos subrel) then - PNodeA((pos,inf,form,term),t),"" (* empty string *) - else t,qpos - else (* x = Orr *) - if (subf1 pos qpos subrel) then - PNodeA((pos,Orr1,form,term),t),pos (* make Orr for LJ *) - else if (subf2 pos qpos subrel) then - PNodeA((pos,Orr2,form,term),t),pos (* make Orr for LJ *) - else t,qpos - | PNodeB((pos,inf,form,term),left,right) -> - let t,qpos = modify left (subrel,tsubrel) in - if inf = Andr then - if (or) (qpos = "Orl-True") (subf1 pos qpos subrel) then - let s,rpos = modify right (subrel,tsubrel) in (* Orl-True -> subf *) - if (or) (rpos = "Orl-True") (subf2 pos rpos subrel) then - PNodeB((pos,inf,form,term),t,s),pos - else s,rpos - else t,qpos (* not subf -> not Orl-True *) - else if inf = Impl then - if (subf1 pos qpos subrel) then - let s,rpos = modify right (subrel,tsubrel) in - PNodeB((pos,inf,form,term),t,s),"" (* empty string *) - else t,qpos - else (* x = Orl *) - let s,rpos = modify right (subrel,tsubrel) in - PNodeB((pos,inf,form,term),t,s),"Orl-True" - -(* transforms the subproof into an LJ proof between - the beta-inference rule (excluded) and - layer boundary in the branch ptree *) - - let rec rec_modify ptree (subrel,tsubrel) = - match ptree with - PEmpty -> - raise jprover_bug - | PNodeAx((pos,inf,form,term)) -> - ptree,pos - | PNodeA((pos,inf,form,term),left) -> - if List.mem inf [Impr;Negr;Allr] then - ptree,pos (* layer bound, stop transforming! *) - else - let t,qpos = rec_modify left (subrel,tsubrel) in - if List.mem inf [Andl;Alll;Exl] then - PNodeA((pos,inf,form,term),t),qpos (* simply propagation*) - else if inf = Exr then - if (subf1 pos qpos subrel) then - PNodeA((pos,inf,form,term),t),pos - else t,qpos - else if inf = Negl then - if (subf1 pos qpos subrel) then - PNodeA((pos,inf,form,term),t),"" (* empty string *) - else t,qpos - else (* x = Orr *) - if (subf1 pos qpos subrel) then - PNodeA((pos,Orr1,form,term),t),pos (* make Orr for LJ *) - else if (subf2 pos qpos subrel) then - PNodeA((pos,Orr2,form,term),t),pos (* make Orr for LJ *) - else t,qpos - | PNodeB((pos,inf,form,term),left,right) -> - let t,qpos = rec_modify left (subrel,tsubrel) in - if inf = Andr then - if (subf1 pos qpos subrel) then - let s,rpos = rec_modify right (subrel,tsubrel) in - if (subf2 pos rpos subrel) then - PNodeB((pos,inf,form,term),t,s),pos - else s,rpos - else t,qpos - else (* x = Impl since x= Orl cannot occur in the partial layer ptree *) - - if (subf1 pos qpos subrel) then - let s,rpos = rec_modify right (subrel,tsubrel) in - PNodeB((pos,inf,form,term),t,s),"" (* empty string *) - else t,qpos - - let weak_modify rule ptree (subrel,tsubrel) = (* recall rule = or_l *) - let (pos,inf,formlua,term) = rule in - if inf = Orl then - ptree,true - else - let ptreem,qpos = rec_modify ptree (subrel,tsubrel) in - if (subf1 pos qpos subrel) then (* weak_modify will always be applied on left branches *) - ptreem,true - else - ptreem,false - -(* Now, the permutation stuff .... *) - -(* Permutation schemes *) - -(* corresponds to local permutation lemma -- Lemma 3 in the paper -- *) -(* with eigenvariablen renaming and branch modification *) - -(* eigenvariablen renaming and branch modification over *) -(* the whole proofs, i.e. over layer boundaries, too *) - - -(* global variable vor eigenvariable renaming during permutations *) - - let eigen_counter = ref 1 - -(* append renamed paramater "r" to non-quantifier subformulae - of renamed quantifier formulae *) - - let make_new_eigenvariable term = - let op = (dest_term term).term_op in - let opa = (dest_op op).op_params in - let oppar = dest_param opa in - match oppar with - | String ofname::_ -> - let new_eigen_var = (ofname^"_r"^(string_of_int (!eigen_counter))) in - eigen_counter := !eigen_counter + 1; - mk_string_term jprover_op new_eigen_var - | _ -> raise jprover_bug - - - let replace_subterm term oldt rept = - let v_term = var_subst term oldt "dummy_var" in - subst1 v_term "dummy_var" rept - - let rec eigen_rename old_parameter new_parameter ptree = - match ptree with - PEmpty -> - raise jprover_bug - | PNodeAx((pos,inf,form,term)) -> - let new_form = replace_subterm form old_parameter new_parameter in - PNodeAx((pos,inf,new_form,term)) - | PNodeA((pos,inf,form,term), left) -> - let new_form = replace_subterm form old_parameter new_parameter - and new_term = replace_subterm term old_parameter new_parameter in - let ren_left = eigen_rename old_parameter new_parameter left in - PNodeA((pos,inf,new_form,new_term), ren_left) - | PNodeB((pos,inf,form,term),left, right) -> - let new_form = replace_subterm form old_parameter new_parameter in - let ren_left = eigen_rename old_parameter new_parameter left in - let ren_right = eigen_rename old_parameter new_parameter right in - PNodeB((pos,inf,new_form,term), ren_left, ren_right) - - let rec update_ptree rule subtree direction tsubrel = - match subtree with - PEmpty -> - raise jprover_bug - | PNodeAx(r) -> - subtree - | PNodeA((pos,inf,formula,term), left) -> - if (pos,inf,formula,term) = rule then - left - (* don't delete rule if subformula belongs to renamed instance of quantifiers; *) - (* but this can never occur now since (renamed) formula is part of rule *) - else - let (posn,infn,formn,termn) = rule in - if (&) (List.mem infn [Exl;Allr] ) (term = termn) then - (* this can only occur if eigenvariable rule with same term as termn has been permuted; *) - (* the application of the same eigenvariable introduction on the same subformula with *) - (* different instantiated variables might occur! *) - (* termn cannot occur in terms of permuted quantifier rules due to substitution split *) - (* during reconstruciton of the ljmc proof *) - let new_term = make_new_eigenvariable term in -(* print_endline "Eigenvariable renaming!!!"; *) - eigen_rename termn new_term subtree - else - let left_del = - update_ptree rule left direction tsubrel - in - PNodeA((pos,inf,formula,term), left_del) - | PNodeB((pos,inf,formula,term), left, right) -> - if (pos,inf,formula,term) = rule then - if direction = "l" then - left - else - right (* direction = "r" *) - else - let left_del = update_ptree rule left direction tsubrel in - let right_del = update_ptree rule right direction tsubrel in - PNodeB((pos,inf,formula,term),left_del,right_del) - - let permute r1 r2 ptree la tsubrel = -(* print_endline "permute in"; *) - match ptree,la with - PNodeA(r1, PNodeA(r2,left)),la -> -(* print_endline "1-o-1"; *) - PNodeA(r2, PNodeA(r1,left)) - (* one-over-one *) - | PNodeA(r1, PNodeB(r2,left,right)),la -> -(* print_endline "1-o-2"; *) - PNodeB(r2, PNodeA(r1,left), PNodeA(r1,right)) - (* one-over-two *) - | PNodeB(r1, PNodeA(r2,left), right),"l" -> -(* print_endline "2-o-1 left"; *) - let right_u = update_ptree r2 right "l" tsubrel in - PNodeA(r2, PNodeB(r1, left, right_u)) - (* two-over-one left *) - | PNodeB(r1, left, PNodeA(r2,right)),"r" -> -(* print_endline "2-o-1 right"; *) - let left_u = update_ptree r2 left "l" tsubrel in - PNodeA(r2, PNodeB(r1, left_u, right)) - (* two-over-one right *) - | PNodeB(r1, PNodeB(r2,left2,right2), right),"l" -> -(* print_endline "2-o-2 left"; *) - let right_ul = update_ptree r2 right "l" tsubrel in - let right_ur = update_ptree r2 right "r" tsubrel in - PNodeB(r2,PNodeB(r1,left2,right_ul),PNodeB(r1,right2,right_ur)) - (* two-over-two left *) - | PNodeB(r1, left, PNodeB(r2,left2,right2)),"r" -> -(* print_endline "2-o-2 right"; *) - let left_ul = update_ptree r2 left "l" tsubrel in - let left_ur = update_ptree r2 left "r" tsubrel in - PNodeB(r2,PNodeB(r1,left_ul,left2),PNodeB(r1,left_ur, right2)) - (* two-over-two right *) - | _ -> raise jprover_bug - -(* permute layers, isolate addmissible branches *) - -(* computes if an Andr is d-generatives *) - - let layer_bound rule = - let (pos,inf,formula,term) = rule in - if List.mem inf [Impr;Negr;Allr] then - true - else - false - - let rec orl_free ptree = - match ptree with - PEmpty -> - raise jprover_bug - | PNodeAx(rule) -> - true - | PNodeA(rule,left) -> - if layer_bound rule then - true - else - orl_free left - | PNodeB(rule,left,right) -> - let (pos,inf,formula,term) = rule in - if inf = Orl then - false - else - (&) (orl_free left) (orl_free right) - - let rec dgenerative rule dglist ptree tsubrel = - let (pos,inf,formula,term) = rule in - if List.mem inf [Exr;Orr;Negl] then - true - else if inf = Andr then - if dglist = [] then - false - else - let first,rest = (List.hd dglist),(List.tl dglist) in - let (pos1,inf1,formula1,term1) = first in - if tsubf pos1 pos tsubrel then - true - else - dgenerative rule rest ptree tsubrel - else if inf = Impl then - not (orl_free ptree) - else - false - - -(* to compute a topmost addmissible pair r,o with - the address addr of r in the proof tree -*) - - let rec top_addmissible_pair ptree dglist act_r act_o act_addr tsubrel dummyt = - let rec search_pair ptree dglist act_r act_o act_addr tsubrel = - match ptree with - PEmpty -> raise jprover_bug - | PNodeAx(_) -> raise jprover_bug - | PNodeA(rule, left) -> -(* print_endline "alpha"; *) - if (dgenerative rule dglist left tsubrel) then (* r = Exr,Orr,Negl *) - let newdg = (@) [rule] dglist in - search_pair left newdg act_r rule act_addr tsubrel - else (* Impr, Allr, Notr only for test *) - search_pair left dglist act_r act_o act_addr tsubrel - | PNodeB(rule,left,right) -> -(* print_endline "beta"; *) - let (pos,inf,formula,term) = rule in - if List.mem inf [Andr;Impl] then - let bool = dgenerative rule dglist left tsubrel in - let newdg,newrule = - if bool then - ((@) [rule] dglist),rule - else - dglist,act_o - in - if orl_free left then - search_pair right newdg act_r newrule (act_addr^"r") tsubrel - else (* not orl_free *) - let left_r,left_o,left_addr = - search_pair left newdg act_r newrule (act_addr^"l") tsubrel in - if left_o = ("",Orr,dummyt,dummyt) then - top_addmissible_pair right dglist act_r act_o (act_addr^"r") tsubrel dummyt - else left_r,left_o,left_addr - else (* r = Orl *) - if orl_free left then - top_addmissible_pair right dglist rule act_o (act_addr^"r") tsubrel dummyt - else - let left_r,left_o,left_addr - = search_pair left dglist rule act_o (act_addr^"l") tsubrel in - if left_o = ("",Orr,dummyt,dummyt) then - top_addmissible_pair right dglist rule act_o (act_addr^"r") tsubrel dummyt - else - left_r,left_o,left_addr - in -(* print_endline "top_addmissible_pair in"; *) - if orl_free ptree then (* there must be a orl BELOW an layer bound *) - begin -(* print_endline "orl_free"; *) - act_r,act_o,act_addr - end - else - begin -(* print_endline "orl_full"; *) - search_pair ptree dglist act_r act_o act_addr tsubrel - end - - let next_direction addr act_addr = - String.make 1 (String.get addr (String.length act_addr)) - (* get starts with count 0*) - - let change_last addr d = - let split = (String.length addr) - 1 in - let prec,last = - (String.sub addr 0 split),(String.sub addr split 1) in - prec^d^last - - let last addr = - if addr = "" - then "" - else - String.make 1 (String.get addr (String.length addr-1)) - - let rest addr = - if addr = "" - then "" - else - String.sub addr 0 ((String.length addr) - 1) - - let rec permute_layer ptree dglist (subrel,tsubrel) = - let rec permute_branch r addr act_addr ptree dglist (subrel,tsubrel) = -(* print_endline "pbranch in"; *) - let la = last act_addr in (* no ensure uniqueness at 2-over-x *) - match ptree,la with - PNodeA(o,PNodeA(rule,left)),la -> (* one-over-one *) -(* print_endline " one-over-one "; *) - let permute_result = permute o rule ptree la tsubrel in - begin match permute_result with - PNodeA(r2,left2) -> - let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in - PNodeA(r2,pbleft) - | _ -> raise jprover_bug - end - | PNodeA(o,PNodeB(rule,left,right)),la -> (* one-over-two *) -(* print_endline " one-over-two "; *) - if rule = r then (* left,right are or_l free *) - permute o rule ptree la tsubrel (* first termination case *) - else - let d = next_direction addr act_addr in - if d = "l" then - let permute_result = permute o rule ptree la tsubrel in - (match permute_result with - PNodeB(r2,left2,right2) -> - let pbleft = permute_branch r addr (act_addr^d) left2 dglist (subrel,tsubrel) in - let plright = permute_layer right2 dglist (subrel,tsubrel) in - PNodeB(r2,pbleft,plright) - | _ -> raise jprover_bug - ) - else (* d = "r", that is left of rule is or_l free *) - let left1,bool = weak_modify rule left (subrel,tsubrel) in - if bool then (* rule is relevant *) - let permute_result = permute o rule (PNodeA(o,PNodeB(rule,left1,right))) la tsubrel in - (match permute_result with - PNodeB(r2,left2,right2) -> - let pbright = permute_branch r addr (act_addr^d) right2 dglist (subrel,tsubrel) in - PNodeB(r2,left2,pbright) - | _ -> raise jprover_bug - ) - else (* rule is not relevant *) - PNodeA(o,left1) (* optimized termination case (1) *) - | PNodeB(o,PNodeA(rule,left),right1),"l" -> (* two-over-one, left *) -(* print_endline " two-over-one, left "; *) - let permute_result = permute o rule ptree la tsubrel in - (match permute_result with - PNodeA(r2,left2) -> - let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in - PNodeA(r2,pbleft) - | _ -> raise jprover_bug - ) - | PNodeB(o,left1,PNodeA(rule,left)),"r" -> (* two-over-one, right *) - (* left of o is or_l free *) -(* print_endline " two-over-one, right"; *) - let leftm,bool = weak_modify o left1 (subrel,tsubrel) in - if bool then (* rule is relevant *) - let permute_result = permute o rule (PNodeB(o,leftm,PNodeA(rule,left))) la tsubrel in - (match permute_result with - PNodeA(r2,left2) -> - let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in - PNodeA(r2,pbleft) - | _ -> raise jprover_bug - ) - else (* rule is not relevant *) - leftm (* optimized termination case (2) *) - | PNodeB(o,PNodeB(rule,left,right),right1),"l" -> (* two-over-two, left *) -(* print_endline " two-over-two, left"; *) - if rule = r then (* left,right are or_l free *) - let permute_result = permute o rule ptree la tsubrel in - (match permute_result with - PNodeB(r2,PNodeB(r3,left3,right3),PNodeB(r4,left4,right4)) -> -(* print_endline "permute 2-o-2, left ok"; *) - let leftm3,bool3 = weak_modify r3 left3 (subrel,tsubrel) in - let leftm4,bool4 = weak_modify r4 left4 (subrel,tsubrel) in - let plleft,plright = - if (&) bool3 bool4 then (* r3 and r4 are relevant *) - (permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel)), - (permute_layer (PNodeB(r4,leftm4,right4)) dglist (subrel,tsubrel)) - else if (&) bool3 (not bool4) then (* only r3 is relevant *) - begin -(* print_endline "two-over-two left: bool3 and not bool4"; *) - (permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel)), - leftm4 - end - else if (&) (not bool3) bool4 then (* only r4 is relevant *) - leftm3, - (permute_layer (PNodeB(r4,leftm4,right4)) dglist (subrel,tsubrel)) - else (* neither r3 nor r4 are relevant *) - leftm3,leftm4 - in - PNodeB(r2,plleft,plright) - | _ -> raise jprover_bug - ) - else - let d = next_direction addr act_addr in - let newadd = change_last act_addr d in - if d = "l" then - let permute_result = permute o rule ptree la tsubrel in - (match permute_result with - PNodeB(r2,left2,right2) -> - let pbleft = permute_branch r addr newadd left2 dglist (subrel,tsubrel) in - let plright = permute_layer right2 dglist (subrel,tsubrel) in - PNodeB(r2,pbleft,plright) - | _ -> raise jprover_bug - ) - else (* d = "r", that is left is or_l free *) - let left1,bool = weak_modify rule left (subrel,tsubrel) in - if bool then (* rule is relevant *) - let permute_result = - permute o rule (PNodeB(o,PNodeB(rule,left1,right),right1)) la tsubrel in - (match permute_result with - PNodeB(r2,PNodeB(r3,left3,right3),right2) -> - let pbright = permute_branch r addr newadd right2 dglist (subrel,tsubrel) in - let leftm3,bool3 = weak_modify r3 left3 (subrel,tsubrel) in - let plleft = - if bool3 (* r3 relevant *) then - permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel) - else (* r3 redundant *) - leftm3 - in - PNodeB(r2,plleft,pbright) (* further opt. NOT possible *) - | _ -> raise jprover_bug - ) - else (* rule is not relevant *) - permute_layer (PNodeB(o,left1,right1)) dglist (subrel,tsubrel) (* further opt. possible *) - (* combine with orl_free *) - | PNodeB(o,left1,PNodeB(rule,left,right)),"r" -> (* two-over-two, right *) -(* print_endline " two-over-two, right"; *) - let leftm1,bool = weak_modify o left1 (subrel,tsubrel) in (* left1 is or_l free *) - if bool then (* o is relevant, even after permutations *) - if rule = r then (* left, right or_l free *) - permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel - else - let d = next_direction addr act_addr in - let newadd = change_last act_addr d in - if d = "l" then - let permute_result = - permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel in - (match permute_result with - PNodeB(r2,left2,right2) -> - let pbleft = permute_branch r addr newadd left2 dglist (subrel,tsubrel) in - let plright = permute_layer right2 dglist (subrel,tsubrel) in - PNodeB(r2,pbleft,plright) - | _ -> raise jprover_bug - ) - else (* d = "r", that is left is or_l free *) - let leftm,bool = weak_modify rule left (subrel,tsubrel) in - if bool then (* rule is relevant *) - let permute_result = - permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel in - (match permute_result with - PNodeB(r2,left2,right2) -> - let pbright = permute_branch r addr newadd right2 dglist (subrel,tsubrel) in - PNodeB(r2,left2,pbright) (* left2 or_l free *) - | _ -> raise jprover_bug - ) - else (* rule is not relevant *) - PNodeB(o,leftm1,leftm) - - else - leftm1 - | _ -> raise jprover_bug - in - let rec trans_add_branch r o addr act_addr ptree dglist (subrel,tsubrel) = - match ptree with - (PEmpty| PNodeAx(_)) -> raise jprover_bug - | PNodeA(rule,left) -> - if (dgenerative rule dglist left tsubrel) then - let newdg = (@) [rule] dglist in - if rule = o then - begin -(* print_endline "one-rule is o"; *) - permute_branch r addr act_addr ptree dglist (subrel,tsubrel) - end - else - begin -(* print_endline "alpha - but not o"; *) - let tptree = trans_add_branch r o addr act_addr left newdg (subrel,tsubrel) in - permute_layer (PNodeA(rule,tptree)) dglist (subrel,tsubrel) - (* r may not longer be valid for rule *) - end - else - let tptree = trans_add_branch r o addr act_addr left dglist (subrel,tsubrel) in - PNodeA(rule,tptree) - | PNodeB(rule,left,right) -> - let d = next_direction addr act_addr in - let bool = (dgenerative rule dglist left tsubrel) in - if rule = o then - begin -(* print_endline "two-rule is o"; *) - permute_branch r addr (act_addr^d) ptree dglist (subrel,tsubrel) - end - else - begin -(* print_endline ("beta - but not o: address "^d); *) - let dbranch = - if d = "l" then - left - else (* d = "r" *) - right - in - let tptree = - if bool then - let newdg = (@) [rule] dglist in - (trans_add_branch r o addr (act_addr^d) dbranch newdg (subrel,tsubrel)) - else - (trans_add_branch r o addr (act_addr^d) dbranch dglist (subrel,tsubrel)) - in - if d = "l" then - permute_layer (PNodeB(rule,tptree,right)) dglist (subrel,tsubrel) - else (* d = "r" *) - begin -(* print_endline "prob. a redundant call"; *) - let back = permute_layer (PNodeB(rule,left,tptree)) dglist (subrel,tsubrel) in -(* print_endline "SURELY a redundant call"; *) - back - end - end - in -(* print_endline "permute_layer in"; *) - let dummyt = mk_var_term "dummy" in - let r,o,addr = - top_addmissible_pair ptree dglist ("",Orl,dummyt,dummyt) ("",Orr,dummyt,dummyt) "" tsubrel dummyt in - if r = ("",Orl,dummyt,dummyt) then - ptree - else if o = ("",Orr,dummyt,dummyt) then (* Orr is a dummy for no d-gen. rule *) - ptree - else -(* - let (x1,x2,x3,x4) = r - and (y1,y2,y3,y4) = o in - print_endline ("top or_l: "^x1); - print_endline ("or_l address: "^addr); - print_endline ("top dgen-rule: "^y1); -*) - trans_add_branch r o addr "" ptree dglist (subrel,tsubrel) - -(* Isolate layer and outer recursion structure *) -(* uses weaker layer boundaries: ONLY critical inferences *) - - let rec trans_layer ptree (subrel,tsubrel) = - let rec isol_layer ptree (subrel,tsubrel) = - match ptree with - PEmpty -> raise jprover_bug - | PNodeAx(inf) -> - ptree - | PNodeA((pos,rule,formula,term),left) -> - if List.mem rule [Allr;Impr;Negr] then - let tptree = trans_layer left (subrel,tsubrel) in - PNodeA((pos,rule,formula,term),tptree) - else - let tptree = isol_layer left (subrel,tsubrel) in - PNodeA((pos,rule,formula,term),tptree) - | PNodeB(rule,left,right) -> - let tptree_l = isol_layer left (subrel,tsubrel) - and tptree_r = isol_layer right (subrel,tsubrel) in - PNodeB(rule,tptree_l,tptree_r) - in - begin -(* print_endline "trans_layer in"; *) - let top_tree = isol_layer ptree (subrel,tsubrel) in - let back = permute_layer top_tree [] (subrel,tsubrel) in -(* print_endline "translauer out"; *) - back - end - -(* REAL PERMUTATION STAFF --- End *) - -(* build the proof tree from a list of inference rules *) - - let rec unclosed subtree = - match subtree with - PEmpty -> true - | PNodeAx(y) -> false - | PNodeA(y,left) -> (unclosed left) - | PNodeB(y,left,right) -> (or) (unclosed left) (unclosed right) - - let rec extend prooftree element = - match prooftree with - PEmpty -> - let (pos,rule,formula,term) = element in - if rule = Ax then - PNodeAx(element) - else - if List.mem rule [Andr; Orl; Impl] then - PNodeB(element,PEmpty,PEmpty) - else - PNodeA(element,PEmpty) - | PNodeAx(y) -> - PEmpty (* that's only for exhaustive pattern matching *) - | PNodeA(y, left) -> - PNodeA(y, (extend left element)) - | PNodeB(y, left, right) -> - if (unclosed left) then - PNodeB(y, (extend left element), right) - else - PNodeB(y, left, (extend right element)) - - let rec bptree prooftree nodelist nax= - match nodelist with - [] -> prooftree,nax - | ((_,pos),(rule,formula,term))::rest -> (* kick away the first argument *) - let newax = - if rule = Ax then - 1 - else - 0 - in - bptree (extend prooftree (pos,rule,formula,term)) rest (nax+newax) - - - let bproof nodelist = - bptree PEmpty nodelist 0 - - let rec get_successor_pos treelist = - match treelist with - [] -> [] - | f::r -> - ( - match f with - Empty -> get_successor_pos r - | NodeAt(_) -> raise jprover_bug - | NodeA(pos,_) -> - pos::(get_successor_pos r) - ) - - let rec get_formula_tree ftreelist f predflag = - match ftreelist with - [] -> raise jprover_bug - | ftree::rest_trees -> - (match ftree with - Empty -> get_formula_tree rest_trees f predflag - | NodeAt(_) -> get_formula_tree rest_trees f predflag - | NodeA(pos,suctrees) -> - if predflag = "pred" then - if pos.pt = Gamma then - let succs = get_successor_pos (Array.to_list suctrees) in - if List.mem f succs then - NodeA(pos,suctrees),succs - else - get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag - else - get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag - else (* predflag = "" *) - if pos = f then - NodeA(pos,suctrees),[] - else - get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag - ) - - let rec get_formula_treelist ftree po = - match po with - [] -> [] - | f::r -> -(* a posistion in po has either stype Gamma_0,Psi_0,Phi_0 (non-atomic), or it has *) -(* ptype Alpha (or on the right), since there was a deadlock for proof reconstruction in LJ*) - if List.mem f.st [Phi_0;Psi_0] then - let (stree,_) = get_formula_tree [ftree] f "" in - stree::(get_formula_treelist ftree r) - else - if f.st = Gamma_0 then - let (predtree,succs) = get_formula_tree [ftree] f "pred" in - let new_po = list_diff r succs in - predtree::(get_formula_treelist ftree new_po) - else - if f.pt = Alpha then (* same as first case, or on the right *) - let (stree,_) = get_formula_tree [ftree] f "" in - stree::(get_formula_treelist ftree r) - else raise (Invalid_argument "Jprover bug: non-admissible open position") - - let rec build_formula_rel dir_treelist slist predname = - - let rec build_renamed_gamma_rel dtreelist predname posname d = - match dtreelist with - [] -> [],[] - | (x,ft)::rdtlist -> - let rest_rel,rest_ren = build_renamed_gamma_rel rdtlist predname posname d in - ( - match ft with - Empty -> (* may have empty successors due to purity in former reconstruction steps *) - rest_rel,rest_ren - | NodeAt(_) -> - raise jprover_bug (* gamma_0 position never is atomic *) - | NodeA(spos,suctrees) -> - if List.mem spos.name slist then -(* the gamma_0 position is really unsolved *) -(* this is only relevant for the gamma_0 positions in po *) - let new_name = (posname^"_"^spos.name) (* make new unique gamma name *) in - let new_srel_el = ((predname,new_name),d) - and new_rename_el = (spos.name,new_name) (* gamma_0 position as key first *) in - let (srel,sren) = build_formula_rel [(x,ft)] slist new_name in - ((new_srel_el::srel) @ rest_rel),((new_rename_el::sren) @ rest_ren) - else - rest_rel,rest_ren - ) - - - in - match dir_treelist with - [] -> [],[] - | (d,f)::dir_r -> - let (rest_rel,rest_renlist) = build_formula_rel dir_r slist predname in - match f with - Empty -> - print_endline "Hello, an empty subtree!!!!!!"; - rest_rel,rest_renlist - | NodeAt(pos) -> - (((predname,pos.name),d)::rest_rel),rest_renlist - | NodeA(pos,suctrees) -> - (match pos.pt with - Alpha | Beta -> - let dtreelist = - if (pos.pt = Alpha) & (pos.op = Neg) then - [(1,suctrees.(0))] - else - let st1 = suctrees.(0) - and st2 = suctrees.(1) in - [(1,st1);(2,st2)] - in - let (srel,sren) = build_formula_rel dtreelist slist pos.name in - ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist) - | Delta -> - let st1 = suctrees.(0) in - let (srel,sren) = build_formula_rel [(1,st1)] slist pos.name in - ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist) - | Psi| Phi -> - let succlist = Array.to_list suctrees in - let dtreelist = (List.map (fun x -> (d,x)) succlist) in - let (srel,sren) = build_formula_rel dtreelist slist predname in - (srel @ rest_rel),(sren @ rest_renlist) - | Gamma -> - let succlist = (Array.to_list suctrees) in - let dtreelist = (List.map (fun x -> (1,x)) succlist) in -(* if (nonemptys suctrees 0 n) = 1 then - let (srel,sren) = build_formula_rel dtreelist slist pos.name in - ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist) - else (* we have more than one gamma instance, which means renaming *) -*) - let (srel,sren) = build_renamed_gamma_rel dtreelist predname pos.name d in - (srel @ rest_rel),(sren @ rest_renlist) - | PNull -> - raise jprover_bug - ) - - let rec rename_gamma ljmc_proof rename_list = - match ljmc_proof with - [] -> [] - | ((inst,pos),(rule,formula,term))::r -> - if List.mem rule [Alll;Exr] then - let new_gamma = List.assoc inst rename_list in - ((inst,new_gamma),(rule,formula,term))::(rename_gamma r rename_list) - else - ((inst,pos),(rule,formula,term))::(rename_gamma r rename_list) - - let rec compare_pair (s,sf) list = - if list = [] then - list - else - let (s_1,sf_1),restlist = (List.hd list),(List.tl list) in - if sf = s_1 then - (@) [(s,sf_1)] (compare_pair (s,sf) restlist) - else - compare_pair (s,sf) restlist - - let rec compare_pairlist list1 list2 = - if list1 = [] then - list1 - else - let (s1,sf1),restlist1 = (List.hd list1),(List.tl list1) in - (@) (compare_pair (s1,sf1) list2) (compare_pairlist restlist1 list2) - - let rec trans_rec pairlist translist = - let tlist = compare_pairlist pairlist translist in - if tlist = [] then - translist - else - (@) (trans_rec pairlist tlist) translist - - let transitive_closure subrel = - let pairlist,nlist = List.split subrel in - trans_rec pairlist pairlist - - let pt ptree subrel = - let tsubrel = transitive_closure subrel in - let transptree = trans_layer ptree (subrel,tsubrel) in - print_endline ""; - fst (modify transptree (subrel,tsubrel)) -(* let mtree = fst (modify transptree (subrel,tsubrel)) in *) -(* pretty_print mtree ax *) - - let rec make_node_list ljproof = - match ljproof with - PEmpty -> - raise jprover_bug - | PNodeAx((pos,inf,form,term)) -> - [(("",pos),(inf,form,term))] - | PNodeA((pos,inf,form,term),left) -> - let left_list = make_node_list left in - (("",pos),(inf,form,term))::left_list - | PNodeB((pos,inf,form,term),left,right) -> - let left_list = make_node_list left - and right_list = make_node_list right in - (("",pos),(inf,form,term))::(left_list @ right_list) - - let permute_ljmc ftree po slist ljmc_proof = - (* ftree/po are the formula tree / open positions of the sequent that caused deadlock and permutation *) -(* print_endline "!!!!!!!!!!!!!Permutation TO DO!!!!!!!!!"; *) - (* the open positions in po are either phi_0, psi_0, or gamma_0 positions *) - (* since proof reconstruction was a deadlock in LJ *) - let po_treelist = get_formula_treelist ftree po in - let dir_treelist = List.map (fun x -> (1,x)) po_treelist in - let (formula_rel,rename_list) = build_formula_rel dir_treelist slist "dummy" in - let renamed_ljmc_proof = rename_gamma ljmc_proof rename_list in - let (ptree,ax) = bproof renamed_ljmc_proof in - let ljproof = pt ptree formula_rel in - (* this is a direct formula relation, comprising left/right subformula *) - begin -(* print_treelist po_treelist; *) -(* print_endline ""; - print_endline ""; -*) -(* print_triplelist formula_rel; *) -(* print_endline ""; - print_endline ""; - tt ljproof; -*) -(* print_pairlist rename_list; *) -(* print_endline ""; - print_endline ""; -*) - make_node_list ljproof - end - -(************** PROOF RECONSTRUCTION without redundancy deletion ******************************) - - let rec init_unsolved treelist = - match treelist with - [] -> [] - | f::r -> - begin match f with - Empty -> [] - | NodeAt(pos) -> - (pos.name)::(init_unsolved r) - | NodeA(pos,suctrees) -> - let new_treelist = (Array.to_list suctrees) @ r in - (pos.name)::(init_unsolved new_treelist) - end - -(* only the unsolved positions will be represented --> skip additional root position *) - - let build_unsolved ftree = - match ftree with - Empty | NodeAt _ -> - raise jprover_bug - | NodeA(pos,suctrees) -> - ((pos.name),init_unsolved (Array.to_list suctrees)) - -(* - let rec collect_variables tree_list = - match tree_list with - [] -> [] - | f::r -> - begin match f with - Empty -> [] - | NodeAt(pos) -> - if pos.st = Gamma_0 then - pos.name::collect_variables r - else - collect_variables r - | NodeA(pos,suctrees) -> - let new_tree_list = (Array.to_list suctrees) @ r in - if pos.st = Gamma_0 then - pos.name::collect_variables new_tree_list - else - collect_variables new_tree_list - end - - let rec extend_sigmaQ sigmaQ vlist = - match vlist with - [] -> [] - | f::r -> - let vf = mk_var_term f in - if List.exists (fun x -> (fst x = vf)) sigmaQ then - extend_sigmaQ sigmaQ r - else -(* first and second component are var terms in meta-prl *) - [(vf,vf)] @ (extend_sigmaQ sigmaQ r) - - let build_sigmaQ sigmaQ ftree = - let vlist = collect_variables [ftree] in - sigmaQ @ (extend_sigmaQ sigmaQ vlist) -*) - -(* subformula relation subrel is assumed to be represented in pairs - (a,b) *) - - let rec delete e list = (* e must not necessarily occur in list *) - match list with - [] -> [] (* e must not necessarily occur in list *) - | first::rest -> - if e = first then - rest - else - first::(delete e rest) - - let rec key_delete fname pos_list = (* in key_delete, f is a pos name (key) but sucs is a list of positions *) - match pos_list with - [] -> [] (* the position with name f must not necessarily occur in pos_list *) - | f::r -> - if fname = f.name then - r - else - f::(key_delete fname r) - - let rec get_roots treelist = - match treelist with - [] -> [] - | f::r -> - match f with - Empty -> (get_roots r) (* Empty is posible below alpha-nodes after purity *) - | NodeAt(pos) -> pos::(get_roots r) - | NodeA(pos,trees) -> pos::(get_roots r) - - let rec comp_ps padd ftree = - match ftree with - Empty -> raise (Invalid_argument "Jprover bug: empty formula tree") - | NodeAt(pos) -> - [] - | NodeA(pos,strees) -> - match padd with - [] -> get_roots (Array.to_list strees) - | f::r -> - if r = [] then - pos::(comp_ps r (Array.get strees (f-1))) - else - comp_ps r (Array.get strees (f-1)) - -(* computes a list: first element predecessor, next elements successoes of p *) - - let tpredsucc p ftree = - let padd = p.address in - comp_ps padd ftree - -(* set an element in an array, without side effects *) - - let myset array int element = - let length = Array.length array in - let firstpart = Array.sub array 0 (int) in - let secondpart = Array.sub array (int+1) (length-(int+1)) in - (Array.append firstpart (Array.append [|element|] secondpart)) - - let rec compute_open treelist slist = - match treelist with - [] -> [] - | first::rest -> - let elements = - match first with - Empty -> [] - | NodeAt(pos) -> - if (List.mem (pos.name) slist) then - [pos] - else - [] - | NodeA(pos,suctrees) -> - if (List.mem (pos.name) slist) then - [pos] - else - compute_open (Array.to_list suctrees) slist - in - elements @ (compute_open rest slist) - - let rec select_connection pname connections slist = - match connections with - [] -> ("none","none") - | f::r -> - let partner = - if (fst f) = pname then - (snd f) - else - if (snd f) = pname then - (fst f) - else - "none" - in - if ((partner = "none") or (List.mem partner slist)) then - select_connection pname r slist - else - f - - let rec replace_element element element_set redord = - match redord with - [] -> raise jprover_bug (* element occurs in redord *) - | (f,fset)::r -> - if f = element then - (f,element_set)::r - else - (f,fset)::(replace_element element element_set r) - - let rec collect_succ_sets sucs redord = - match redord with - [] -> StringSet.empty - | (f,fset)::r -> - let new_sucs = key_delete f sucs in - if (List.length sucs) = (List.length new_sucs) then (* position with name f did not occur in sucs -- no deletion *) - (collect_succ_sets sucs r) - else - StringSet.union (StringSet.add f fset) (collect_succ_sets new_sucs r) - - let replace_ordering psucc_name sucs redord = - let new_psucc_set = collect_succ_sets sucs redord in -(* print_string_set new_psucc_set; *) - replace_element psucc_name new_psucc_set redord - - let rec update pname redord = - match redord with - [] -> [] - | (f,fset)::r -> - if pname=f then - r - else - (f,fset)::(update pname r) - -(* rule construction *) - - let rec selectQ_rec spos_var csigmaQ = - match csigmaQ with - [] -> mk_var_term spos_var (* dynamic completion of csigmaQ *) - | (var,term)::r -> - if spos_var=var then - term - else - selectQ_rec spos_var r - - let selectQ spos_name csigmaQ = - let spos_var = spos_name^"_jprover" in - selectQ_rec spos_var csigmaQ - - let apply_sigmaQ term sigmaQ = - let sigma_vars,sigma_terms = List.split sigmaQ in - (subst term sigma_vars sigma_terms) - - let build_rule pos spos csigmaQ orr_flag calculus = - let inst_label = apply_sigmaQ (pos.label) csigmaQ in - match pos.op,pos.pol with - Null,_ -> raise (Invalid_argument "Jprover: no rule") - | At,O -> Ax,(inst_label),xnil_term (* to give back a term *) - | At,I -> Ax,(inst_label),xnil_term - | And,O -> Andr,(inst_label),xnil_term - | And,I -> Andl,(inst_label),xnil_term - | Or,O -> - if calculus = "LJ" then - let or_rule = - if orr_flag = 1 then - Orr1 - else - Orr2 - in - or_rule,(inst_label),xnil_term - else - Orr,(inst_label),xnil_term - | Or,I -> Orl,(inst_label),xnil_term - | Neg,O -> Negr,(inst_label),xnil_term - | Neg,I -> Negl,(inst_label),xnil_term - | Imp,O -> Impr,(inst_label),xnil_term - | Imp,I -> Impl,(inst_label),xnil_term - | All,I -> Alll,(inst_label),(selectQ spos.name csigmaQ) (* elements of csigmaQ is (string * term) *) - | Ex,O -> Exr,(inst_label), (selectQ spos.name csigmaQ) - | All,O -> Allr,(inst_label),(mk_string_term jprover_op spos.name) (* must be a proper term *) - | Ex,I -> Exl,(inst_label),(mk_string_term jprover_op spos.name) (* must be a proper term *) - - -(* %%%%%%%%%%%%%%%%%%%% Split begin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) - - let rec nonemptys treearray j n = - if j = n then - 0 - else - let count = - if (Array.get treearray j) <> Empty then - 1 - else - 0 - in - count + (nonemptys treearray (j+1) n) - - let rec collect_pure ftreelist (flist,slist) = - - let rec collect_itpure ftree (flist,slist) = - match ftree with - Empty -> (* assumed that not all brother trees are Empty *) - [] - | NodeAt(pos) -> (* that may NOT longer be an inner node *) - if ((List.mem (pos.name) flist) or (List.mem (pos.name) slist)) then - [] - else - [pos] - | NodeA(pos,treearray) -> - collect_pure (Array.to_list treearray) (flist,slist) - in - match ftreelist with - [] -> [] - | f::r -> - (collect_itpure f (flist,slist)) @ (collect_pure r (flist,slist)) - - let rec update_list testlist list = - match testlist with - [] -> list - | f::r -> - let newlist = delete f list in (* f may not occur in list; then newlist=list *) - update_list r newlist - - let rec update_pairlist p pairlist = - match pairlist with - [] -> [] - | f::r -> - if ((fst f) = p) or ((snd f) = p) then - update_pairlist p r - else - f::(update_pairlist p r) - - let rec update_connections slist connections = - match slist with - [] -> connections - | f::r -> - let connew = update_pairlist f connections in - update_connections r connew - - let rec update_redord delset redord = (* delset is the set of positions to be deleted *) - match redord with - [] -> [] - | (f,fset)::r -> - if (StringSet.mem f delset) then - update_redord delset r (* delete all key elements f from redord which are in delset *) - else - let new_fset = StringSet.diff fset delset in (* no successor of f from delset should remain in fset *) - (f,new_fset)::(update_redord delset r) - - let rec get_position_names treelist = - match treelist with - [] -> [] - | deltree::rests -> - match deltree with - Empty -> get_position_names rests - | NodeAt(pos) -> - (pos.name)::get_position_names rests - | NodeA(pos,strees) -> - (pos.name)::(get_position_names ((Array.to_list strees) @ rests)) - - let rec slist_to_set slist = - match slist with - [] -> - StringSet.empty - | f::r -> - StringSet.add f (slist_to_set r) - - let rec print_purelist pr = - match pr with - [] -> - begin - print_string "."; - print_endline " "; - end - | f::r -> - print_string ((f.name)^", "); - print_purelist r - - let update_relations deltree redord connections unsolved_list = - let pure_names = get_position_names [deltree] in - begin -(* print_ftree deltree; - Format.open_box 0; - print_endline " "; - print_stringlist pure_names; - Format.force_newline (); - Format.print_flush (); -*) - let rednew = update_redord (slist_to_set pure_names) redord - and connew = update_connections pure_names connections - and unsolnew = update_list pure_names unsolved_list in - (rednew,connew,unsolnew) - end - - let rec collect_qpos ftreelist uslist = - match ftreelist with - [] -> [],[] - | ftree::rest -> - match ftree with - Empty -> - collect_qpos rest uslist - | NodeAt(pos) -> - let (rest_delta,rest_gamma) = collect_qpos rest uslist in - if (pos.st = Gamma_0) & (List.mem pos.name uslist) then - rest_delta,(pos.name::rest_gamma) - else - if (pos.st = Delta_0) & (List.mem pos.name uslist) then - (pos.name::rest_delta),rest_gamma - else - rest_delta,rest_gamma - | NodeA(pos,suctrees) -> - let (rest_delta,rest_gamma) = collect_qpos ((Array.to_list suctrees) @ rest) uslist in - if (pos.st = Gamma_0) & (List.mem pos.name uslist) then - rest_delta,(pos.name::rest_gamma) - else - if (pos.st = Delta_0) & (List.mem pos.name uslist) then - (pos.name::rest_delta),rest_gamma - else - rest_delta,rest_gamma - - let rec do_split gamma_diff sigmaQ = - match sigmaQ with - [] -> [] - | (v,term)::r -> - if (List.mem (String.sub v 0 (String.index v '_')) gamma_diff) then - do_split gamma_diff r - else - (v,term)::(do_split gamma_diff r) - -(* make a term list out of a bterm list *) - - let rec collect_subterms = function - [] -> [] - | bt::r -> - let dbt = dest_bterm bt in - (dbt.bterm)::(collect_subterms r) - - let rec collect_delta_terms = function - [] -> [] - | t::r -> - let dt = dest_term t in - let top = dt.term_op - and tterms = dt.term_terms in - let dop = dest_op top in - let don = dest_opname dop.op_name in - let doa = dest_param dop.op_params in - match don with - [] -> - let sub_terms = collect_subterms tterms in - collect_delta_terms (sub_terms @ r) - | op1::opr -> - if op1 = "jprover" then - match doa with - [] -> raise (Invalid_argument "Jprover: delta position missing") - | String delta::_ -> - delta::(collect_delta_terms r) - | _ -> raise (Invalid_argument "Jprover: delta position error") - else - let sub_terms = collect_subterms tterms in - collect_delta_terms (sub_terms @ r) - - - - let rec check_delta_terms (v,term) ass_delta_diff dterms = - match ass_delta_diff with - [] -> term,[] - | (var,dname)::r -> - if List.mem dname dterms then - let new_var = - if var = "" then - v - else - var - in - let replace_term = mk_string_term jprover_op dname in - let next_term = var_subst term replace_term new_var in - let (new_term,next_diffs) = check_delta_terms (v,next_term) r dterms in - (new_term,((new_var,dname)::next_diffs)) - else - let (new_term,next_diffs) = check_delta_terms (v,term) r dterms in - (new_term,((var,dname)::next_diffs)) - - - let rec localize_sigma zw_sigma ass_delta_diff = - match zw_sigma with - [] -> [] - | (v,term)::r -> - let dterms = collect_delta_terms [term] in - let (new_term,new_ass_delta_diff) = check_delta_terms (v,term) ass_delta_diff dterms in - (v,new_term)::(localize_sigma r new_ass_delta_diff) - - let subst_split ft1 ft2 ftree uslist1 uslist2 uslist sigmaQ = - let delta,gamma = collect_qpos [ftree] uslist - and delta1,gamma1 = collect_qpos [ft1] uslist1 - and delta2,gamma2 = collect_qpos [ft2] uslist2 in - let delta_diff1 = list_diff delta delta1 - and delta_diff2 = list_diff delta delta2 - and gamma_diff1 = list_diff gamma gamma1 - and gamma_diff2 = list_diff gamma gamma2 in - let zw_sigma1 = do_split gamma_diff1 sigmaQ - and zw_sigma2 = do_split gamma_diff2 sigmaQ in - let ass_delta_diff1 = List.map (fun x -> ("",x)) delta_diff1 - and ass_delta_diff2 = List.map (fun x -> ("",x)) delta_diff2 in - let sigmaQ1 = localize_sigma zw_sigma1 ass_delta_diff1 - and sigmaQ2 = localize_sigma zw_sigma2 ass_delta_diff2 in - (sigmaQ1,sigmaQ2) - - let rec reduce_tree addr actual_node ftree beta_flag = - match addr with - [] -> (ftree,Empty,actual_node,beta_flag) - | a::radd -> - match ftree with - Empty -> - print_endline "Empty purity tree"; - raise jprover_bug - | NodeAt(_) -> - print_endline "Atom purity tree"; - raise jprover_bug - | NodeA(pos,strees) -> -(* print_endline pos.name; *) - (* the associated node occurs above f (or the empty address) and hence, is neither atom nor empty tree *) - - let nexttree = (Array.get strees (a-1)) in - if (nonemptys strees 0 (Array.length strees)) < 2 then - begin -(* print_endline "strees 1 or non-empties < 2"; *) - let (ft,dt,an,bf) = reduce_tree radd actual_node nexttree beta_flag in - let nstrees = myset strees (a-1) ft in -(* print_endline ("way back "^pos.name); *) - (NodeA(pos,nstrees),dt,an,bf) - end - else (* nonemptys >= 2 *) - begin -(* print_endline "nonempties >= 2 "; *) - let (new_act,new_bf) = - if pos.pt = Beta then - (actual_node,true) - else - ((pos.name),false) - in - let (ft,dt,an,bf) = reduce_tree radd new_act nexttree new_bf in - if an = pos.name then - let nstrees = myset strees (a-1) Empty in -(* print_endline ("way back assocnode "^pos.name); *) - (NodeA(pos,nstrees),nexttree,an,bf) - else (* has been replaced / will be replaced below / above pos *) - let nstrees = myset strees (a-1) ft in -(* print_endline ("way back "^pos.name); *) - (NodeA(pos,nstrees),dt,an,bf) - end - - let rec purity ftree redord connections unsolved_list = - - let rec purity_reduction pr ftree redord connections unsolved_list = - begin -(* Format.open_box 0; - print_endline " "; - print_purelist pr; - Format.force_newline (); - Format.print_flush (); -*) - match pr with - [] -> (ftree,redord,connections,unsolved_list) - | f::r -> -(* print_endline ("pure position "^(f.name)); *) - let (ftnew,deltree,assocn,beta_flag) = reduce_tree f.address "" ftree false - in -(* print_endline ("assoc node "^assocn); *) - if assocn = "" then - (Empty,[],[],[]) (* should not occur in the final version *) - else - let (rednew,connew,unsolnew) = update_relations deltree redord connections unsolved_list in - begin -(* Format.open_box 0; - print_endline " "; - print_pairlist connew; - Format.force_newline (); - Format.print_flush (); -*) - if beta_flag = true then - begin -(* print_endline "beta_flag true"; *) - purity ftnew rednew connew unsolnew - (* new pure positions may occur; old ones may not longer exist *) - end - else - purity_reduction r ftnew rednew connew unsolnew (* let's finish the old pure positions *) - end - end - - in - let flist,slist = List.split connections in - let pr = collect_pure [ftree] (flist,slist) in - purity_reduction pr ftree redord connections unsolved_list - - let rec betasplit addr ftree redord connections unsolved_list = - match ftree with - Empty -> - print_endline "bsplit Empty tree"; - raise jprover_bug - | NodeAt(_) -> - print_endline "bsplit Atom tree"; - raise jprover_bug (* the beta-node should actually occur! *) - | NodeA(pos,strees) -> - match addr with - [] -> (* we are at the beta node under consideration *) - let st1tree = (Array.get strees 0) - and st2tree = (Array.get strees 1) in - let (zw1red,zw1conn,zw1uslist) = update_relations st2tree redord connections unsolved_list - and (zw2red,zw2conn,zw2uslist) = update_relations st1tree redord connections unsolved_list in - ((NodeA(pos,[|st1tree;Empty|])),zw1red,zw1conn,zw1uslist), - ((NodeA(pos,[|Empty;st2tree|])),zw2red,zw2conn,zw2uslist) - | f::rest -> - let nexttree = Array.get strees (f-1) in - let (zw1ft,zw1red,zw1conn,zw1uslist),(zw2ft,zw2red,zw2conn,zw2uslist) = - betasplit rest nexttree redord connections unsolved_list in -(* let scopytrees = Array.copy strees in *) - let zw1trees = myset strees (f-1) zw1ft - and zw2trees = myset strees (f-1) zw2ft in - (NodeA(pos,zw1trees),zw1red,zw1conn,zw1uslist),(NodeA(pos,zw2trees),zw2red,zw2conn,zw2uslist) - - - - - let split addr pname ftree redord connections unsolved_list opt_bproof = - let (opt_bp1,min_con1),(opt_bp2,min_con2) = split_permutation pname opt_bproof in - begin -(* - print_endline "Beta proof 1: "; - print_endline ""; - print_beta_proof opt_bp1; - print_endline ""; - print_endline ("Beta proof 1 connections: "); - Format.open_box 0; - print_pairlist min_con1; - print_endline "."; - Format.print_flush(); - print_endline ""; - print_endline ""; - print_endline "Beta proof 2: "; - print_endline ""; - print_beta_proof opt_bp2; - print_endline ""; - print_endline ("Beta proof 2 connections: "); - Format.open_box 0; - print_pairlist min_con2; - print_endline "."; - Format.print_flush(); - print_endline ""; -*) - let (zw1ft,zw1red,zw1conn,zw1uslist),(zw2ft,zw2red,zw2conn,zw2uslist) = - betasplit addr ftree redord connections unsolved_list in -(* zw1conn and zw2conn are not longer needed when using beta proofs *) -(* print_endline "betasp_out"; *) - let ft1,red1,conn1,uslist1 = purity zw1ft zw1red min_con1 zw1uslist in -(* print_endline "purity_one_out"; *) - let ft2,red2,conn2,uslist2 = purity zw2ft zw2red min_con2 zw2uslist in -(* print_endline "purity_two_out"; *) -(* again, min_con1 = conn1 and min_con2 = conn2 should hold *) - begin -(* print_endline ""; - print_endline ""; - print_endline ("Purity 1 connections: "); - Format.open_box 0; - print_pairlist conn1; - print_endline "."; - print_endline ""; - Format.print_flush(); - print_endline ""; - print_endline ""; - print_endline ("Purity 2 connections: "); - Format.open_box 0; - print_pairlist conn2; - print_endline "."; - print_endline ""; - Format.print_flush(); - print_endline ""; - print_endline ""; -*) - (ft1,red1,conn1,uslist1,opt_bp1),(ft2,red2,conn2,uslist2,opt_bp2) - end - end - - -(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Splitting end %%%%%%%%%%%%%%%% *) - - -(* for wait labels we collect all solved atoms with pol=0 *) - - let rec collect_solved_O_At ftreelist slist = - match ftreelist with - [] -> - [] - | f::r -> - match f with - Empty -> (* may become possible after purity *) - collect_solved_O_At r slist - | NodeAt(pos) -> - if ((List.mem (pos.name) slist) or (pos.pol = I)) then (* recall slist is the unsolved list *) - collect_solved_O_At r slist - else - (* here, we have pos solved and pos.pol = O) *) - pos::(collect_solved_O_At r slist) - | NodeA(pos,treearray) -> - collect_solved_O_At ((Array.to_list treearray) @ r) slist - - let rec red_ord_block pname redord = - match redord with - [] -> false - | (f,fset)::r -> - if ((f = pname) or (not (StringSet.mem pname fset))) then - red_ord_block pname r - else - true (* then, we have (StringSet.mem pname fset) *) - - let rec check_wait_succ_LJ faddress ftree = - match ftree with - Empty -> raise jprover_bug - | NodeAt(pos) -> raise jprover_bug (* we have an gamma_0 position or an or-formula *) - | NodeA(pos,strees) -> - match faddress with - [] -> - if pos.op = Or then - match (strees.(0),strees.(1)) with - (Empty,Empty) -> raise (Invalid_argument "Jprover: redundancies occur") - | (Empty,_) -> (false,2) (* determines the Orr2 rule *) - | (_,Empty) -> (false,1) (* determines the Orr1 ruke *) - | (_,_) -> (true,0) (* wait-label is set *) - else - (false,0) - | f::r -> - if r = [] then - if (pos.pt = Gamma) & ((nonemptys strees 0 (Array.length strees)) > 1) then - (true,0) (* we are at a gamma position (exr) with one than one successor -- wait label in LJ*) - else - check_wait_succ_LJ r (Array.get strees (f-1)) - else - check_wait_succ_LJ r (Array.get strees (f-1)) - - let blocked f po redord ftree connections slist logic calculus opt_bproof = -(* print_endline ("Blocking check "^(f.name)); *) - if (red_ord_block (f.name) redord) then - begin -(* print_endline "wait-1 check positive"; *) - true,0 - end - else - if logic = "C" then - false,0 (* ready, in C only redord counts *) - else - let pa_O = collect_solved_O_At [ftree] slist (* solved atoms in ftree *) - and po_test = (delete f po) in - if calculus = "LJmc" then (* we provide dynamic wait labels for both sequent calculi *) -(* print_endline "wait-2 check"; *) - if (f.st = Psi_0) & (f.pt <> PNull) & - ((pa_O <> []) or (List.exists (fun x -> x.pol = O) po_test)) then - begin -(* print_endline "wait-2 positive"; *) - true,0 (* wait_2 label *) - end - else - begin -(* print_endline "wait-2 negative"; *) - false,0 - end - else (* calculus is supposed to be LJ *) - if calculus = "LJ" then - if ((f.st = Phi_0) & ((f.op=Neg) or (f.op=Imp)) & - ((pa_O <> []) or (List.exists (fun x -> x.pol = O) po_test)) - ) - (* this would cause an impl or negl rule with an non-empty succedent *) - then - if (f.op=Neg) then - true,0 - else (* (f.op=Imp) *) - (* In case of an impl rule on A => B, the wait_label must NOT be set - iff all succedent formulae depend exclusively on B. For this, we - perform a split operation and determine, if in the A-subgoal - all succedent formulae are pure, i.e.~have been deleted from treds. - Otherwise, in case of A-dependent succedent formulae, the - wait_label must be set. - *) - let ((_,min_con1),_) = split_permutation f.name opt_bproof in - let slist_fake = delete f.name slist in - let ((zw1ft,zw1red,_,zw1uslist),_) = - betasplit (f.address) ftree redord connections slist_fake in - let ft1,_,_,uslist1 = purity zw1ft zw1red min_con1 zw1uslist in -(* print_endline "wait label purity_one_out"; *) - let ft1_root = (List.hd (List.tl (tpredsucc f ft1))) in -(* print_endline ("wait-root "^(ft1_root.name)); *) - let po_fake = compute_open [ft1] uslist1 in - let po_fake_test = delete ft1_root po_fake - and pa_O_fake = collect_solved_O_At [ft1] uslist1 in -(* print_purelist (po_fake_test @ pa_O_fake); *) - if ((pa_O_fake <> []) or (List.exists (fun x -> x.pol = O) po_fake_test)) then - true,0 - else - false,0 - else - if ((f.pol=O) & ((f.st=Gamma_0) or (f.op=Or))) then - let (bool,orr_flag) = check_wait_succ_LJ f.address ftree in - (bool,orr_flag) - (* here is determined if orr1 or orr2 will be performed, provided bool=false) *) - (* orr_flag can be 1 or 2 *) - else - false,0 - else - raise (Invalid_argument "Jprover: calculus should be LJmc or LJ") - - let rec get_beta_preference list actual = - match list with - [] -> actual - | (f,int)::r -> - if f.op = Imp then - (f,int) - else -(* if f.op = Or then - get_beta_preference r (f,int) - else -*) - get_beta_preference r actual - - exception Gamma_deadlock - - let rec select_pos search_po po redord ftree connections slist logic calculus candidates - opt_bproof = - match search_po with - [] -> - (match candidates with - [] -> - if calculus = "LJ" then - raise Gamma_deadlock (* permutation may be necessary *) - else - raise (Invalid_argument "Jprover bug: overall deadlock") (* this case should not occur *) - | c::rest -> - get_beta_preference (c::rest) c - ) - | f::r -> (* there exist an open position *) - let (bool,orr_flag) = (blocked f po redord ftree connections slist logic calculus - opt_bproof) - in - if (bool = true) then - select_pos r po redord ftree connections slist logic calculus candidates opt_bproof - else - if f.pt = Beta then - (* search for non-splitting rules first *) -(* let beta_candidate = - if candidates = [] - then - [(f,orr_flag)] - else - !!!! but preserve first found candidate !!!!!!! - candidates - in - !!!!!!! this strategy is not sure the best -- back to old !!!!!!!!! -*) - select_pos r po redord ftree connections slist logic calculus - ((f,orr_flag)::candidates) opt_bproof - else - (f,orr_flag) - -(* let rec get_position_in_tree pname treelist = - match treelist with - [] -> raise jprover_bug - | f::r -> - begin match f with - Empty -> get_position_in_tree pname r - | NodeAt(pos) -> - if pos.name = pname then - pos - else - get_position_in_tree pname r - | NodeA(pos,suctrees) -> - get_position_in_tree pname ((Array.to_list suctrees) @ r) - end -*) - -(* total corresponds to tot in the thesis, - tot simulates the while-loop, solve is the rest *) - - let rec total ftree redord connections csigmaQ slist logic calculus opt_bproof = - let rec tot ftree redord connections po slist = - let rec solve ftree redord connections p po slist (pred,succs) orr_flag = - let newslist = delete (p.name) slist in - let rback = - if p.st = Gamma_0 then - begin -(* print_endline "that's the gamma rule"; *) - [((p.name,pred.name),(build_rule pred p csigmaQ orr_flag calculus))] - end - else - [] - in -(* print_endline "gamma check finish"; *) - let pnew = - if p.pt <> Beta then - succs @ (delete p po) - else - po - in - match p.pt with - Gamma -> - rback @ (tot ftree redord connections pnew newslist) - | Psi -> - if p.op = At then - let succ = List.hd succs in - rback @ (solve ftree redord connections succ pnew newslist (p,[]) orr_flag) (* solve atoms immediately *) - else - rback @ (tot ftree redord connections pnew newslist) - | Phi -> - if p.op = At then - let succ = List.hd succs in - rback @ (solve ftree redord connections succ pnew newslist (p,[]) orr_flag) (* solve atoms immediately *) - else - rback @ (tot ftree redord connections pnew newslist) - | PNull -> - let new_redord = update p.name redord in - let (c1,c2) = select_connection (p.name) connections newslist in - if (c1= "none" & c2 ="none") then - rback @ (tot ftree new_redord connections pnew newslist) - else - let (ass_pos,inst_pos) = -(* need the pol=O position ass_pos of the connection for later permutation *) -(* need the pol=I position inst_pos for NuPRL instantiation *) - if p.name = c1 then - if p.pol = O then - (c1,c2) - else - (c2,c1) - else (* p.name = c2 *) - if p.pol = O then - (c2,c1) - else - (c1,c2) - in - rback @ [(("",ass_pos),(build_rule p p csigmaQ orr_flag calculus))] - (* one possibility of recursion end *) - | Alpha -> - rback @ ((("",p.name),(build_rule p p csigmaQ orr_flag calculus))::(tot ftree redord connections pnew newslist)) - | Delta -> - let sp = List.hd succs in - rback @ ((("",p.name),(build_rule p sp csigmaQ orr_flag calculus))::(tot ftree redord connections pnew newslist)) - | Beta -> -(* print_endline "split_in"; *) - let (ft1,red1,conn1,uslist1,opt_bproof1),(ft2,red2,conn2,uslist2,opt_bproof2) = - split (p.address) (p.name) ftree redord connections newslist opt_bproof in - let (sigmaQ1,sigmaQ2) = subst_split ft1 ft2 ftree uslist1 uslist2 newslist csigmaQ in -(* print_endline "split_out"; *) - let p1 = total ft1 red1 conn1 sigmaQ1 uslist1 logic calculus opt_bproof1 in -(* print_endline "compute p1 out"; *) - let p2 = total ft2 red2 conn2 sigmaQ2 uslist2 logic calculus opt_bproof2 in -(* print_endline "compute p2 out"; *) - rback @ [(("",p.name),(build_rule p p csigmaQ orr_flag calculus))] @ p1 @ p2 (* second possibility of recursion end *) - in - begin try - let (p,orr_flag) = select_pos po po redord ftree connections slist logic - calculus [] opt_bproof - (* last argument for guiding selection strategy *) - in -(* print_endline ((p.name)^" "^(string_of_int orr_flag)); *) - let predsuccs = tpredsucc p ftree in - let pred = List.hd predsuccs - and succs = List.tl predsuccs in - let redpo = update (p.name) redord in (* deletes the entry (p,psuccset) from the redord *) - let rednew = - if (p.pt = Delta) then (* keep the tree ordering for the successor position only *) - let psucc = List.hd succs in - let ppsuccs = tpredsucc psucc ftree in - let sucs = List.tl ppsuccs in - replace_ordering (psucc.name) sucs redpo (* union the succsets of psucc *) - else - redpo - in -(* print_endline "update ok"; *) - solve ftree rednew connections p po slist (pred,succs) orr_flag - with Gamma_deadlock -> - let ljmc_subproof = total ftree redord connections csigmaQ slist "J" "LJmc" opt_bproof - in - eigen_counter := 1; - permute_ljmc ftree po slist ljmc_subproof - (* the permuaiton result will be appended to the lj proof constructed so far *) - end - in - let po = compute_open [ftree] slist in - tot ftree redord connections po slist - - let reconstruct ftree redord sigmaQ ext_proof logic calculus = - let min_connections = remove_dups_connections ext_proof in - let (opt_bproof,beta_exp,closures) = construct_opt_beta_proof ftree ext_proof in -(* let connections = remove_dups_connections ext_proof in - let bproof,beta_exp,closures = construct_beta_proof ftree connections in - let (opt_bproof,min_connections) = bproof_purity bproof in -*) - if !debug_jprover then - begin - print_endline ""; - print_endline ("Beta proof with number of closures = "^(string_of_int closures)^" and number of beta expansions = "^(string_of_int beta_exp)); -(* print_endline ""; - print_endline ""; - print_beta_proof bproof; - print_endline ""; - print_endline ""; - print_endline "Optimal beta proof: "; - print_endline ""; - print_endline ""; - print_beta_proof opt_bproof; - print_endline ""; - print_endline ""; - print_endline ("Beta proof connections: "); - Format.open_box 0; - print_pairlist min_connections; - print_endline "."; - Format.print_flush(); *) - print_endline ""; - end; - let (newroot_name,unsolved_list) = build_unsolved ftree in - let redord2 = (update newroot_name redord) in (* otherwise we would have a deadlock *) - let (init_tree,init_redord,init_connections,init_unsolved_list) = - purity ftree redord2 min_connections unsolved_list in - begin -(* print_endline ""; - print_endline ""; - print_endline ("Purity connections: "); - Format.open_box 0; - print_pairlist init_connections; - print_endline "."; - print_endline ""; - Format.print_flush(); - print_endline ""; - print_endline ""; -*) -(* it should hold: min_connections = init_connections *) - total init_tree init_redord init_connections sigmaQ - init_unsolved_list logic calculus opt_bproof - end - -(* ***************** REDUCTION ORDERING -- both types **************************** *) - - exception Reflexive - - let rec transitive_irreflexive_closure addset const ordering = - match ordering with - [] -> - [] - | (pos,fset)::r -> - if (pos = const) or (StringSet.mem const fset) then -(* check reflexsivity during transitive closure wrt. addset ONLY!!! *) - if StringSet.mem pos addset then - raise Reflexive - else - (pos,(StringSet.union fset addset))::(transitive_irreflexive_closure addset const r) - else - (pos,fset)::(transitive_irreflexive_closure addset const r) - - let rec search_set var ordering = -(* print_endline var; *) - match ordering with - [] -> - raise (Invalid_argument "Jprover: element in ordering missing") - | (pos,fset)::r -> - if pos = var then - StringSet.add pos fset - else - search_set var r - - let add_sets var const ordering = - let addset = search_set var ordering in - transitive_irreflexive_closure addset const ordering - -(* ************* J ordering ********************************************** *) - - let rec add_arrowsJ (v,vlist) ordering = - match vlist with - [] -> ordering - | f::r -> - if ((String.get f 0)='c') then - let new_ordering = add_sets v f ordering in - add_arrowsJ (v,r) new_ordering - else - add_arrowsJ (v,r) ordering - - let rec add_substJ replace_vars replace_string ordering atom_rel = - match replace_vars with - [] -> ordering - | v::r -> - if (String.get v 1 = 'n') (* don't integrate new variables *) - or (List.exists (fun (x,_,_) -> (x.aname = v)) atom_rel) then (* no reduction ordering at atoms *) - (add_substJ r replace_string ordering atom_rel) - else - let next_ordering = add_arrowsJ (v,replace_string) ordering in - (add_substJ r replace_string next_ordering atom_rel) - - let build_orderingJ replace_vars replace_string ordering atom_rel = - try - add_substJ replace_vars replace_string ordering atom_rel - with Reflexive -> (* only possible in the FO case *) - raise Not_unifiable (*search for alternative string unifiers *) - - let rec build_orderingJ_list substJ ordering atom_rel = - match substJ with - [] -> ordering - | (v,vlist)::r -> - let next_ordering = build_orderingJ [v] vlist ordering atom_rel in - build_orderingJ_list r next_ordering atom_rel - -(* ************* J ordering END ********************************************** *) - -(* ************* quantifier ordering ********************************************** *) - - let rec add_arrowsQ v clist ordering = - match clist with - [] -> ordering - | f::r -> - let new_ordering = add_sets v f ordering in - add_arrowsQ v r new_ordering - - let rec print_sigmaQ sigmaQ = - match sigmaQ with - [] -> - print_endline "." - | (v,term)::r -> - begin - Format.open_box 0; - print_endline " "; - print_string (v^" = "); - print_term stdout term; - Format.force_newline (); - Format.print_flush (); - print_sigmaQ r - end - - let rec print_term_list tlist = - match tlist with - [] -> print_string "." - | t::r -> - begin - print_term stdout t; - print_string " "; - print_term_list r - end - - let rec add_sigmaQ new_elements ordering = - match new_elements with - [] -> ([],ordering) - | (v,termlist)::r -> - let dterms = collect_delta_terms termlist in - begin - let new_ordering = add_arrowsQ v dterms ordering in - let (rest_pairs,rest_ordering) = add_sigmaQ r new_ordering in - ((v,dterms)::rest_pairs),rest_ordering - end - - let build_orderingQ new_elements ordering = -(* new_elements is of type (string * term list) list, since one variable can receive more than *) -(* a single term due to substitution multiplication *) - try -(* print_endline "build orderingQ in"; *) (* apple *) - add_sigmaQ new_elements ordering; - with Reflexive -> - raise Failed (* new connection, please *) - - -(* ************* quantifier ordering END ********************************************** *) - -(* ****** Quantifier unification ************** *) - -(* For multiplication we assume always idempotent substitutions sigma, tau! *) - - let rec collect_assoc inst_vars tauQ = - match inst_vars with - [] -> [] - | f::r -> - let f_term = List.assoc f tauQ in - f_term::(collect_assoc r tauQ) - - let rec rec_apply sigmaQ tauQ tau_vars tau_terms = - match sigmaQ with - [] -> [],[] - | (v,term)::r -> - let app_term = subst term tau_vars tau_terms in - let old_free = free_vars_list term - and new_free = free_vars_list app_term in - let inst_vars = list_diff old_free new_free in - let inst_terms = collect_assoc inst_vars tauQ in - let (rest_sigma,rest_sigma_ordering) = rec_apply r tauQ tau_vars tau_terms in - if inst_terms = [] then - ((v,app_term)::rest_sigma),rest_sigma_ordering - else - let ordering_v = String.sub v 0 (String.index v '_') in - ((v,app_term)::rest_sigma),((ordering_v,inst_terms)::rest_sigma_ordering) - -(* let multiply sigmaQ tauQ = - let tau_vars,tau_terms = List.split tauQ - and sigma_vars,sigma_terms = List.split sigmaQ in - let apply_terms = rec_apply sigma_terms tau_vars tau_terms in - (List.combine sigma_vars apply_terms) @ tauQ -*) - - let multiply sigmaQ tauQ = - let (tau_vars,tau_terms) = List.split tauQ in - let (new_sigmaQ,sigma_ordering) = rec_apply sigmaQ tauQ tau_vars tau_terms in - let tau_ordering_terms = (List.map (fun x -> [x]) tau_terms) (* for extending ordering_elements *) in - let tau_ordering_vars = (List.map (fun x -> String.sub x 0 (String.index x '_')) tau_vars) in - let tau_ordering = (List.combine tau_ordering_vars tau_ordering_terms) in - ((new_sigmaQ @ tauQ), - (sigma_ordering @ tau_ordering) - ) - - let apply_2_sigmaQ term1 term2 sigmaQ = - let sigma_vars,sigma_terms = List.split sigmaQ in - (subst term1 sigma_vars sigma_terms),(subst term2 sigma_vars sigma_terms) - - let jqunify term1 term2 sigmaQ = - let app_term1,app_term2 = apply_2_sigmaQ term1 term2 sigmaQ in - try - let tauQ = unify_mm app_term1 app_term2 StringSet.empty in - let (mult,oel) = multiply sigmaQ tauQ in - (mult,oel) - with - RefineError _ -> (* any unification failure *) -(* print_endline "fo-unification fail"; *) - raise Failed (* new connection, please *) - -(* ************ T-STRING UNIFICATION ******************************** *) - - let rec combine subst (ov,oslist) = - match subst with - [] -> [],[] - | f::r -> - let (v,slist) = f in - let rest_vlist,rest_combine = (combine r (ov,oslist)) in - if (List.mem ov slist) then (* subst assumed to be idemponent *) - let com_element = com_subst slist (ov,oslist) in - (v::rest_vlist),((v,com_element)::rest_combine) - else - (rest_vlist,(f::rest_combine)) - - let compose sigma one_subst = - let (n,subst)=sigma - and (ov,oslist) = one_subst in - let (trans_vars,com) = combine subst (ov,oslist) - in -(* begin - print_endline "!!!!!!!!!test print!!!!!!!!!!"; - print_subst [one_subst]; - print_subst subst; - print_endline "!!!!!!!!! END test print!!!!!!!!!!"; -*) - if List.mem one_subst subst then - (trans_vars,(n,com)) - else -(* ov may multiply as variable in subst with DIFFERENT values *) -(* in order to avoid explicit atom instances!!! *) - (trans_vars,(n,(com @ [one_subst]))) -(* end *) - - let rec apply_element fs ft (v,slist) = - match (fs,ft) with - ([],[]) -> - ([],[]) - | ([],(ft_first::ft_rest)) -> - let new_ft_first = - if ft_first = v then - slist - else - [ft_first] - in - let (emptylist,new_ft_rest) = apply_element [] ft_rest (v,slist) in - (emptylist,(new_ft_first @ new_ft_rest)) - | ((fs_first::fs_rest),[]) -> - let new_fs_first = - if fs_first = v then - slist - else - [fs_first] - in - let (new_fs_rest,emptylist) = apply_element fs_rest [] (v,slist) in - ((new_fs_first @ new_fs_rest),emptylist) - | ((fs_first::fs_rest),(ft_first::ft_rest)) -> - let new_fs_first = - if fs_first = v then - slist - else - [fs_first] - and new_ft_first = - if ft_first = v then - slist - else - [ft_first] - in - let (new_fs_rest,new_ft_rest) = apply_element fs_rest ft_rest (v,slist) in - ((new_fs_first @ new_fs_rest),(new_ft_first @ new_ft_rest)) - - let rec shorten us ut = - match (us,ut) with - ([],_) -> (us,ut) - | (_,[]) -> (us,ut) - | ((fs::rs),(ft::rt)) -> - if fs = ft then - shorten rs rt - else - (us,ut) - - let rec apply_subst_list eq_rest (v,slist) = - - match eq_rest with - [] -> - (true,[]) - | (atomnames,(fs,ft))::r -> - let (n_fs,n_ft) = apply_element fs ft (v,slist) in - let (new_fs,new_ft) = shorten n_fs n_ft in (* delete equal first elements *) - match (new_fs,new_ft) with - [],[] -> - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,([],[]))::new_eq_rest)) - | [],(fft::rft) -> - if (is_const fft) then - (false,[]) - else - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,([],new_ft))::new_eq_rest)) - | (ffs::rfs),[] -> - if (is_const ffs) then - (false,[]) - else - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,(new_fs,[]))::new_eq_rest)) - | (ffs::rfs),(fft::rft) -> - if (is_const ffs) & (is_const fft) then - (false,[]) - (* different first constants cause local fail *) - else - (* at least one of firsts is a variable *) - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,(new_fs,new_ft))::new_eq_rest)) - - let apply_subst eq_rest (v,slist) atomnames = - if (List.mem v atomnames) then (* don't apply subst to atom variables !! *) - (true,eq_rest) - else - apply_subst_list eq_rest (v,slist) - - let all_variable_check eqlist = false (* needs some discussion with Jens! -- NOT done *) - -(* - let rec all_variable_check eqlist = - match eqlist with - [] -> true - | ((_,(fs,ft))::rest_eq) -> - if (fs <> []) & (ft <> []) then - let fs_first = List.hd fs - and ft_first = List.hd ft - in - if (is_const fs_first) or (is_const ft_first) then - false - else - all_variable_check rest_eq - else - false -*) - - let rec tunify_list eqlist init_sigma orderingQ atom_rel = - - let rec tunify atomnames fs ft rt rest_eq sigma ordering = - - let apply_r1 fs ft rt rest_eq sigma = -(* print_endline "r1"; *) - tunify_list rest_eq sigma ordering atom_rel - - in - let apply_r2 fs ft rt rest_eq sigma = -(* print_endline "r2"; *) - tunify atomnames rt fs ft rest_eq sigma ordering - - in - let apply_r3 fs ft rt rest_eq sigma = -(* print_endline "r3"; *) - let rfs = (List.tl fs) - and rft = (List.tl rt) in - tunify atomnames rfs ft rft rest_eq sigma ordering - - in - let apply_r4 fs ft rt rest_eq sigma = -(* print_endline "r4"; *) - tunify atomnames rt ft fs rest_eq sigma ordering - - in - let apply_r5 fs ft rt rest_eq sigma = -(* print_endline "r5"; *) - let v = (List.hd fs) in - let (compose_vars,new_sigma) = compose sigma (v,ft) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,ft) atomnames in - if (bool=false) then - raise Not_unifiable - else - let new_ordering = build_orderingJ (v::compose_vars) ft ordering atom_rel in - tunify atomnames (List.tl fs) rt rt new_rest_eq new_sigma new_ordering - - in - let apply_r6 fs ft rt rest_eq sigma = -(* print_endline "r6"; *) - let v = (List.hd fs) in - let (_,new_sigma) = (compose sigma (v,[])) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,[]) atomnames in - if (bool=false) then - raise Not_unifiable - else - (* no relation update since [] has been replaced for v *) - tunify atomnames (List.tl fs) ft rt new_rest_eq new_sigma ordering - - in - let apply_r7 fs ft rt rest_eq sigma = -(* print_endline "r7"; *) - let v = (List.hd fs) - and c1 = (List.hd rt) - and c2t =(List.tl rt) in - let (compose_vars,new_sigma) = (compose sigma (v,(ft @ [c1]))) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [c1])) atomnames in - if bool=false then - raise Not_unifiable - else - let new_ordering = build_orderingJ (v::compose_vars) (ft @ [c1]) ordering atom_rel in - tunify atomnames (List.tl fs) [] c2t new_rest_eq new_sigma new_ordering - - - in - let apply_r8 fs ft rt rest_eq sigma = -(* print_endline "r8"; *) - tunify atomnames rt [(List.hd fs)] (List.tl fs) rest_eq sigma ordering - - in - let apply_r9 fs ft rt rest_eq sigma = -(* print_endline "r9"; *) - let v = (List.hd fs) - and (max,subst) = sigma in - let v_new = ("vnew"^(string_of_int max)) in - let (compose_vars,new_sigma) = (compose ((max+1),subst) (v,(ft @ [v_new]))) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [v_new])) atomnames in - if (bool=false) then - raise Not_unifiable - else - let new_ordering = - build_orderingJ (v::compose_vars) (ft @ [v_new]) ordering atom_rel in - tunify atomnames rt [v_new] (List.tl fs) new_rest_eq new_sigma new_ordering - - in - let apply_r10 fs ft rt rest_eq sigma = -(* print_endline "r10"; *) - let x = List.hd rt in - tunify atomnames fs (ft @ [x]) (List.tl rt) rest_eq sigma ordering - - in - if r_1 fs ft rt then - apply_r1 fs ft rt rest_eq sigma - else if r_2 fs ft rt then - apply_r2 fs ft rt rest_eq sigma - else if r_3 fs ft rt then - apply_r3 fs ft rt rest_eq sigma - else if r_4 fs ft rt then - apply_r4 fs ft rt rest_eq sigma - else if r_5 fs ft rt then - apply_r5 fs ft rt rest_eq sigma - else if r_6 fs ft rt then - (try - apply_r6 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_7 fs ft rt then (* r7 applicable if r6 was and tr6 = C2t' *) - (try - apply_r7 fs ft rt rest_eq sigma - with Not_unifiable -> - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r6 was *) - ) - else -(* r10 could be represented only once if we would try it before r7.*) -(* but looking at the transformation rules, r10 should be tried at last in any case *) - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable r6 was *) - ) - else if r_7 fs ft rt then (* not r6 and r7 possible if z <> [] *) - (try - apply_r7 fs ft rt rest_eq sigma - with Not_unifiable -> - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r7 was *) - ) - else if r_8 fs ft rt then - (try - apply_r8 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_10 fs ft rt then (* r10 applicable if r8 was and tr8 <> [] *) - apply_r10 fs ft rt rest_eq sigma - else - raise Not_unifiable (* simply back propagation *) - ) - else if r_9 fs ft rt then - (try - apply_r9 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_10 fs ft rt then (* r10 applicable if r9 was and tr9 <> [] *) - apply_r10 fs ft rt rest_eq sigma - else - raise Not_unifiable (* simply back propagation *) - ) - - - else - if r_10 fs ft rt then (* not ri, i<10, and r10 possible if for instance *) - (* (s=[] and x=v1) or (z<>[] and xt=C1V1t') *) - apply_r10 fs ft rt rest_eq sigma - else (* NO rule applicable *) - raise Not_unifiable - in - match eqlist with - [] -> - init_sigma,orderingQ - | f::rest_eq -> - begin -(* Format.open_box 0; - print_equations [f]; - Format.print_flush (); -*) - let (atomnames,(fs,ft)) = f in - tunify atomnames fs [] ft rest_eq init_sigma orderingQ - end - -let rec test_apply_eq atomnames eqs eqt subst = - match subst with - [] -> (eqs,eqt) - | (f,flist)::r -> - let (first_appl_eqs,first_appl_eqt) = - if List.mem f atomnames then - (eqs,eqt) - else - (apply_element eqs eqt (f,flist)) - in - test_apply_eq atomnames first_appl_eqs first_appl_eqt r - -let rec test_apply_eqsubst eqlist subst = - match eqlist with - [] -> [] - | f::r -> - let (atomnames,(eqs,eqt)) = f in - let applied_element = test_apply_eq atomnames eqs eqt subst in - (atomnames,applied_element)::(test_apply_eqsubst r subst) - -let ttest us ut ns nt eqlist orderingQ atom_rel = - let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 *) - (* to eliminate common beginning *) - let new_element = ([ns;nt],(short_us,short_ut)) in - let full_eqlist = - if List.mem new_element eqlist then - eqlist - else - new_element::eqlist - in - let (sigma,_) = tunify_list full_eqlist (1,[]) orderingQ atom_rel in - let (n,subst) = sigma in - let test_apply = test_apply_eqsubst full_eqlist subst in - begin - print_endline ""; - print_endline "Final equations:"; - print_equations full_eqlist; - print_endline ""; - print_endline "Final substitution:"; - print_tunify sigma; - print_endline ""; - print_endline "Applied equations:"; - print_equations test_apply - end - -let do_stringunify us ut ns nt equations fo_eqlist orderingQ atom_rel qmax = - let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 to eliminate common beginning *) - let new_element = ([ns;nt],(short_us,short_ut)) in - let full_eqlist = - if List.mem new_element equations then - equations @ fo_eqlist - else - (new_element::equations) @ fo_eqlist - in - try -(* print_equations full_eqlist; *) -(* max-1 new variables have been used for the domain equations *) - let (new_sigma,new_ordering) = tunify_list full_eqlist (1,[]) orderingQ atom_rel in -(* sigmaQ will not be returned in eqlist *) - (new_sigma,(qmax,full_eqlist),new_ordering) - with Not_unifiable -> - raise Failed (* new connection please *) - -let rec one_equation gprefix dlist delta_0_prefixes n = - match dlist with - [] -> ([],n) - | f::r -> - let fprefix = List.assoc f delta_0_prefixes in - let (sf1,sg) = shorten fprefix gprefix - and v_new = ("vnewq"^(string_of_int n)) in - let fnew = sf1 @ [v_new] in - let (rest_equations,new_n) = one_equation gprefix r delta_0_prefixes (n+1) in - (([],(fnew,sg))::rest_equations),new_n - -let rec make_domain_equations fo_pairs (gamma_0_prefixes,delta_0_prefixes) n = - match fo_pairs with - [] -> ([],n) - | (g,dlist)::r -> - let gprefix = List.assoc g gamma_0_prefixes in - let (gequations,max) = one_equation gprefix dlist delta_0_prefixes n in - let (rest_equations,new_max) = - make_domain_equations r (gamma_0_prefixes,delta_0_prefixes) max in - (gequations @ rest_equations),new_max - -(* type of one unifier: int * ((string * string list) list) *) -(* global failure: (0,[]) *) - -let stringunify ext_atom try_one eqlist fo_pairs logic orderingQ atom_rel qprefixes = - if logic = "C" then - ((0,[]),(0,[]),orderingQ) - else - let (qmax,equations) = eqlist - and us = ext_atom.aprefix - and ut = try_one.aprefix - and ns = ext_atom.aname - and nt = try_one.aname in - if qprefixes = ([],[]) then (* prop case *) - begin -(* print_endline "This is the prop case"; *) - let (new_sigma,new_eqlist) = Jtunify.do_stringunify us ut ns nt equations - (* prop unification only *) - in - (new_sigma,new_eqlist,[]) (* assume the empty reduction ordering during proof search *) - end - else - begin -(* print_endline "This is the FO case"; *) -(* fo_eqlist encodes the domain condition on J quantifier substitutions *) -(* Again, always computed for the whole substitution sigmaQ *) - let (fo_eqlist,new_max) = make_domain_equations fo_pairs qprefixes qmax in - begin -(* Format.open_box 0; - print_string "domain equations in"; - print_equations fo_eqlist; - print_string "domain equations out"; - Format.print_flush (); -*) - do_stringunify us ut ns nt equations fo_eqlist orderingQ atom_rel new_max - end - end - -(**************************************** add multiplicity *********************************) - -let rec subst_replace subst_list t = - match subst_list with - [] -> t - | (old_t,new_t)::r -> - let inter_term = var_subst t old_t "dummy" in - let new_term = subst1 inter_term "dummy" new_t in - subst_replace r new_term - -let rename_pos x m = - let pref = String.get x 0 in - (Char.escaped pref)^(string_of_int m) - -let update_position position m replace_n subst_list mult = - let ({name=x; address=y; op=z; pol=p; pt=a; st=b; label=t}) = position in - let nx = rename_pos x m in - let nsubst_list = - if b=Gamma_0 then - let vx = mk_var_term (x^"_jprover") - and vnx = mk_var_term (nx^"_jprover") in - (vx,vnx)::subst_list - else - if b=Delta_0 then - let sx = mk_string_term jprover_op x - and snx = mk_string_term jprover_op nx in - (sx,snx)::subst_list - else - subst_list - in - let nt = subst_replace nsubst_list t in - let add_array = Array.of_list y in - let _ = (add_array.(replace_n) <- mult) in - let new_add = Array.to_list add_array in - ({name=nx; address=new_add; op=z; pol=p; pt=a; st=b; label=nt},m,nsubst_list) - -let rec append_orderings list_of_lists = - match list_of_lists with - [] -> - [] - | f::r -> - f @ (append_orderings r) - -let rec union_orderings first_orderings = - match first_orderings with - [] -> - StringSet.empty - | (pos,fset)::r -> - StringSet.union (StringSet.add pos fset) (union_orderings r) - -let rec select_orderings add_orderings = - match add_orderings with - [] -> [] - | f::r -> - (List.hd f)::select_orderings r - -let combine_ordering_list add_orderings pos_name = - let first_orderings = select_orderings add_orderings in - let pos_succs = union_orderings first_orderings in - let rest_orderings = append_orderings add_orderings in - (pos_name,pos_succs)::rest_orderings - -let rec copy_and_rename_tree last_tree replace_n pos_n mult subst_list = - - let rec rename_subtrees tree_list nposition s_pos_n nsubst_list = - match tree_list with - [] -> ([||],[],s_pos_n) - | f::r -> - let (f_subtree,f_ordering,f_pos_n) = - copy_and_rename_tree f replace_n s_pos_n mult nsubst_list in - let (r_subtrees,r_ordering_list,r_pos_n) = rename_subtrees r nposition f_pos_n nsubst_list in - ((Array.append [|f_subtree|] r_subtrees),(f_ordering::r_ordering_list),r_pos_n) - - in - match last_tree with - Empty -> raise (Invalid_argument "Jprover: copy tree") - | NodeAt(position) -> (* can never be a Gamma_0 position -> no replacements *) - let (nposition,npos_n,_) = update_position position (pos_n+1) replace_n subst_list mult in - ((NodeAt(nposition)),[(nposition.name,StringSet.empty)],npos_n) - | NodeA(position, suctrees) -> - let (nposition,npos_n,nsubst_list) = update_position position (pos_n+1) replace_n subst_list mult in - let (new_suctrees, new_ordering_list, new_pos_n) = - rename_subtrees (Array.to_list suctrees) nposition npos_n nsubst_list in - let new_ordering = combine_ordering_list new_ordering_list (nposition.name) in - ((NodeA(nposition,new_suctrees)),new_ordering,new_pos_n) - -(* we construct for each pos a list orderings representing and correspondning to the array of succtrees *) - -let rec add_multiplicity ftree pos_n mult logic = - let rec parse_subtrees tree_list s_pos_n = - match tree_list with - [] -> ([||],[],s_pos_n) - | f::r -> - let (f_subtree,f_ordering,f_pos_n) = add_multiplicity f s_pos_n mult logic in - let (r_subtrees,r_ordering_list,r_pos_n) = parse_subtrees r f_pos_n in - ((Array.append [|f_subtree|] r_subtrees),(f_ordering::r_ordering_list),r_pos_n) - - in - match ftree with - Empty -> raise (Invalid_argument "Jprover: add mult") - | NodeAt(pos) -> (ftree,[(pos.name,StringSet.empty)],pos_n) - | NodeA(pos,suctrees) -> - let (new_suctrees, new_ordering_list, new_pos_n) = parse_subtrees (Array.to_list suctrees) pos_n in - if (((pos.pt = Phi) & (((pos.op <> At) & (logic="J")) or ((pos.op = All) & (logic = "C")))) - (* no explicit atom-instances *) - or ((pos.pt = Gamma) & (pos.st <> Phi_0))) then (* universal quantifiers are copied *) - (* at their Phi positions *) - let replace_n = (List.length pos.address) (* points to the following argument in the array_of_address *) - and last = (Array.length new_suctrees) - 1 in (* array first element has index 0 *) - let last_tree = new_suctrees.(last) in - let (add_tree,add_ordering,final_pos_n) = - copy_and_rename_tree last_tree replace_n new_pos_n mult [] in - let final_suctrees = Array.append new_suctrees [|add_tree|] - and add_orderings = List.append new_ordering_list [add_ordering] in - let final_ordering = combine_ordering_list add_orderings (pos.name) in - ((NodeA(pos,final_suctrees)),final_ordering,final_pos_n) - else - let final_ordering = combine_ordering_list new_ordering_list (pos.name) in - ((NodeA(pos,new_suctrees)),final_ordering,new_pos_n) - - -(************** Path checker ****************************************************) - -let rec get_sets atom atom_sets = - match atom_sets with - [] -> raise (Invalid_argument "Jprover bug: atom not found") - | f::r -> - let (a,b,c) = f in - if atom = a then f - else - get_sets atom r - -let rec get_connections a alpha tabulist = - match alpha with - [] -> [] - | f::r -> - if (a.apredicate = f.apredicate) & (a.apol <> f.apol) & (not (List.mem f tabulist)) then - (a,f)::(get_connections a r tabulist) - else - (get_connections a r tabulist) - -let rec connections atom_rel tabulist = - match atom_rel with - [] -> [] - | f::r -> - let (a,alpha,beta) = f in - (get_connections a alpha tabulist) @ (connections r (a::tabulist)) - -let check_alpha_relation atom set atom_sets = - let (a,alpha,beta) = get_sets atom atom_sets in - AtomSet.subset set alpha - -let rec extset atom_sets path closed = - match atom_sets with - [] -> AtomSet.empty - | f::r -> - let (at,alpha,beta) = f in - if (AtomSet.subset path alpha) & (AtomSet.subset closed beta) then - AtomSet.add at (extset r path closed) - else - (extset r path closed) - -let rec check_ext_list ext_list fail_set atom_sets = (* fail_set consists of one atom only *) - match ext_list with - [] -> AtomSet.empty - | f::r -> - if (check_alpha_relation f fail_set atom_sets) then - AtomSet.add f (check_ext_list r fail_set atom_sets) - else - (check_ext_list r fail_set atom_sets) - -let fail_ext_set ext_atom ext_set atom_sets = - let ext_list = AtomSet.elements ext_set - and fail_set = AtomSet.add ext_atom AtomSet.empty in - check_ext_list ext_list fail_set atom_sets - -let rec ext_partners con path ext_atom (reduction_partners,extension_partners) atom_sets = - match con with - [] -> - (reduction_partners,extension_partners) - | f::r -> - let (a,b) = f in - if List.mem ext_atom [a;b] then - let ext_partner = - if ext_atom = a then b else a - in - let (new_red_partners,new_ext_partners) = -(* force reduction steps first *) - if (AtomSet.mem ext_partner path) then - ((AtomSet.add ext_partner reduction_partners),extension_partners) - else - if (check_alpha_relation ext_partner path atom_sets) then - (reduction_partners,(AtomSet.add ext_partner extension_partners)) - else - (reduction_partners,extension_partners) - in - ext_partners r path ext_atom (new_red_partners,new_ext_partners) atom_sets - else - ext_partners r path ext_atom (reduction_partners,extension_partners) atom_sets - -exception Failed_connections - -let path_checker atom_rel atom_sets qprefixes init_ordering logic = - - let con = connections atom_rel [] in - let rec provable path closed (orderingQ,reduction_ordering) eqlist (sigmaQ,sigmaJ) = - - let rec check_connections (reduction_partners,extension_partners) ext_atom = - let try_one = - if reduction_partners = AtomSet.empty then - if extension_partners = AtomSet.empty then - raise Failed_connections - else - AtomSet.choose extension_partners - else - (* force reduction steps always first!! *) - AtomSet.choose reduction_partners - in -(* print_endline ("connection partner "^(try_one.aname)); *) -(* print_endline ("partner path "^(print_set path)); -*) - (try - let (new_sigmaQ,new_ordering_elements) = jqunify (ext_atom.alabel) (try_one.alabel) sigmaQ in -(* build the orderingQ incrementally from the new added substitution tau of new_sigmaQ *) - let (relate_pairs,new_orderingQ) = build_orderingQ new_ordering_elements orderingQ in -(* we make in incremental reflexivity test during the string unification *) - let (new_sigmaJ,new_eqlist,new_red_ordering) = -(* new_red_ordering = [] in propositional case *) - stringunify ext_atom try_one eqlist relate_pairs logic new_orderingQ atom_rel qprefixes - in -(* print_endline ("make reduction ordering "^((string_of_int (List.length new_ordering)))); *) - let new_closed = AtomSet.add ext_atom closed in - let ((next_orderingQ,next_red_ordering),next_eqlist,(next_sigmaQ,next_sigmaJ),subproof) = - if AtomSet.mem try_one path then - provable path new_closed (new_orderingQ,new_red_ordering) new_eqlist (new_sigmaQ,new_sigmaJ) - (* always use old first-order ordering for recursion *) - else - let new_path = AtomSet.add ext_atom path - and extension = AtomSet.add try_one AtomSet.empty in - let ((norderingQ,nredordering),neqlist,(nsigmaQ,nsigmaJ),p1) = - provable new_path extension (new_orderingQ,new_red_ordering) new_eqlist (new_sigmaQ,new_sigmaJ) in - let ((nnorderingQ,nnredordering),nneqlist,(nnsigmaQ,nnsigmaJ),p2) = - provable path new_closed (norderingQ,nredordering) neqlist (nsigmaQ,nsigmaJ) in - ((nnorderingQ,nnredordering),nneqlist,(nnsigmaQ,nnsigmaJ),(p1 @ p2)) - (* first the extension subgoals = depth first; then other subgoals in same clause *) - in - ((next_orderingQ,next_red_ordering),next_eqlist,(next_sigmaQ,next_sigmaJ),(((ext_atom.aname),(try_one.aname))::subproof)) - with Failed -> -(* print_endline ("new connection for "^(ext_atom.aname)); *) -(* print_endline ("Failed"); *) - check_connections ((AtomSet.remove try_one reduction_partners), - (AtomSet.remove try_one extension_partners) - ) ext_atom - ) - - in - let rec check_extension extset = - if extset = AtomSet.empty then - raise Failed (* go directly to a new entry connection *) - else - let select_one = AtomSet.choose extset in -(* print_endline ("extension literal "^(select_one.aname)); *) -(* print_endline ("extension path "^(print_set path));*) - let (reduction_partners,extension_partners) = - ext_partners con path select_one (AtomSet.empty,AtomSet.empty) atom_sets in - (try - check_connections (reduction_partners,extension_partners) select_one - with Failed_connections -> -(* print_endline ("no connections for subgoal "^(select_one.aname)); *) -(* print_endline ("Failed_connections"); *) - let fail_ext_set = fail_ext_set select_one extset atom_sets in - check_extension fail_ext_set - ) - - in - let extset = extset atom_sets path closed in - if extset = AtomSet.empty then - ((orderingQ,reduction_ordering),eqlist,(sigmaQ,sigmaJ),[]) - else - check_extension extset - in - if qprefixes = ([],[]) then - begin -(* print_endline "!!!!!!!!!!! prop prover !!!!!!!!!!!!!!!!!!"; *) -(* in the propositional case, the reduction ordering will be computed AFTER proof search *) - let (_,eqlist,(_,(n,substJ)),ext_proof) = - provable AtomSet.empty AtomSet.empty ([],[]) (1,[]) ([],(1,[])) in - let orderingJ = build_orderingJ_list substJ init_ordering atom_rel in - ((init_ordering,orderingJ),eqlist,([],(n,substJ)),ext_proof) - end - else - provable AtomSet.empty AtomSet.empty (init_ordering,[]) (1,[]) ([],(1,[])) - -(*************************** prepare and init prover *******************************************************) - -let rec list_to_set list = - match list with - [] -> AtomSet.empty - | f::r -> - let rest_set = list_to_set r in - AtomSet.add f rest_set - -let rec make_atom_sets atom_rel = - match atom_rel with - [] -> [] - | f::r -> - let (a,alpha,beta) = f in - (a,(list_to_set alpha),(list_to_set beta))::(make_atom_sets r) - -let rec predecessor address_1 address_2 ftree = - match ftree with - Empty -> PNull (* should not occur since every pair of atoms have a common predecessor *) - | NodeAt(position) -> PNull (* should not occur as above *) - | NodeA(position,suctrees) -> - match address_1,address_2 with - [],_ -> raise (Invalid_argument "Jprover: predecessors left") - | _,[] -> raise (Invalid_argument "Jprover: predecessors right") - | (f1::r1),(f2::r2) -> - if f1 = f2 then - predecessor r1 r2 (suctrees.(f1-1)) - else - position.pt - -let rec compute_sets element ftree alist = - match alist with - [] -> [],[] - | first::rest -> - if first = element then - compute_sets element ftree rest (* element is neithes alpha- nor beta-related to itself*) - else - let (alpha_rest,beta_rest) = compute_sets element ftree rest in - if predecessor (element.aaddress) (first.aaddress) ftree = Beta then - (alpha_rest,(first::beta_rest)) - else - ((first::alpha_rest),beta_rest) - -let rec compute_atomlist_relations worklist ftree alist = (* last version of alist for total comparison *) - let rec compute_atom_relations element ftree alist = - let alpha_set,beta_set = compute_sets element ftree alist in - (element,alpha_set,beta_set) - in - match worklist with - [] -> [] - | first::rest -> - let first_relations = compute_atom_relations first ftree alist in - first_relations::(compute_atomlist_relations rest ftree alist) - -let atom_record position prefix = - let aname = (position.name) in - let aprefix = (List.append prefix [aname]) in (* atom position is last element in prefix *) - let aop = (dest_term position.label).term_op in - ({aname=aname; aaddress=(position.address); aprefix=aprefix; apredicate=aop; - apol=(position.pol); ast=(position.st); alabel=(position.label)}) - -let rec select_atoms_treelist treelist prefix = - let rec select_atoms ftree prefix = - match ftree with - Empty -> [],[],[] - | NodeAt(position) -> - [(atom_record position prefix)],[],[] - | NodeA(position,suctrees) -> - let treelist = Array.to_list suctrees in - let new_prefix = - let prefix_element = - if List.mem (position.st) [Psi_0;Phi_0] then - [(position.name)] - else - [] - in - (List.append prefix prefix_element) - in - let (gamma_0_element,delta_0_element) = - if position.st = Gamma_0 then - begin -(* Format.open_box 0; - print_endline "gamma_0 prefixes "; - print_string (position.name^" :"); - print_stringlist prefix; - print_endline " "; - Format.force_newline (); - Format.print_flush (); -*) - [(position.name,prefix)],[] - end - else - if position.st = Delta_0 then - begin -(* Format.open_box 0; - print_endline "delta_0 prefixes "; - print_string (position.name^" :"); - print_stringlist prefix; - print_endline " "; - Format.force_newline (); - Format.print_flush (); -*) - [],[(position.name,prefix)] - end - else - [],[] - in - let (rest_alist,rest_gamma_0_prefixes,rest_delta_0_prefixes) = - select_atoms_treelist treelist new_prefix in - (rest_alist,(rest_gamma_0_prefixes @ gamma_0_element), - (rest_delta_0_prefixes @ delta_0_element)) - - in - match treelist with - [] -> [],[],[] - | first::rest -> - let (first_alist,first_gprefixes,first_dprefixes) = select_atoms first prefix - and (rest_alist,rest_gprefixes,rest_dprefixes) = select_atoms_treelist rest prefix in - ((first_alist @ rest_alist),(first_gprefixes @ rest_gprefixes), - (first_dprefixes @ rest_dprefixes)) - -let prepare_prover ftree = - let alist,gamma_0_prefixes,delta_0_prefixes = select_atoms_treelist [ftree] [] in - let atom_rel = compute_atomlist_relations alist ftree alist in - (atom_rel,(gamma_0_prefixes,delta_0_prefixes)) - -(* ************************ Build intial formula tree and relations *********************************** *) -(* Building a formula tree and the tree ordering from the input formula, i.e. OCaml term *) - -let make_position_name stype pos_n = - let prefix = - if List.mem stype [Phi_0;Gamma_0] - then "v" - else - if List.mem stype [Psi_0;Delta_0] - then "c" - else - "a" - in - prefix^(string_of_int pos_n) - -let dual_pol pol = - if pol = O then I else O - -let check_subst_term (variable,old_term) pos_name stype = - if (List.mem stype [Gamma_0;Delta_0]) then - let new_variable = - if stype = Gamma_0 then (mk_var_term (pos_name^"_jprover")) - else - (mk_string_term jprover_op pos_name) - in - (subst1 old_term variable new_variable) (* replace variable (non-empty) in t by pos_name *) - (* pos_name is either a variable term or a constant, f.i. a string term *) - (* !!! check unification module how handling eingenvariables as constants !!! *) - else - old_term - -let rec build_ftree (variable,old_term) pol stype address pos_n = - let pos_name = make_position_name stype pos_n in - let term = check_subst_term (variable,old_term) pos_name stype in - if JLogic.is_and_term term then - let s,t = JLogic.dest_and term in - let ptype,stype_1,stype_2 = - if pol = O - then Beta,Beta_1,Beta_2 - else - Alpha,Alpha_1,Alpha_2 - in - let position = {name=pos_name; address=address; op=And; pol=pol; pt=ptype; st=stype; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree ("",s) pol stype_1 (address@[1]) (pos_n+1) in - let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[2]) - (posn_left+1) in - let (succ_left,whole_left) = List.hd ordering_left - and (succ_right,whole_right) = List.hd ordering_right in - let pos_succs = - (StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right))) - in - (NodeA(position,[|subtree_left;subtree_right|]), - ((position.name,pos_succs)::(ordering_left @ ordering_right)), - posn_right - ) - else - if JLogic.is_or_term term then - let s,t = JLogic.dest_or term in - let ptype,stype_1,stype_2 = - if pol = O - then Alpha,Alpha_1,Alpha_2 - else - Beta,Beta_1,Beta_2 - in - let position = {name=pos_name; address=address; op=Or; pol=pol; pt=ptype; st=stype; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree ("",s) pol stype_1 (address@[1]) (pos_n+1) in - let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[2]) - (posn_left+1) in - let (succ_left,whole_left) = List.hd ordering_left - and (succ_right,whole_right) = List.hd ordering_right in - let pos_succs = - StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right)) in - (NodeA(position,[|subtree_left;subtree_right|]), - ((position.name),pos_succs) :: (ordering_left @ ordering_right), - posn_right - ) - else - if JLogic.is_implies_term term then - let s,t = JLogic.dest_implies term in - let ptype_0,stype_0,ptype,stype_1,stype_2 = - if pol = O - then Psi,Psi_0,Alpha,Alpha_1,Alpha_2 - else - Phi,Phi_0,Beta,Beta_1,Beta_2 - in - let pos2_name = make_position_name stype_0 (pos_n+1) in - let sposition = {name=pos_name; address=address; op=Imp; pol=pol; pt=ptype_0; st=stype; label=term} - and position = {name=pos2_name; address=address@[1]; op=Imp; pol=pol; pt=ptype; st=stype_0; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree ("",s) (dual_pol pol) stype_1 (address@[1;1]) - (pos_n+2) in - let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[1;2]) - (posn_left+1) in - let (succ_left,whole_left) = List.hd ordering_left - and (succ_right,whole_right) = List.hd ordering_right in - let pos_succs = - StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right)) in - let pos_ordering = (position.name,pos_succs) :: (ordering_left @ ordering_right) in - (NodeA(sposition,[|NodeA(position,[|subtree_left;subtree_right|])|]), - ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering), - posn_right - ) - else - if JLogic.is_not_term term then - let s = JLogic.dest_not term in - let ptype_0,stype_0,ptype,stype_1= - if pol = O - then Psi,Psi_0,Alpha,Alpha_1 - else - Phi,Phi_0,Alpha,Alpha_1 - in - let pos2_name = make_position_name stype_0 (pos_n+1) in - let sposition = {name=pos_name; address=address; op=Neg; pol=pol; pt=ptype_0; st=stype; label=term} - and position = {name=pos2_name; address=address@[1]; op=Neg; pol=pol; pt=ptype; st=stype_0; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree ("",s) (dual_pol pol) stype_1 (address@[1;1]) - (pos_n+2) in - let (succ_left,whole_left) = List.hd ordering_left in - let pos_succs = - StringSet.add succ_left whole_left in - let pos_ordering = (position.name,pos_succs) :: ordering_left in - (NodeA(sposition,[|NodeA(position,[| subtree_left|])|]), - ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering), - posn_left - ) - else - if JLogic.is_exists_term term then - let v,s,t = JLogic.dest_exists term in (* s is type of v and will be supressed here *) - let ptype,stype_1 = - if pol = O - then Gamma,Gamma_0 - else - Delta,Delta_0 - in - let position = {name=pos_name; address=address; op=Ex; pol=pol; pt=ptype; st=stype; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree (v,t) pol stype_1 (address@[1]) (pos_n+1) in - let (succ_left,whole_left) = List.hd ordering_left in - let pos_succs = - StringSet.add succ_left whole_left in - (NodeA(position,[|subtree_left|]), - ((position.name,pos_succs) :: ordering_left), - posn_left - ) - else - if JLogic.is_all_term term then - let v,s,t = JLogic.dest_all term in - (* s is type of v and will be supressed here *) - let ptype_0,stype_0,ptype,stype_1= - if pol = O - then Psi,Psi_0,Delta,Delta_0 - else - Phi,Phi_0,Gamma,Gamma_0 - in - let pos2_name = make_position_name stype_0 (pos_n+1) in - let sposition = {name=pos_name; address=address; op=All; pol=pol; pt=ptype_0; st=stype; label=term} - and position = {name=pos2_name; address=address@[1]; op=All; pol=pol; pt=ptype; st=stype_0; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree (v,t) pol stype_1 (address@[1;1]) - (pos_n+2) in - let (succ_left,whole_left) = List.hd ordering_left in - let pos_succs = - StringSet.add succ_left whole_left in - let pos_ordering = (position.name,pos_succs) :: ordering_left in - (NodeA(sposition,[|NodeA(position,[|subtree_left|])|]), - ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering), - posn_left - ) - else (* finally, term is atomic *) - let ptype_0,stype_0 = - if pol = O - then Psi,Psi_0 - else - Phi,Phi_0 - in - let pos2_name = make_position_name stype_0 (pos_n+1) in - let sposition = {name=pos_name; address=address; op=At; pol=pol; pt=ptype_0; st=stype; label=term} - and position = {name=pos2_name; address=address@[1]; op=At; pol=pol; pt=PNull; st=stype_0; label=term} in - (NodeA(sposition,[|NodeAt(position)|]), - [(sposition.name,(StringSet.add position.name StringSet.empty));(position.name,StringSet.empty)], - pos_n+1 - ) - -let rec construct_ftree termlist treelist orderinglist pos_n goal = - match termlist with - [] -> - let new_root = {name="w"; address=[]; op=Null; pol=O; pt=Psi; st=PNull_0; label=goal} - and treearray = Array.of_list treelist in - NodeA(new_root,treearray),(("w",(union_orderings orderinglist))::orderinglist),pos_n - | ft::rest_terms -> - let next_address = [((List.length treelist)+1)] - and next_pol,next_goal = - if rest_terms = [] then - O,ft (* construct tree for the conclusion *) - else - I,goal - in - let new_tree,new_ordering,new_pos_n = - build_ftree ("",ft) next_pol Alpha_1 next_address (pos_n+1) in - construct_ftree rest_terms (treelist @ [new_tree]) - (orderinglist @ new_ordering) new_pos_n next_goal - -(*************************** Main LOOP ************************************) -let unprovable = RefineError ("Jprover", StringError "formula is not provable") -let mult_limit_exn = RefineError ("Jprover", StringError "multiplicity limit reached") -let coq_exn = RefineError ("Jprover", StringError "interface for coq: error on ") - -let init_prover ftree = - let atom_relation,qprefixes = prepare_prover ftree in -(* print_atom_info atom_relation; *) (* apple *) - let atom_sets = make_atom_sets atom_relation in - (atom_relation,atom_sets,qprefixes) - - -let rec try_multiplicity mult_limit ftree ordering pos_n mult logic = - try - let (atom_relation,atom_sets,qprefixes) = init_prover ftree in - let ((orderingQ,red_ordering),eqlist,unifier,ext_proof) = - path_checker atom_relation atom_sets qprefixes ordering logic in - (ftree,red_ordering,eqlist,unifier,ext_proof) (* orderingQ is not needed as return value *) - with Failed -> - match mult_limit with - Some m when m == mult -> - raise mult_limit_exn - | _ -> - let new_mult = mult+1 in - begin - Pp.msgnl (Pp.(++) (Pp.str "Multiplicity Fail: Trying new multiplicity ") - (Pp.int new_mult)); -(* - Format.open_box 0; - Format.force_newline (); - Format.print_string "Multiplicity Fail: "; - Format.print_string ("Try new multiplicity "^(string_of_int new_mult)); - Format.force_newline (); - Format.print_flush (); -*) - let (new_ftree,new_ordering,new_pos_n) = - add_multiplicity ftree pos_n new_mult logic in - if (new_ftree = ftree) then - raise unprovable - else -(* print_formula_info new_ftree new_ordering new_pos_n; *) (* apple *) - try_multiplicity mult_limit new_ftree new_ordering new_pos_n new_mult logic - end - -let prove mult_limit termlist logic = - let (ftree,ordering,pos_n) = construct_ftree termlist [] [] 0 (mk_var_term "dummy") in -(* pos_n = number of positions without new root "w" *) -(* print_formula_info ftree ordering pos_n; *) (* apple *) - try_multiplicity mult_limit ftree ordering pos_n 1 logic - -(********** first-order type theory interface *******************) - -let rec renam_free_vars termlist = - match termlist - with [] -> [],[] - | f::r -> - let var_names = free_vars_list f in - let string_terms = - List.map (fun x -> (mk_string_term free_var_op x)) var_names - in - let mapping = List.combine var_names string_terms - and new_f = subst f var_names string_terms in - let (rest_mapping,rest_renamed) = renam_free_vars r in - let unique_mapping = remove_dups_list (mapping @ rest_mapping) in - (unique_mapping,(new_f::rest_renamed)) - -let rec apply_var_subst term var_subst_list = - match var_subst_list with - [] -> term - | (v,t)::r -> - let next_term = var_subst term t v in - apply_var_subst next_term r - -let rec make_equal_list n list_object = - if n = 0 then - [] - else - list_object::(make_equal_list (n-1) list_object) - -let rec create_output rule_list input_map = - match rule_list with - [] -> JLogic.empty_inf - | f::r -> - let (pos,(rule,term1,term2)) = f in - let delta1_names = collect_delta_terms [term1] - and delta2_names = collect_delta_terms [term2] in - let unique_deltas = remove_dups_list (delta1_names @ delta2_names) in - let delta_terms = - List.map (fun x -> (mk_string_term jprover_op x)) unique_deltas in - let delta_vars = List.map (fun x -> (x^"_jprover")) unique_deltas in - let delta_map = List.combine delta_vars delta_terms in - let var_mapping = (input_map @ delta_map) in - let frees1 = free_vars_list term1 - and frees2 = free_vars_list term2 in - let unique_object = mk_var_term "v0_jprover" in - let unique_list1 = make_equal_list (List.length frees1) unique_object - and unique_list2 = make_equal_list (List.length frees2) unique_object - in - let next_term1 = subst term1 frees1 unique_list1 - and next_term2 = subst term2 frees2 unique_list2 in - let new_term1 = apply_var_subst next_term1 var_mapping - and new_term2 = apply_var_subst next_term2 var_mapping - and (a,b) = pos - in - -(* kick away the first argument, the position *) - (JLogic.append_inf (create_output r input_map) (b,new_term1) (a,new_term2) rule) - -let rec make_test_interface rule_list input_map = - match rule_list with - [] -> [] - | f::r -> - let (pos,(rule,term1,term2)) = f in - let delta1_names = collect_delta_terms [term1] - and delta2_names = collect_delta_terms [term2] in - let unique_deltas = remove_dups_list (delta1_names @ delta2_names) in - let delta_terms = - List.map (fun x -> (mk_string_term jprover_op x)) unique_deltas in - let delta_vars = List.map (fun x -> (x^"_jprover")) unique_deltas in - let delta_map = List.combine delta_vars delta_terms in - let var_mapping = (input_map @ delta_map) in - let frees1 = free_vars_list term1 - and frees2 = free_vars_list term2 in - let unique_object = mk_var_term "v0_jprover" in - let unique_list1 = make_equal_list (List.length frees1) unique_object - and unique_list2 = make_equal_list (List.length frees2) unique_object - in - begin -(* - print_endline ""; - print_endline ""; - print_stringlist frees1; - print_endline ""; - print_stringlist frees2; - print_endline ""; - print_endline ""; -*) - let next_term1 = subst term1 frees1 unique_list1 - and next_term2 = subst term2 frees2 unique_list2 in - let new_term1 = apply_var_subst next_term1 var_mapping - and new_term2 = apply_var_subst next_term2 var_mapping - in - (pos,(rule,new_term1,new_term2))::(make_test_interface r input_map) - end - -(**************************************************************) - -let decomp_pos pos = - let {name=n; address=a; label=l} = pos in - (n,(a,l)) - -let rec build_formula_id ftree = - let rec build_fid_list = function - [] -> [] - | t::rest -> (build_formula_id t)@(build_fid_list rest) - in - match ftree with - Empty -> [] - | NodeAt(position) -> - [decomp_pos position] - | NodeA(position,subtrees) -> - let tree_list = Array.to_list subtrees in - (decomp_pos position)::(build_fid_list tree_list) - -let rec encode1 = function (* normal *) - [] -> "" - | i::r -> "_"^(string_of_int i)^(encode1 r) - -let rec encode2 = function (* move up *) - [i] -> "" - | i::r -> "_"^(string_of_int i)^(encode2 r) - | _ -> raise coq_exn - -let rec encode3 = function (* move down *) - [] -> "_1" - | i::r -> "_"^(string_of_int i)^(encode3 r) - -let lookup_coq str map = - try - let (il,t) = List.assoc str map in - il - with Not_found -> raise coq_exn - -let create_coq_input inf map = - let rec rec_coq_part inf = - match inf with - [] -> [] - | (rule, (s1, t1), ((s2, t2) as k))::r -> - begin - match rule with - Andl | Andr | Orl | Orr1 | Orr2 -> - (rule, (encode1 (lookup_coq s1 map), t1), k)::(rec_coq_part r) - | Impr | Impl | Negr | Negl | Ax -> - (rule, (encode2 (lookup_coq s1 map), t1), k)::(rec_coq_part r) - | Exr -> - (rule, (encode1 (lookup_coq s1 map), t1), - (encode1 (lookup_coq s2 map), t2))::(rec_coq_part r) - | Exl -> - (rule, (encode1 (lookup_coq s1 map), t1), - (encode3 (lookup_coq s1 map), t2))::(rec_coq_part r) - | Allr | Alll -> - (rule, (encode2 (lookup_coq s1 map), t1), - (* (s2, t2))::(rec_coq_part r) *) - (encode3 (lookup_coq s1 map), t2))::(rec_coq_part r) - | _ -> raise coq_exn - end - in - rec_coq_part inf - -let gen_prover mult_limit logic calculus hyps concls = - let (input_map,renamed_termlist) = renam_free_vars (hyps @ concls) in - let (ftree,red_ordering,eqlist,(sigmaQ,sigmaJ),ext_proof) = prove mult_limit renamed_termlist logic in - let sequent_proof = reconstruct ftree red_ordering sigmaQ ext_proof logic calculus in - let idl = build_formula_id ftree in -(* print_ftree ftree; apple *) - (* transform types and rename constants *) - (* we can transform the eigenvariables AFTER proof reconstruction since *) - (* new delta_0 constants may have been constructed during rule permutation *) - (* from the LJmc to the LJ proof *) - create_coq_input (create_output sequent_proof input_map) idl - -let prover mult_limit hyps concl = gen_prover mult_limit "J" "LJ" hyps [concl] - -(************* test with propositional proof reconstruction ************) - -let rec count_axioms seq_list = - match seq_list with - [] -> 0 - | f::r -> - let (rule,_,_) = f in - if rule = Ax then - 1 + count_axioms r - else - count_axioms r - -let do_prove mult_limit termlist logic calculus = - try begin - let (input_map,renamed_termlist) = renam_free_vars termlist in - let (ftree,red_ordering,eqlist,(sigmaQ,sigmaJ),ext_proof) = prove mult_limit renamed_termlist logic in - Format.open_box 0; - Format.force_newline (); - Format.force_newline (); - Format.print_string "Extension proof ready"; - Format.force_newline (); - Format.force_newline (); - Format.print_string ("Length of Extension proof: "^((string_of_int (List.length ext_proof)))^ - " Axioms"); - Format.force_newline (); - Format.force_newline (); - print_endline "Extension proof:"; - Format.open_box 0; - print_pairlist ext_proof; (* print list of type (string * string) list *) - Format.force_newline (); - Format.force_newline (); - Format.force_newline (); - Format.print_flush (); - Format.print_flush (); - Format.open_box 0; - print_ordering red_ordering; - Format.print_flush (); - Format.open_box 0; - Format.force_newline (); -(* ----------------------------------------------- *) - Format.open_box 0; - print_tunify sigmaJ; - Format.print_flush (); - print_endline ""; - print_endline ""; - print_sigmaQ sigmaQ; - print_endline ""; - print_endline ""; - Format.open_box 0; - let (qmax,equations) = eqlist in - print_endline ("number of quantifier domains : "^(string_of_int (qmax-1))); - print_endline ""; - print_equations equations; - Format.print_flush (); - print_endline ""; - print_endline ""; - print_endline ("Length of equations : "^((string_of_int (List.length equations)))); - print_endline ""; - print_endline ""; -(* --------------------------------------------------------- *) - Format.print_string "Break ... "; - print_endline ""; - print_endline ""; - Format.print_flush (); - let reconstr_proof = reconstruct ftree red_ordering sigmaQ ext_proof logic calculus in - let sequent_proof = make_test_interface reconstr_proof input_map in - Format.open_box 0; - Format.force_newline (); - Format.force_newline (); - Format.print_string "Sequent proof ready"; - Format.force_newline (); - Format.force_newline (); - Format.print_flush (); - let (ptree,count_ax) = bproof sequent_proof in - Format.open_box 0; - Format.print_string ("Length of sequent proof: "^((string_of_int count_ax))^" Axioms"); - Format.force_newline (); - Format.force_newline (); - Format.force_newline (); - Format.force_newline (); - Format.print_flush (); - tt ptree; - Format.print_flush (); - print_endline ""; - print_endline "" - end with exn -> begin - print_endline "Jprover got an exception:"; - print_endline (Printexc.to_string exn) - end - -let test concl logic calculus = (* calculus should be LJmc or LJ for J, and LK for C *) - do_prove None [concl] logic calculus - -(* for sequents *) - -let seqtest list_term logic calculus = - let bterms = (dest_term list_term).term_terms in - let termlist = collect_subterms bterms in - do_prove None termlist logic calculus - -(*****************************************************************) - -end (* of struct *) diff --git a/contrib/jprover/jall.mli b/contrib/jprover/jall.mli deleted file mode 100644 index 1811fe59..00000000 --- a/contrib/jprover/jall.mli +++ /dev/null @@ -1,339 +0,0 @@ -(* JProver provides an efficient refiner for first-order classical - and first-order intuitionistic logic. It consists of two main parts: - a proof search procedure and a proof reconstruction procedure. - - - Proof Search - ============ - - The proof search process is based on a matrix-based (connection-based) - proof procedure, i.e.~a non-normalform extension procedure. - Besides the well-known quantifier substitution (Martelli Montanari), - a special string unifiation procedure is used in order to - efficiently compute intuitionistic rule non-permutabilities. - - - Proof Reconstruction - ==================== - - The proof reconstruction process converts machine-generated matrix proofs - into cut-free Gentzen-style sequent proofs. For classcal logic "C", - Gentzen's sequent calculus "LK" is used as target calculus. - For intuitionistic logic "J", either Gentzen's single-conclusioned sequent - calculus "LJ" or Fitting's multiply-conclusioned sequent calculus "LJmc" - can be used. All sequent claculi are implemented in a set-based formulation - in order to avoid structural rules. - - The proof reconstruction procedure combines three main procedures, depending - on the selected logics and sequent calculi. It consists of: - - 1) A uniform traversal algorithm for all logics and target sequent calculi. - This procedure converts classical (intuitionistic) matrix proofs - directly into cut-free "LK" ("LJmc" or "LJ") sequent proofs. - However, the direct construction of "LJ" proofs may fail in some cases - due to proof theoretical reasons. - - 2) A complete redundancy deletion algorithm, which integrates additional - knowledge from the proof search process into the reconstruction process. - This procedure is called by the traversal algorithms in order to avoid - search and deadlocks during proof reconstruciton. - - 3) A permutation-based proof transformation for converting "LJmc" proofs - into "LJ" proofs. - This procedure is called by-need, whenever the direct reconstruction - of "LJ" proofs from matrix proofs fails. - - - - - Literature: - ========== - - JProver system description was presented at CADE 2001: - @InProceedings{inp:Schmitt+01a, - author = "Stephan Schmitt and Lori Lorigo and Christoph Kreitz and - Alexey Nogin", - title = "{{\sf JProver}}: Integrating Connection-based Theorem - Proving into Interactive Proof Assistants", - booktitle = "International Joint Conference on Automated Reasoning", - year = "2001", - editor = "R. Gore and A. Leitsch and T. Nipkow", - volume = 2083, - series = LNAI, - pages = "421--426", - publisher = SPRINGER, - language = English, - where = OWN, - } - - The implementation of JProver is based on the following publications: - - - - Slides of PRL-seminar talks: - --------------------------- - - An Efficient Refiner for First-order Intuitionistic Logic - - http://www.cs.cornell.edu/Nuprl/PRLSeminar/PRLSeminar99_00/schmitt/feb28.html - - - An Efficient Refiner for First-order Intuitionistic Logic (Part II) - - http://www.cs.cornell.edu/Nuprl/PRLSeminar/PRLSeminar99_00/schmitt/may22.html - - - - Proof search: - ------------- - - -[1] - @InProceedings{inp:OttenKreitz96b, - author = "J.~Otten and C.~Kreitz", - title = "A uniform proof procedure for classical and - non-classical logics", - booktitle = "Proceedings of the 20$^{th}$ German Annual Conference on - Artificial Intelligence", - year = "1996", - editor = "G.~G{\"o}rz and S.~H{\"o}lldobler", - number = "1137", - series = LNAI, - pages = "307--319", - publisher = SPRINGER - } - - -[2] - @Article{ar:KreitzOtten99, - author = "C.~Kreitz and J.~Otten", - title = "Connection-based theorem proving in classical and - non-classical logics", - journal = "Journal for Universal Computer Science, - Special Issue on Integration of Deductive Systems", - year = "1999", - volume = "5", - number = "3", - pages = "88--112" - } - - - - - Special string unifiation procedure: - ------------------------------------ - - -[3] - @InProceedings{inp:OttenKreitz96a, - author = "J.~Otten and C.~Kreitz", - titl = "T-string-unification: unifying prefixes in - non-classical proof methods", - booktitle = "Proceedings of the 5$^{th}$ Workshop on Theorem Proving - with Analytic Tableaux and Related Methods", - year = 1996, - editor = "U.~Moscato", - number = "1071", - series = LNAI, - pages = "244--260", - publisher = SPRINGER, - month = "May " - } - - - - Proof reconstruction: Uniform traversal algorithm - ------------------------------------------------- - - -[4] - @InProceedings{inp:SchmittKreitz96a, - author = "S.~Schmitt and C.~Kreitz", - title = "Converting non-classical matrix proofs into - sequent-style systems", - booktitle = "Proceedings of the 13$^t{}^h$ Conference on - Automated Deduction", - editor = M.~A.~McRobbie and J.~K.~Slaney", - number = "1104", - series = LNAI, - pages = "418--432", - year = "1996", - publisher = SPRINGER, - month = "July/August" - } - - -[5] - @Article{ar:KreitzSchmitt00, - author = "C.~Kreitz and S.~Schmitt", - title = "A uniform procedure for converting matrix proofs - into sequent-style systems", - journal = "Journal of Information and Computation", - year = "2000", - note = "(to appear)" - } - - -[6] - @Book{bo:Schmitt00, - author = "S.~Schmitt", - title = "Proof reconstruction in classical and non-classical logics", - year = "2000", - publisher = "Infix", - series = "Dissertationen zur K{\"u}nstlichen Intelleigenz", - number = "(to appear)", - note = "(Ph.{D}.~{T}hesis, Technische Universit{\"a}t Darmstadt, - FG Intellektik, Germany, 1999)" - } - - The traversal algorithm is presented in the Chapters 2 and 3 of my thesis. - The thesis will be made available for the Department through Christoph Kreitz, - Upson 4159, kreitz@cs.cornell.edu - - - - - Proof reconstruction: Complete redundancy deletion - -------------------------------------------------- - - -[7] - @Book{bo:Schmitt00, - author = "S.~Schmitt", - title = "Proof reconstruction in classical and non-classical logics", - year = "2000", - publisher = "Infix", - series = "Dissertationen zur K{\"u}nstlichen Intelleigenz", - note = "(Ph.{D}.~{T}hesis, Technische Universit{\"a}t Darmstadt, - FG Intellektik, Germany, 1999)" - note = "(to appear)", - - } - - The integration of proof knowledge and complete redundancy deletion is presented - in Chapter 4 of my thesis. - - -[8] - @InProceedings{inp:Schmitt00, - author = "S.~Schmitt", - title = "A tableau-like representation framework for efficient - proof reconstruction", - booktitle = "Proceedings of the International Conference on Theorem Proving - with Analytic Tableaux and Related Methods", - year = "2000", - series = LNAI, - publisher = SPRINGER, - month = "June" - note = "(to appear)", - } - - - - - Proof Reconstruction: Permutation-based poof transformations "LJ" -> "LJmc" - --------------------------------------------------------------------------- - - -[9] - @InProceedings{inp:EglySchmitt98, - author = "U.~Egly and S.~Schmitt", - title = "Intuitionistic proof transformations and their - application to constructive program synthesis", - booktitle = "Proceedings of the 4$^{th}$ International Conference - on Artificial Intelligence and Symbolic Computation", - year = "1998", - editor = "J.~Calmet and J.~Plaza", - number = "1476", - series = LNAI, - pages = "132--144", - publisher = SPRINGER, - month = "September" - } - - -[10] - @Article{ar:EglySchmitt99, - author = "U.~Egly and S.~Schmitt", - title = "On intuitionistic proof transformations, their - complexity, and application to constructive program synthesis", - journal = "Fundamenta Informaticae, - Special Issue: Symbolic Computation and Artificial Intelligence", - year = "1999", - volume = "39", - number = "1--2", - pages = "59--83" - } -*) - -(*: open Refiner.Refiner -open Refiner.Refiner.Term -open Refiner.Refiner.TermType -open Refiner.Refiner.TermSubst - -open Jlogic_sig -:*) - -open Jterm -open Opname -open Jlogic - -val ruletable : rule -> string - -module JProver(JLogic: JLogicSig) : -sig - val test : term -> string -> string -> unit - - (* Procedure call: test conclusion logic calculus - - test is applied to a first-order formula. The output is some - formatted sequent proof for test / debugging purposes. - - The arguments for test are as follows: - - logic = "C"|"J" - i.e. first-order classical logic or first-order intuitionistic logic - - calculus = "LK"|"LJ"|"LJmc" - i.e. "LK" for classical logic "C", and either Gentzen's single conclusioned - calculus "LJ" or Fittings multiply-conclusioned calculus "LJmc" for - intuitionistic logic "J". - - term = first-order formula representing the proof goal. - *) - - - - val seqtest : term -> string -> string -> unit - - (* seqtest procedure is for debugging purposes only *) - - - val gen_prover : int option -> string -> string -> term list -> term list -> JLogic.inference - - (* Procedure call: gen_prover mult_limit logic calculus hypothesis conclusion - - The arguments for gen_prover are as follows: - - mult_limit - maximal multiplicity to try, None for unlimited - - logic = same as in test - - calculus = same as in test - - hypothesis = list of first-order terms forming the antecedent of the input sequent - - conclusion = list of first-order terms forming the succedent of the input sequent - This list should contain only one element if logic = "J" and calculus = "LJ". - *) - - - val prover : int option -> term list -> term -> JLogic.inference - - (* Procedure call: gen_prover mult_limit "J" "LJ" hyps [concl] - - prover provides the first-order refiner for NuPRL, using - a single concluisoned succedent [concl] in the sequent. - The result is a sequent proof in the single-conclusioned calculus "LJ". - *) -end diff --git a/contrib/jprover/jlogic.ml b/contrib/jprover/jlogic.ml deleted file mode 100644 index c074e93e..00000000 --- a/contrib/jprover/jlogic.ml +++ /dev/null @@ -1,106 +0,0 @@ -open Opname -open Jterm - -type rule = - | Ax | Andr | Andl | Orr | Orr1 | Orr2 | Orl | Impr | Impl | Negr | Negl - | Allr | Alll| Exr | Exl | Fail | Falsel | Truer - -let ruletable = function - | Fail -> "Fail" - | Ax -> "Ax" - | Negl -> "Negl" - | Negr -> "Negr" - | Andl -> "Andl" - | Andr -> "Andr" - | Orl -> "Orl" - | Orr -> "Orr" - | Orr1 -> "Orr1" - | Orr2 -> "Orr2" - | Impl -> "Impl" - | Impr -> "Impr" - | Exl -> "Exl" - | Exr -> "Exr" - | Alll -> "Alll" - | Allr -> "Allr" - | Falsel -> "Falsel" - | Truer -> "Truer" - -module type JLogicSig = -sig - (* understanding the input *) - val is_all_term : term -> bool - val dest_all : term -> string * term * term - val is_exists_term : term -> bool - val dest_exists : term -> string * term * term - val is_and_term : term -> bool - val dest_and : term -> term * term - val is_or_term : term -> bool - val dest_or : term -> term * term - val is_implies_term : term -> bool - val dest_implies : term -> term * term - val is_not_term : term -> bool - val dest_not : term -> term - - (* processing the output *) - type inf_step = rule * (string * term) * (string * term) - type inference = inf_step list -(* type inference *) - val empty_inf : inference - val append_inf : inference -> (string * term) -> (string * term) -> rule -> inference - val print_inf : inference -> unit -end;; - -(* Copy from [term_op_std.ml]: *) - - let rec print_address int_list = - match int_list with - | [] -> - Format.print_string "" - | hd::rest -> - begin - Format.print_int hd; - print_address rest - end - -module JLogic: JLogicSig = -struct - let is_all_term = Jterm.is_all_term - let dest_all = Jterm.dest_all - let is_exists_term = Jterm.is_exists_term - let dest_exists = Jterm.dest_exists - let is_and_term = Jterm.is_and_term - let dest_and = Jterm.dest_and - let is_or_term = Jterm.is_or_term - let dest_or = Jterm.dest_or - let is_implies_term = Jterm.is_implies_term - let dest_implies = Jterm.dest_implies - let is_not_term = Jterm.is_not_term - let dest_not = Jterm.dest_not - - type inf_step = rule * (string * term) * (string * term) - type inference = inf_step list - - let empty_inf = [] - let append_inf inf t1 t2 rule = - (rule, t1, t2)::inf - - let rec print_inf inf = - match inf with - | [] -> print_string "."; Format.print_flush () - | (rule, (n1,t1), (n2,t2))::d -> - print_string (ruletable rule); - print_string (":("^n1^":"); - print_term stdout t1; - print_string (","^n2^":"); - print_term stdout t2; - print_string ")\n"; - print_inf d -end;; - -let show_loading s = print_string s -type my_Debug = { mutable debug_name: string; - mutable debug_description: string; - debug_value: bool - } - -let create_debug x = ref false diff --git a/contrib/jprover/jlogic.mli b/contrib/jprover/jlogic.mli deleted file mode 100644 index a9079791..00000000 --- a/contrib/jprover/jlogic.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* The interface to manipulate [jterms], which is - extracted and modified from Meta-Prl. *) - -type rule = - Ax | Andr | Andl | Orr | Orr1 | Orr2 | Orl | Impr | Impl | Negr | Negl - | Allr | Alll| Exr | Exl | Fail | Falsel | Truer - -module type JLogicSig = - sig - val is_all_term : Jterm.term -> bool - val dest_all : Jterm.term -> string * Jterm.term * Jterm.term - val is_exists_term : Jterm.term -> bool - val dest_exists : Jterm.term -> string * Jterm.term * Jterm.term - val is_and_term : Jterm.term -> bool - val dest_and : Jterm.term -> Jterm.term * Jterm.term - val is_or_term : Jterm.term -> bool - val dest_or : Jterm.term -> Jterm.term * Jterm.term - val is_implies_term : Jterm.term -> bool - val dest_implies : Jterm.term -> Jterm.term * Jterm.term - val is_not_term : Jterm.term -> bool - val dest_not : Jterm.term -> Jterm.term - type inf_step = rule * (string * Jterm.term) * (string * Jterm.term) - type inference = inf_step list - val empty_inf : inference - val append_inf : - inference -> (string * Jterm.term) -> (string * Jterm.term) -> rule -> inference - val print_inf : inference -> unit - end - -module JLogic : JLogicSig - -val show_loading : string -> unit - -type my_Debug = { - mutable debug_name : string; - mutable debug_description : string; - debug_value : bool; -} -val create_debug : 'a -> bool ref -val ruletable : rule -> string diff --git a/contrib/jprover/jprover.ml4 b/contrib/jprover/jprover.ml4 deleted file mode 100644 index 5fd763c3..00000000 --- a/contrib/jprover/jprover.ml4 +++ /dev/null @@ -1,554 +0,0 @@ -(*i camlp4deps: "parsing/grammar.cma" i*) - -open Jlogic - -module JA = Jall -module JT = Jterm -module T = Tactics -module TCL = Tacticals -module TM = Tacmach -module N = Names -module PT = Proof_type -module HT = Hiddentac -module PA = Pattern -module HP = Hipattern -module TR = Term -module PR = Printer -module RO = Reductionops -module UT = Util -module RA = Rawterm - -module J=JA.JProver(JLogic) (* the JProver *) - -(*i -module NO = Nameops -module TO = Termops -module RE = Reduction -module CL = Coqlib -module ID = Inductiveops -module CV = Clenv -module RF = Refiner -i*) - -(* Interface to JProver: *) -(* type JLogic.inf_step = rule * (string * Jterm.term) * (string * Jterm.term) *) -type jp_inf_step = JLogic.inf_step -type jp_inference = JLogic.inference (* simply a list of [inf_step] *) - -(* Definitions for rebuilding proof tree from JProver: *) -(* leaf, one-branch, two-branch, two-branch, true, false *) -type jpbranch = JP0 | JP1 | JP2 | JP2' | JPT | JPF -type jptree = | JPempty (* empty tree *) - | JPAx of jp_inf_step (* Axiom node *) - | JPA of jp_inf_step * jptree - | JPB of jp_inf_step * jptree * jptree - -(* Private debugging tools: *) -(*i*) -let mbreak s = Format.print_flush (); print_string ("-break at: "^s); - Format.print_flush (); let _ = input_char stdin in () -(*i*) -let jp_error re = raise (JT.RefineError ("jprover", JT.StringError re)) - -(* print Coq constructor *) -let print_constr ct = Pp.ppnl (PR.pr_lconstr ct); Format.print_flush () - -let rec print_constr_list = function - | [] -> () - | ct::r -> print_constr ct; print_constr_list r - -let print_constr_pair op c1 c2 = - print_string (op^"("); - print_constr c1; - print_string ","; - print_constr c2; - print_string ")\n" - - -(* Parsing modules for Coq: *) -(* [is_coq_???] : testing functions *) -(* [dest_coq_???] : destructors *) - -let is_coq_true ct = (HP.is_unit_type ct) && not (HP.is_equation ct) - -let is_coq_false = HP.is_empty_type - -(* return two subterms *) -let dest_coq_and ct = - match (HP.match_with_conjunction ct) with - | Some (hdapp,args) -> -(*i print_constr hdapp; print_constr_list args; i*) - begin - match args with - | s1::s2::[] -> -(*i print_constr_pair "and" s1 s2; i*) - (s1,s2) - | _ -> jp_error "dest_coq_and" - end - | None -> jp_error "dest_coq_and" - -let is_coq_or = HP.is_disjunction - -(* return two subterms *) -let dest_coq_or ct = - match (HP.match_with_disjunction ct) with - | Some (hdapp,args) -> -(*i print_constr hdapp; print_constr_list args; i*) - begin - match args with - | s1::s2::[] -> -(*i print_constr_pair "or" s1 s2; i*) - (s1,s2) - | _ -> jp_error "dest_coq_or" - end - | None -> jp_error "dest_coq_or" - -let is_coq_not = HP.is_nottype - -let dest_coq_not ct = - match (HP.match_with_nottype ct) with - | Some (hdapp,arg) -> -(*i print_constr hdapp; print_constr args; i*) -(*i print_string "not "; - print_constr arg; i*) - arg - | None -> jp_error "dest_coq_not" - - -let is_coq_impl ct = - match TR.kind_of_term ct with - | TR.Prod (_,_,b) -> (not (Termops.dependent (TR.mkRel 1) b)) - | _ -> false - - -let dest_coq_impl c = - match TR.kind_of_term c with - | TR.Prod (_,b,c) -> -(*i print_constr_pair "impl" b c; i*) - (b, c) - | _ -> jp_error "dest_coq_impl" - -(* provide new variables for renaming of universal variables *) -let new_counter = - let ctr = ref 0 in - fun () -> incr ctr;!ctr - -(* provide new symbol name for unknown Coq constructors *) -let new_ecounter = - let ectr = ref 0 in - fun () -> incr ectr;!ectr - -(* provide new variables for address naming *) -let new_acounter = - let actr = ref 0 in - fun () -> incr actr;!actr - -let is_coq_forall ct = - match TR.kind_of_term (RO.whd_betaiota ct) with - | TR.Prod (_,_,b) -> Termops.dependent (TR.mkRel 1) b - | _ -> false - -(* return the bounded variable (as a string) and the bounded term *) -let dest_coq_forall ct = - match TR.kind_of_term (RO.whd_betaiota ct) with - | TR.Prod (_,_,b) -> - let x ="jp_"^(string_of_int (new_counter())) in - let v = TR.mkVar (N.id_of_string x) in - let c = TR.subst1 v b in (* substitute de Bruijn variable by [v] *) -(*i print_constr_pair "forall" v c; i*) - (x, c) - | _ -> jp_error "dest_coq_forall" - - -(* Apply [ct] to [t]: *) -let sAPP ct t = - match TR.kind_of_term (RO.whd_betaiota ct) with - | TR.Prod (_,_,b) -> - let c = TR.subst1 t b in - c - | _ -> jp_error "sAPP" - - -let is_coq_exists ct = - if not (HP.is_conjunction ct) then false - else let (hdapp,args) = TR.decompose_app ct in - match args with - | _::la::[] -> - begin - try - match TR.destLambda la with - | (N.Name _,_,_) -> true - | _ -> false - with _ -> false - end - | _ -> false - -(* return the bounded variable (as a string) and the bounded term *) -let dest_coq_exists ct = - let (hdapp,args) = TR.decompose_app ct in - match args with - | _::la::[] -> - begin - try - match TR.destLambda la with - | (N.Name x,t1,t2) -> - let v = TR.mkVar x in - let t3 = TR.subst1 v t2 in -(*i print_constr_pair "exists" v t3; i*) - (N.string_of_id x, t3) - | _ -> jp_error "dest_coq_exists" - with _ -> jp_error "dest_coq_exists" - end - | _ -> jp_error "dest_coq_exists" - - -let is_coq_and ct = - if (HP.is_conjunction ct) && not (is_coq_exists ct) - && not (is_coq_true ct) then true - else false - - -(* Parsing modules: *) - -let jtbl = Hashtbl.create 53 (* associate for unknown Coq constr. *) -let rtbl = Hashtbl.create 53 (* reverse table of [jtbl] *) - -let dest_coq_symb ct = - N.string_of_id (TR.destVar ct) - -(* provide new names for unknown Coq constr. *) -(* [ct] is the unknown constr., string [s] is appended to the name encoding *) -let create_coq_name ct s = - try - Hashtbl.find jtbl ct - with Not_found -> - let t = ("jp_"^s^(string_of_int (new_ecounter()))) in - Hashtbl.add jtbl ct t; - Hashtbl.add rtbl t ct; - t - -let dest_coq_app ct s = - let (hd, args) = TR.decompose_app ct in -(*i print_constr hd; - print_constr_list args; i*) - if TR.isVar hd then - (dest_coq_symb hd, args) - else (* unknown constr *) - (create_coq_name hd s, args) - -let rec parsing2 c = (* for function symbols, variables, constants *) - if (TR.isApp c) then (* function symbol? *) - let (f,args) = dest_coq_app c "fun_" in - JT.fun_ f (List.map parsing2 args) - else if TR.isVar c then (* identifiable variable or constant *) - JT.var_ (dest_coq_symb c) - else (* unknown constr *) - JT.var_ (create_coq_name c "var_") - -(* the main parsing function *) -let rec parsing c = - let ct = Reduction.whd_betadeltaiota (Global.env ()) c in -(* let ct = Reduction.whd_betaiotazeta (Global.env ()) c in *) - if is_coq_true ct then - JT.true_ - else if is_coq_false ct then - JT.false_ - else if is_coq_not ct then - JT.not_ (parsing (dest_coq_not ct)) - else if is_coq_impl ct then - let (t1,t2) = dest_coq_impl ct in - JT.imp_ (parsing t1) (parsing t2) - else if is_coq_or ct then - let (t1,t2) = dest_coq_or ct in - JT.or_ (parsing t1) (parsing t2) - else if is_coq_and ct then - let (t1,t2) = dest_coq_and ct in - JT.and_ (parsing t1) (parsing t2) - else if is_coq_forall ct then - let (v,t) = dest_coq_forall ct in - JT.forall v (parsing t) - else if is_coq_exists ct then - let (v,t) = dest_coq_exists ct in - JT.exists v (parsing t) - else if TR.isApp ct then (* predicate symbol with arguments *) - let (p,args) = dest_coq_app ct "P_" in - JT.pred_ p (List.map parsing2 args) - else if TR.isVar ct then (* predicate symbol without arguments *) - let p = dest_coq_symb ct in - JT.pred_ p [] - else (* unknown predicate *) - JT.pred_ (create_coq_name ct "Q_") [] - -(*i - print_string "??";print_constr ct; - JT.const_ ("err_"^(string_of_int (new_ecounter()))) -i*) - - -(* Translate JProver terms into Coq constructors: *) -(* The idea is to retrieve it from [rtbl] if it exists indeed, otherwise - create one. *) -let rec constr_of_jterm t = - if (JT.is_var_term t) then (* a variable *) - let v = JT.dest_var t in - try - Hashtbl.find rtbl v - with Not_found -> TR.mkVar (N.id_of_string v) - else if (JT.is_fun_term t) then (* a function symbol *) - let (f,ts) = JT.dest_fun t in - let f' = try Hashtbl.find rtbl f with Not_found -> TR.mkVar (N.id_of_string f) in - TR.mkApp (f', Array.of_list (List.map constr_of_jterm ts)) - else jp_error "constr_of_jterm" - - -(* Coq tactics for Sequent Calculus LJ: *) -(* Note that for left-rule a name indicating the being applied rule - in Coq's Hints is required; for right-rule a name is also needed - if it will pass some subterm to the left-hand side. - However, all of these can be computed by the path [id] of the being - applied rule. -*) - -let assoc_addr = Hashtbl.create 97 - -let short_addr s = - let ad = - try - Hashtbl.find assoc_addr s - with Not_found -> - let t = ("jp_H"^(string_of_int (new_acounter()))) in - Hashtbl.add assoc_addr s t; - t - in - N.id_of_string ad - -(* and-right *) -let dyn_andr = - T.split RA.NoBindings - -(* For example, the following implements the [and-left] rule: *) -let dyn_andl id = (* [id1]: left child; [id2]: right child *) - let id1 = (short_addr (id^"_1")) and id2 = (short_addr (id^"_2")) in - (TCL.tclTHEN (T.simplest_elim (TR.mkVar (short_addr id))) (T.intros_using [id1;id2])) - -let dyn_orr1 = - T.left RA.NoBindings - -let dyn_orr2 = - T.right RA.NoBindings - -let dyn_orl id = - let id1 = (short_addr (id^"_1")) and id2 = (short_addr (id^"_2")) in - (TCL.tclTHENS (T.simplest_elim (TR.mkVar (short_addr id))) - [T.intro_using id1; T.intro_using id2]) - -let dyn_negr id = - let id1 = id^"_1_1" in - HT.h_intro (short_addr id1) - -let dyn_negl id = - T.simplest_elim (TR.mkVar (short_addr id)) - -let dyn_impr id = - let id1 = id^"_1_1" in - HT.h_intro (short_addr id1) - -let dyn_impl id gl = - let t = TM.pf_get_hyp_typ gl (short_addr id) in - let ct = Reduction.whd_betadeltaiota (Global.env ()) t in (* unfolding *) - let (_,b) = dest_coq_impl ct in - let id2 = (short_addr (id^"_1_2")) in - (TCL.tclTHENLAST - (TCL.tclTHENS (T.cut b) [T.intro_using id2;TCL.tclIDTAC]) - (T.apply_term (TR.mkVar (short_addr id)) - [TR.mkMeta (Evarutil.new_meta())])) gl - -let dyn_allr c = (* [c] must be an eigenvariable which replaces [v] *) - HT.h_intro (N.id_of_string c) - -(* [id2] is the path of the instantiated term for [id]*) -let dyn_alll id id2 t gl = - let id' = short_addr id in - let id2' = short_addr id2 in - let ct = TM.pf_get_hyp_typ gl id' in - let ct' = Reduction.whd_betadeltaiota (Global.env ()) ct in (* unfolding *) - let ta = sAPP ct' t in - TCL.tclTHENS (T.cut ta) [T.intro_using id2'; T.apply (TR.mkVar id')] gl - -let dyn_exl id id2 c = (* [c] must be an eigenvariable *) - (TCL.tclTHEN (T.simplest_elim (TR.mkVar (short_addr id))) - (T.intros_using [(N.id_of_string c);(short_addr id2)])) - -let dyn_exr t = - T.one_constructor 1 (RA.ImplicitBindings [t]) - -let dyn_falsel = dyn_negl - -let dyn_truer = - T.one_constructor 1 RA.NoBindings - -(* Do the proof by the guidance of JProver. *) - -let do_one_step inf = - let (rule, (s1, t1), (s2, t2)) = inf in - begin -(*i if not (Jterm.is_xnil_term t2) then - begin - print_string "1: "; JT.print_term stdout t2; print_string "\n"; - print_string "2: "; print_constr (constr_of_jterm t2); print_string "\n"; - end; -i*) - match rule with - | Andl -> dyn_andl s1 - | Andr -> dyn_andr - | Orl -> dyn_orl s1 - | Orr1 -> dyn_orr1 - | Orr2 -> dyn_orr2 - | Impr -> dyn_impr s1 - | Impl -> dyn_impl s1 - | Negr -> dyn_negr s1 - | Negl -> dyn_negl s1 - | Allr -> dyn_allr (JT.dest_var t2) - | Alll -> dyn_alll s1 s2 (constr_of_jterm t2) - | Exr -> dyn_exr (Tactics.inj_open (constr_of_jterm t2)) - | Exl -> dyn_exl s1 s2 (JT.dest_var t2) - | Ax -> T.assumption (*i TCL.tclIDTAC i*) - | Truer -> dyn_truer - | Falsel -> dyn_falsel s1 - | _ -> jp_error "do_one_step" - (* this is impossible *) - end -;; - -(* Parameter [tr] is the reconstucted proof tree from output of JProver. *) -let do_coq_proof tr = - let rec rec_do trs = - match trs with - | JPempty -> TCL.tclIDTAC - | JPAx h -> do_one_step h - | JPA (h, t) -> TCL.tclTHEN (do_one_step h) (rec_do t) - | JPB (h, left, right) -> TCL.tclTHENS (do_one_step h) [rec_do left; rec_do right] - in - rec_do tr - - -(* Rebuild the proof tree from the output of JProver: *) - -(* Since some universal variables are not necessarily first-order, - lazy substitution may happen. They are recorded in [rtbl]. *) -let reg_unif_subst t1 t2 = - let (v,_,_) = JT.dest_all t1 in - Hashtbl.add rtbl v (TR.mkVar (N.id_of_string (JT.dest_var t2))) - -let count_jpbranch one_inf = - let (rule, (_, t1), (_, t2)) = one_inf in - begin - match rule with - | Ax -> JP0 - | Orr1 | Orr2 | Negl | Impr | Alll | Exr | Exl -> JP1 - | Andr | Orl -> JP2 - | Negr -> if (JT.is_true_term t1) then JPT else JP1 - | Andl -> if (JT.is_false_term t1) then JPF else JP1 - | Impl -> JP2' (* reverse the sons of [Impl] since [dyn_impl] reverses them *) - | Allr -> reg_unif_subst t1 t2; JP1 - | _ -> jp_error "count_jpbranch" - end - -let replace_by r = function - (rule, a, b) -> (r, a, b) - -let rec build_jptree inf = - match inf with - | [] -> ([], JPempty) - | h::r -> - begin - match count_jpbranch h with - | JP0 -> (r,JPAx h) - | JP1 -> let (r1,left) = build_jptree r in - (r1, JPA(h, left)) - | JP2 -> let (r1,left) = build_jptree r in - let (r2,right) = build_jptree r1 in - (r2, JPB(h, left, right)) - | JP2' -> let (r1,left) = build_jptree r in (* for [Impl] *) - let (r2,right) = build_jptree r1 in - (r2, JPB(h, right, left)) - | JPT -> let (r1,left) = build_jptree r in (* right True *) - (r1, JPAx (replace_by Truer h)) - | JPF -> let (r1,left) = build_jptree r in (* left False *) - (r1, JPAx (replace_by Falsel h)) - end - - -(* The main function: *) -(* [limits] is the multiplicity limit. *) -let jp limits gls = - let concl = TM.pf_concl gls in - let ct = concl in -(*i print_constr ct; i*) - Hashtbl.clear jtbl; (* empty the hash tables *) - Hashtbl.clear rtbl; - Hashtbl.clear assoc_addr; - let t = parsing ct in -(*i JT.print_term stdout t; i*) - try - let p = (J.prover limits [] t) in -(*i print_string "\n"; - JLogic.print_inf p; i*) - let (il,tr) = build_jptree p in - if (il = []) then - begin - Pp.msgnl (Pp.str "Proof is built."); - do_coq_proof tr gls - end - else UT.error "Cannot reconstruct proof tree from JProver." - with e -> Pp.msgnl (Pp.str "JProver fails to prove this:"); - JT.print_error_msg e; - UT.error "JProver terminated." - -(* an unfailed generalization procedure *) -let non_dep_gen b gls = - let concl = TM.pf_concl gls in - if (not (Termops.dependent b concl)) then - T.generalize [b] gls - else - TCL.tclIDTAC gls - -let rec unfail_gen = function - | [] -> TCL.tclIDTAC - | h::r -> - TCL.tclTHEN - (TCL.tclORELSE (non_dep_gen h) (TCL.tclIDTAC)) - (unfail_gen r) - -(* -(* no argument, which stands for no multiplicity limit *) -let jp gls = - let ls = List.map (fst) (TM.pf_hyps_types gls) in -(*i T.generalize (List.map TR.mkVar ls) gls i*) - (* generalize the context *) - TCL.tclTHEN (TCL.tclTRY T.red_in_concl) - (TCL.tclTHEN (unfail_gen (List.map TR.mkVar ls)) - (jp None)) gls -*) -(* -let dyn_jp l gls = - assert (l = []); - jp -*) - -(* one optional integer argument for the multiplicity *) -let jpn n gls = - let ls = List.map (fst) (TM.pf_hyps_types gls) in - TCL.tclTHEN (TCL.tclTRY T.red_in_concl) - (TCL.tclTHEN (unfail_gen (List.map TR.mkVar ls)) - (jp n)) gls - -TACTIC EXTEND jprover - [ "jp" natural_opt(n) ] -> [ jpn n ] -END - -(* -TACTIC EXTEND Andl - [ "Andl" ident(id)] -> [ ... (Andl id) ... ]. -END -*) diff --git a/contrib/jprover/jterm.ml b/contrib/jprover/jterm.ml deleted file mode 100644 index 7fc923a5..00000000 --- a/contrib/jprover/jterm.ml +++ /dev/null @@ -1,872 +0,0 @@ -open Printf -open Opname -open List - -(* Definitions of [jterm]: *) -type param = param' - and operator = operator' - and term = term' - and bound_term = bound_term' - and param' = - | Number of int - | String of string - | Token of string - | Var of string - | ParamList of param list - and operator' = { op_name : opname; op_params : param list } - and term' = { term_op : operator; term_terms : bound_term list } - and bound_term' = { bvars : string list; bterm : term } -;; - -(* Debugging tools: *) -(*i*) -let mbreak s = Format.print_flush (); print_string ("-break at: "^s); - Format.print_flush (); let _ = input_char stdin in () -(*i*) - -type error_msg = - | TermMatchError of term * string - | StringError of string - -exception RefineError of string * error_msg - -let ref_raise = function - | RefineError(s,e) -> raise (RefineError(s,e)) - | _ -> raise (RefineError ("Jterm", StringError "unexpected error")) - -(* Printing utilities: *) - -let fprint_str ostream s = - let _ = fprintf ostream "%s." s in ostream - -let fprint_str_list ostream sl = - ignore (List.fold_left fprint_str ostream sl); - Format.print_flush () - -let fprint_opname ostream = function - { opname_token= tk; opname_name = sl } -> - fprint_str_list ostream sl - -let rec fprint_param ostream = function - | Number n -> fprintf ostream " %d " n - | String s -> fprint_str_list ostream [s] - | Token t -> fprint_str_list ostream [t] - | Var v -> fprint_str_list ostream [v] - | ParamList ps -> fprint_param_list ostream ps -and fprint_param_list ostream = function - | [] -> () - | param::r -> fprint_param ostream param; - fprint_param_list ostream r -;; - -let print_strs = fprint_str_list stdout - - -(* Interface to [Jall.ml]: *) -(* It is extracted from Meta-Prl's standard implementation. *) -(*c begin of the extraction *) - -type term_subst = (string * term) list -let mk_term op bterms = { term_op = op; term_terms = bterms } -let make_term x = x (* external [make_term : term' -> term] = "%identity" *) -let dest_term x = x (* external [dest_term : term -> term'] = "%identity" *) -let mk_op name params = - { op_name = name; op_params = params } - -let make_op x = x (* external [make_op : operator' -> operator] = "%identity" *) -let dest_op x = x (* external [dest_op : operator -> operator'] = "%identity" *) -let mk_bterm bvars term = { bvars = bvars; bterm = term } -let make_bterm x = x (* external [make_bterm : bound_term' -> bound_term] = "%identity" *) -let dest_bterm x = x (* external [dest_bterm : bound_term -> bound_term'] = "%identity" *) -let make_param x = x (* external [make_param : param' -> param] = "%identity" *) -let dest_param x = x (* external [dest_param : param -> param'] = "%identity" *) - -(* - * Operator names. - *) -let opname_of_term = function - { term_op = { op_name = name } } -> - name - -(* - * Get the subterms. - * None of the subterms should be bound. - *) -let subterms_of_term t = - List.map (fun { bterm = t } -> t) t.term_terms - -let subterm_count { term_terms = terms } = - List.length terms - -let subterm_arities { term_terms = terms } = - List.map (fun { bvars = vars } -> List.length vars) terms - -(* - * Manifest terms are injected into the "perv" module. - *) -let xperv = make_opname ["Perv"] -let sequent_opname = mk_opname "sequent" xperv - -(* - * Variables. - *) - -let var_opname = make_opname ["var"] - -(* - * See if a term is a variable. - *) -let is_var_term = function - | { term_op = { op_name = opname; op_params = [Var v] }; - term_terms = [] - } when Opname.eq opname var_opname -> true - | _ -> - false - -(* - * Destructor for a variable. - *) -let dest_var = function - | { term_op = { op_name = opname; op_params = [Var v] }; - term_terms = [] - } when Opname.eq opname var_opname -> v - | t -> - ref_raise(RefineError ("dest_var", TermMatchError (t, "not a variable"))) -(* - * Make a variable. - *) -let mk_var_term v = - { term_op = { op_name = var_opname; op_params = [Var v] }; - term_terms = [] - } - -(* - * Simple terms - *) -(* - * "Simple" terms have no parameters and no binding variables. - *) -let is_simple_term_opname name = function - | { term_op = { op_name = name'; op_params = [] }; - term_terms = bterms - } when Opname.eq name' name -> - let rec aux = function - | { bvars = []; bterm = _ }::t -> aux t - | _::t -> false - | [] -> true - in - aux bterms - | _ -> false - -let mk_any_term op terms = - let aux t = - { bvars = []; bterm = t } - in - { term_op = op; term_terms = List.map aux terms } - -let mk_simple_term name terms = - mk_any_term { op_name = name; op_params = [] } terms - -let dest_simple_term = function - | ({ term_op = { op_name = name; op_params = [] }; - term_terms = bterms - } : term) as t -> - let aux = function - | { bvars = []; bterm = t } -> - t - | _ -> - ref_raise(RefineError ("dest_simple_term", TermMatchError (t, "binding vars exist"))) - in - name, List.map aux bterms - | t -> - ref_raise(RefineError ("dest_simple_term", TermMatchError (t, "params exist"))) - -let dest_simple_term_opname name = function - | ({ term_op = { op_name = name'; op_params = [] }; - term_terms = bterms - } : term) as t -> - if Opname.eq name name' then - let aux = function - | { bvars = []; bterm = t } -> t - | _ -> ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "binding vars exist"))) - in - List.map aux bterms - else - ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "opname mismatch"))) - | t -> - ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "params exist"))) - -(* - * Bound terms. - *) -let mk_simple_bterm bterm = - { bvars = []; bterm = bterm } - -let dest_simple_bterm = function - | { bvars = []; bterm = bterm } -> - bterm - | _ -> - ref_raise(RefineError ("dest_simple_bterm", StringError ("bterm is not simple"))) - -(* Copy from [term_op_std.ml]: *) -(*i modified for Jprover, as a patch... i*) -let mk_string_term opname s = - { term_op = { op_name = opname; op_params = [String s] }; term_terms = [] } - -(*i let mk_string_term opname s = - let new_opname={opname_token=opname.opname_token; opname_name=(List.tl opname.opname_name)@[s]} in - { term_op = { op_name = new_opname; op_params = [String (List.hd opname.opname_name)] }; term_terms = [] } -i*) - -(* Copy from [term_subst_std.ml]: *) - -let rec free_vars_term gvars bvars = function - | { term_op = { op_name = opname; op_params = [Var v] }; term_terms = bterms } when Opname.eq opname var_opname -> - (* This is a variable *) - let gvars' = - if List.mem v bvars or List.mem v gvars then - gvars - else - v::gvars - in - free_vars_bterms gvars' bvars bterms - | { term_terms = bterms } -> - free_vars_bterms gvars bvars bterms - and free_vars_bterms gvars bvars = function - | { bvars = vars; bterm = term}::l -> - let bvars' = vars @ bvars in - let gvars' = free_vars_term gvars bvars' term in - free_vars_bterms gvars' bvars l - | [] -> - gvars - -let free_vars_list = free_vars_term [] [] - - -(* Termop: *) - -let is_no_subterms_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [] - } -> - Opname.eq opname' opname - | _ -> - false - -(* - * Terms with one subterm. - *) -let is_dep0_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = [] }] - } -> Opname.eq opname' opname - | _ -> false - -let mk_dep0_term opname t = - { term_op = { op_name = opname; op_params = [] }; - term_terms = [{ bvars = []; bterm = t }] - } - -let dest_dep0_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = []; bterm = t }] - } when Opname.eq opname' opname -> t - | t -> ref_raise(RefineError ("dest_dep0_term", TermMatchError (t, "not a dep0 term"))) - -(* - * Terms with two subterms. - *) -let is_dep0_dep0_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = [] }; { bvars = [] }] - } -> Opname.eq opname' opname - | _ -> false - -let mk_dep0_dep0_term opname = fun - t1 t2 -> - { term_op = { op_name = opname; op_params = [] }; - term_terms = [{ bvars = []; bterm = t1 }; - { bvars = []; bterm = t2 }] - } - -let dest_dep0_dep0_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = []; bterm = t1 }; - { bvars = []; bterm = t2 }] - } when Opname.eq opname' opname -> t1, t2 - | t -> ref_raise(RefineError ("dest_dep0_dep0_term", TermMatchError (t, "bad arity"))) - -(* - * Bound term. - *) - -let is_dep0_dep1_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = [] }; { bvars = [_] }] - } when Opname.eq opname' opname -> true - | _ -> false - -let is_dep0_dep1_any_term = function - | { term_op = { op_params = [] }; - term_terms = [{ bvars = [] }; { bvars = [_] }] - } -> true - | _ -> false - -let mk_dep0_dep1_term opname = fun - v t1 t2 -> { term_op = { op_name = opname; op_params = [] }; - term_terms = [{ bvars = []; bterm = t1 }; - { bvars = [v]; bterm = t2 }] - } - -let dest_dep0_dep1_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = []; bterm = t1 }; - { bvars = [v]; bterm = t2 }] - } when Opname.eq opname' opname -> v, t1, t2 - | t -> ref_raise(RefineError ("dest_dep0_dep1_term", TermMatchError (t, "bad arity"))) - -let rec smap f = function - | [] -> [] - | (hd::tl) as l -> - let hd' = f hd in - let tl' = smap f tl in - if (hd==hd')&&(tl==tl') then l else hd'::tl' - -let rec try_check_assoc v v' = function - | [] -> raise Not_found - | (v1,v2)::tl -> - begin match v=v1, v'=v2 with - | true, true -> true - | false, false -> try_check_assoc v v' tl - | _ -> false - end - -let rec zip_list l l1 l2 = match (l1,l2) with - | (h1::t1), (h2::t2) -> - zip_list ((h1,h2)::l) t1 t2 - | [], [] -> - l - | _ -> raise (Failure "Term.zip_list") - -let rec assoc_in_range eq y = function - | (_, y')::tl -> - (eq y y') || (assoc_in_range eq y tl) - | [] -> - false - -let rec check_assoc v v' = function - | [] -> v=v' - | (v1,v2)::tl -> - begin match v=v1, v'=v2 with - | true, true -> true - | false, false -> check_assoc v v' tl - | _ -> false - end - -let rec zip a b = match (a,b) with - | (h1::t1), (h2::t2) -> - (h1, h2) :: zip t1 t2 - | [], [] -> - [] - | - _ -> raise (Failure "Term.zip") - -let rec for_all2 f l1 l2 = - match (l1,l2) with - | h1::t1, h2::t2 -> for_all2 f t1 t2 & f h1 h2 - | [], [] -> true - | _ -> false - -let newname v i = - v ^ "_" ^ (string_of_int i) - -let rec new_var v avoid i = - let v' = newname v i in - if avoid v' - then new_var v avoid (succ i) - else v' - -let vnewname v avoid = new_var v avoid 1 - -let rev_mem a b = List.mem b a - -let rec find_index_aux v i = function - | h::t -> - if h = v then - i - else - find_index_aux v (i + 1) t - | [] -> - raise Not_found - -let find_index v l = find_index_aux v 0 l - -let rec remove_elements l1 l2 = - match l1, l2 with - | flag::ft, h::t -> - if flag then - remove_elements ft t - else - h :: remove_elements ft t - | _, l -> - l - -let rec subtract l1 l2 = - match l1 with - | h::t -> - if List.mem h l2 then - subtract t l2 - else - h :: subtract t l2 - | [] -> - [] - -let rec fv_mem fv v = - match fv with - | [] -> false - | h::t -> - List.mem v h || fv_mem t v - -let rec new_vars fv = function - | [] -> [] - | v::t -> - (* Rename the first one, then add it to free vars *) - let v' = vnewname v (fv_mem fv) in - v'::(new_vars ([v']::fv) t) - -let rec fsubtract l = function - | [] -> l - | h::t -> - fsubtract (subtract l h) t - -let add_renames_fv r l = - let rec aux = function - | [] -> l - | v::t -> [v]::(aux t) - in - aux r - -let add_renames_terms r l = - let rec aux = function - | [] -> l - | v::t -> (mk_var_term v)::(aux t) - in - aux r - -(* - * First order simultaneous substitution. - *) -let rec subst_term terms fv vars = function - | { term_op = { op_name = opname; op_params = [Var(v)] }; term_terms = [] } as t - when Opname.eq opname var_opname-> - (* Var case *) - begin - try List.nth terms (find_index v vars) with - Not_found -> - t - end - | { term_op = op; term_terms = bterms } -> - (* Other term *) - { term_op = op; term_terms = subst_bterms terms fv vars bterms } - -and subst_bterms terms fv vars bterms = - (* When subst through bterms, catch binding occurrences *) - let rec subst_bterm = function - | { bvars = []; bterm = term } -> - (* Optimize the common case *) - { bvars = []; bterm = subst_term terms fv vars term } - - | { bvars = bvars; bterm = term } -> - (* First subtract bound instances *) - let flags = List.map (function v -> List.mem v bvars) vars in - let vars' = remove_elements flags vars in - let fv' = remove_elements flags fv in - let terms' = remove_elements flags terms in - - (* If any of the binding variables are free, rename them *) - let renames = subtract bvars (fsubtract bvars fv') in - if renames <> [] then - let fv'' = (free_vars_list term)::fv' in - let renames' = new_vars fv'' renames in - { bvars = subst_bvars renames' renames bvars; - bterm = subst_term - (add_renames_terms renames' terms') - (add_renames_fv renames' fv') - (renames @ vars') - term - } - else - { bvars = bvars; - bterm = subst_term terms' fv' vars' term - } - in - List.map subst_bterm bterms - -and subst_bvars renames' renames bvars = - let subst_bvar v = - try List.nth renames' (find_index v renames) with - Not_found -> v - in - List.map subst_bvar bvars - -let subst term vars terms = - subst_term terms (List.map free_vars_list terms) vars term - -(*i bug!!! in the [term_std] module - let subst1 t var term = - let fv = free_vars_list term in - if List.mem var fv then - subst_term [term] [fv] [var] t - else - t -The following is the correct implementation -i*) - -let subst1 t var term = -if List.mem var (free_vars_list t) then - subst_term [term] [free_vars_list term] [var] t -else - t - -let apply_subst t s = - let vs,ts = List.split s in - subst t vs ts - -let rec equal_params p1 p2 = - match p1, p2 with - | Number n1, Number n2 -> - n1 = n2 - | ParamList pl1, ParamList pl2 -> - List.for_all2 equal_params pl1 pl2 - | _ -> - p1 = p2 - -let rec equal_term vars t t' = - match t, t' with - | { term_op = { op_name = opname1; op_params = [Var v] }; - term_terms = [] - }, - { term_op = { op_name = opname2; op_params = [Var v'] }; - term_terms = [] - } when Opname.eq opname1 var_opname & Opname.eq opname2 var_opname -> - check_assoc v v' vars - | { term_op = { op_name = name1; op_params = params1 }; term_terms = bterms1 }, - { term_op = { op_name = name2; op_params = params2 }; term_terms = bterms2 } -> - (Opname.eq name1 name2) - & (for_all2 equal_params params1 params2) - & (equal_bterms vars bterms1 bterms2) -and equal_bterms vars bterms1 bterms2 = - let equal_bterm = fun - { bvars = bvars1; bterm = term1 } - { bvars = bvars2; bterm = term2 } -> - equal_term (zip_list vars bvars1 bvars2) term1 term2 - in - for_all2 equal_bterm bterms1 bterms2 - - -let alpha_equal t1 t2 = - try equal_term [] t1 t2 with Failure _ -> false - -let var_subst t t' v = - let { term_op = { op_name = opname } } = t' in - let vt = mk_var_term v in - let rec subst_term = function - { term_op = { op_name = opname'; op_params = params }; - term_terms = bterms - } as t -> - (* Check if this is the same *) - if Opname.eq opname' opname & alpha_equal t t' then - vt - else - { term_op = { op_name = opname'; op_params = params }; - term_terms = List.map subst_bterm bterms - } - - and subst_bterm { bvars = vars; bterm = term } = - if List.mem v vars then - let av = vars @ (free_vars_list term) in - let v' = vnewname v (fun v -> List.mem v av) in - let rename var = if var = v then v' else var in - let term = subst1 term v (mk_var_term v') in - { bvars = smap rename vars; bterm = subst_term term } - else - { bvars = vars; bterm = subst_term term } - in - subst_term t - -let xnil_opname = mk_opname "nil" xperv -let xnil_term = mk_simple_term xnil_opname [] -let is_xnil_term = is_no_subterms_term xnil_opname - -(*c End of the extraction from Meta-Prl *) - -(* Huang's modification: *) -let all_opname = make_opname ["quantifier";"all"] -let is_all_term = is_dep0_dep1_term all_opname -let dest_all = dest_dep0_dep1_term all_opname -let mk_all_term = mk_dep0_dep1_term all_opname - -let exists_opname = make_opname ["quantifier";"exst"] -let is_exists_term = is_dep0_dep1_term exists_opname -let dest_exists = dest_dep0_dep1_term exists_opname -let mk_exists_term = mk_dep0_dep1_term exists_opname - -let or_opname = make_opname ["connective";"or"] -let is_or_term = is_dep0_dep0_term or_opname -let dest_or = dest_dep0_dep0_term or_opname -let mk_or_term = mk_dep0_dep0_term or_opname - -let and_opname = make_opname ["connective";"and"] -let is_and_term = is_dep0_dep0_term and_opname -let dest_and = dest_dep0_dep0_term and_opname -let mk_and_term = mk_dep0_dep0_term and_opname - -let cor_opname = make_opname ["connective";"cor"] -let is_cor_term = is_dep0_dep0_term cor_opname -let dest_cor = dest_dep0_dep0_term cor_opname -let mk_cor_term = mk_dep0_dep0_term cor_opname - -let cand_opname = make_opname ["connective";"cand"] -let is_cand_term = is_dep0_dep0_term cand_opname -let dest_cand = dest_dep0_dep0_term cand_opname -let mk_cand_term = mk_dep0_dep0_term cand_opname - -let implies_opname = make_opname ["connective";"=>"] -let is_implies_term = is_dep0_dep0_term implies_opname -let dest_implies = dest_dep0_dep0_term implies_opname -let mk_implies_term = mk_dep0_dep0_term implies_opname - -let iff_opname = make_opname ["connective";"iff"] -let is_iff_term = is_dep0_dep0_term iff_opname -let dest_iff = dest_dep0_dep0_term iff_opname -let mk_iff_term = mk_dep0_dep0_term iff_opname - -let not_opname = make_opname ["connective";"not"] -let is_not_term = is_dep0_term not_opname -let dest_not = dest_dep0_term not_opname -let mk_not_term = mk_dep0_term not_opname - -let var_ = mk_var_term -let fun_opname = make_opname ["function"] -let fun_ f ts = mk_any_term {op_name = fun_opname; op_params = [String f] } ts - -let is_fun_term = function - | { term_op = { op_name = opname; op_params = [String f] }} - when Opname.eq opname fun_opname -> true - | _ -> - false - -let dest_fun = function - | { term_op = { op_name = opname; op_params = [String f] }; term_terms = ts} - when Opname.eq opname fun_opname -> (f, List.map (fun { bterm = t } -> t) ts) - | t -> - ref_raise(RefineError ("dest_fun", TermMatchError (t, "not a function symbol"))) - -let const_ c = fun_ c [] -let is_const_term = function - | { term_op = { op_name = opname; op_params = [String f] }; term_terms = [] } - when Opname.eq opname fun_opname -> true - | _ -> - false - -let dest_const t = - let (n, ts) = dest_fun t in n - -let pred_opname = make_opname ["predicate"] -let pred_ p ts = mk_any_term {op_name = pred_opname; op_params = [String p] } ts - -let not_ = mk_not_term -let and_ = mk_and_term -let or_ = mk_or_term -let imp_ = mk_implies_term -let cand_ = mk_cand_term -let cor_ = mk_cor_term -let iff_ = mk_iff_term -let nil_term = {term_op={op_name=nil_opname; op_params=[]}; term_terms=[] } -let forall v t = mk_all_term v nil_term t -let exists v t= mk_exists_term v nil_term t -let rec wbin op = function - | [] -> raise (Failure "Term.wbin") - | [t] -> t - | t::r -> op t (wbin op r) - -let wand_ = wbin and_ -let wor_ = wbin or_ -let wimp_ = wbin imp_ - -(*i let true_opname = make_opname ["bool";"true"] -let is_true_term = is_no_subterms_term true_opname -let true_ = mk_simple_term true_opname [] -let false_ = not_ true_ - -let is_false_term t = - if is_not_term t then - let t1 = dest_not t in - is_true_term t1 - else - false -i*) - -let dummy_false_ = mk_simple_term (make_opname ["bool";"false"]) [] -let dummy_true_ = mk_simple_term (make_opname ["bool";"true"]) [] -let false_ = and_ (dummy_false_) (not_ dummy_false_) -let true_ = not_ (and_ (dummy_true_) (not_ dummy_true_)) - -let is_false_term t = - if (alpha_equal t false_) then true - else false - -let is_true_term t = - if (alpha_equal t true_) then true - else false - -(* Print a term [t] via the [ostream]: *) -let rec fprint_term ostream t prec = - let l_print op_prec = - if (prec > op_prec) then fprintf ostream "(" in - let r_print op_prec = - if (prec > op_prec) then fprintf ostream ")" in - if is_false_term t then (* false *) - fprint_str_list ostream ["False"] - else if is_true_term t then (* true *) - fprint_str_list ostream ["True"] - else if is_all_term t then (* for all *) - let v, t1, t2 = dest_all t in - fprint_str_list ostream ["A."^v]; - fprint_term ostream t2 4 - else if is_exists_term t then (* exists *) - let v, t1, t2 = dest_exists t in - fprint_str_list ostream ["E."^v]; - fprint_term ostream t2 4 (* implication *) - else if is_implies_term t then - let t1, t2 = dest_implies t in - l_print 0; - fprint_term ostream t1 1; - fprint_str_list ostream ["=>"]; - fprint_term ostream t2 0; - r_print 0 - else if is_and_term t then (* logical and *) - let t1, t2 = dest_and t in - l_print 3; - fprint_term ostream t1 3; - fprint_str_list ostream ["&"]; - fprint_term ostream t2 3; - r_print 3 - else if is_or_term t then (* logical or *) - let t1, t2 = dest_or t in - l_print 2; - fprint_term ostream t1 2; - fprint_str_list ostream ["|"]; - fprint_term ostream t2 2; - r_print 2 - else if is_not_term t then (* logical not *) - let t2 = dest_not t in - fprint_str_list ostream ["~"]; - fprint_term ostream t2 4 (* nil term *) - else if is_xnil_term t then - fprint_str_list ostream ["NIL"] - else match t with (* other cases *) - { term_op = { op_name = opname; op_params = opparm }; term_terms = bterms} -> - if (Opname.eq opname pred_opname) || (Opname.eq opname fun_opname) then - begin - fprint_param_list ostream opparm; - if bterms != [] then - begin - fprintf ostream "("; - fprint_bterm_list ostream prec bterms; - fprintf ostream ")"; - end - end else - begin - fprintf ostream "["; -(* fprint_opname ostream opname; - fprintf ostream ": "; *) - fprint_param_list ostream opparm; - if bterms != [] then - begin - fprintf ostream "("; - fprint_bterm_list ostream prec bterms; - fprintf ostream ")"; - end; - fprintf ostream "]" - end -and fprint_bterm_list ostream prec = function - | [] -> () - | {bvars=bv; bterm=bt}::r -> - fprint_str_list ostream bv; - fprint_term ostream bt prec; - if (r<>[]) then fprint_str_list ostream [","]; - fprint_bterm_list ostream prec r -;; - - -let print_term ostream t = - Format.print_flush (); - fprint_term ostream t 0; - Format.print_flush () - -let print_error_msg = function - | RefineError(s,e) -> print_string ("(module "^s^") "); - begin - match e with - | TermMatchError(t,s) -> print_term stdout t; print_string (s^"\n") - | StringError s -> print_string (s^"\n") - end - | ue -> print_string "Unexpected error for Jp.\n"; - raise ue - - -(* Naive implementation for [jterm] substitution, unification, etc.: *) -let substitute subst term = - apply_subst term subst - -(* A naive unification algorithm: *) -let compsubst subst1 subst2 = - (List.map (fun (v, t) -> (v, substitute subst1 t)) subst2) @ subst1 -;; - -let rec extract_terms = function - | [] -> [] - | h::r -> let {bvars=_; bterm=bt}=h in bt::extract_terms r - -(* Occurs check: *) -let occurs v t = - let rec occur_rec t = - if is_var_term t then v=dest_var t - else let { term_op = _ ; term_terms = bterms} = t in - let sons = extract_terms bterms in - List.exists occur_rec sons - in - occur_rec t - -(* The naive unification algorithm: *) -let rec unify2 (term1,term2) = - if is_var_term term1 then - if equal_term [] term1 term2 then [] - else let v1 = dest_var term1 in - if occurs v1 term2 then raise (RefineError ("unify1", StringError ("1"))) - else [v1,term2] - else if is_var_term term2 then - let v2 = dest_var term2 in - if occurs v2 term1 then raise (RefineError ("unify2", StringError ("2"))) - else [v2,term1] - else - let { term_op = { op_name = opname1; op_params = params1 }; - term_terms = bterms1 - } = term1 - in - let { term_op = { op_name = opname2; op_params = params2 }; - term_terms = bterms2 - } = term2 - in - if Opname.eq opname1 opname2 & params1 = params2 then - let sons1 = extract_terms bterms1 - and sons2 = extract_terms bterms2 in - List.fold_left2 - (fun s t1 t2 -> compsubst - (unify2 (substitute s t1, substitute s t2)) s) - [] sons1 sons2 - else raise (RefineError ("unify3", StringError ("3"))) - -let unify term1 term2 = unify2 (term1, term2) -let unify_mm term1 term2 _ = unify2 (term1, term2) diff --git a/contrib/jprover/jterm.mli b/contrib/jprover/jterm.mli deleted file mode 100644 index 0bc42010..00000000 --- a/contrib/jprover/jterm.mli +++ /dev/null @@ -1,110 +0,0 @@ -(* This module is modified and extracted from Meta-Prl. *) - -(* Definitions of [jterm]: *) -type param = param' -and operator = operator' -and term = term' -and bound_term = bound_term' -and param' = - | Number of int - | String of string - | Token of string - | Var of string - | ParamList of param list -and operator' = { op_name : Opname.opname; op_params : param list; } -and term' = { term_op : operator; term_terms : bound_term list; } -and bound_term' = { bvars : string list; bterm : term; } -type term_subst = (string * term) list - -type error_msg = TermMatchError of term * string | StringError of string - -exception RefineError of string * error_msg - -(* Collect free variables: *) -val free_vars_list : term -> string list - -(* Substitutions: *) -val subst_term : term list -> string list list -> string list -> term -> term -val subst : term -> string list -> term list -> term -val subst1 : term -> string -> term -> term -val var_subst : term -> term -> string -> term -val apply_subst : term -> (string * term) list -> term - -(* Unification: *) -val unify_mm : term -> term -> 'a -> (string * term) list - -val xnil_term : term' - -(* Testing functions: *) -val is_xnil_term : term' -> bool -val is_var_term : term' -> bool -val is_true_term : term' -> bool -val is_false_term : term' -> bool -val is_all_term : term' -> bool -val is_exists_term : term' -> bool -val is_or_term : term' -> bool -val is_and_term : term' -> bool -val is_cor_term : term' -> bool -val is_cand_term : term' -> bool -val is_implies_term : term' -> bool -val is_iff_term : term' -> bool -val is_not_term : term' -> bool -val is_fun_term : term -> bool -val is_const_term : term -> bool - - -(* Constructors for [jterms]: *) -val var_ : string -> term' -val fun_ : string -> term list -> term' -val const_ : string -> term' -val pred_ : string -> term list -> term' -val not_ : term -> term' -val and_ : term -> term -> term' -val or_ : term -> term -> term' -val imp_ : term -> term -> term' -val cand_ : term -> term -> term' -val cor_ : term -> term -> term' -val iff_ : term -> term -> term' -val false_ : term' -val true_ : term' -val nil_term : term' -val forall : string -> term -> term' -val exists : string -> term -> term' - - -(* Destructors for [jterm]: *) -val dest_var : term -> string -val dest_fun : term -> string * term list -val dest_const : term -> string -val dest_not : term -> term -val dest_iff : term -> term * term -val dest_implies : term -> term * term -val dest_cand : term -> term * term -val dest_cor : term -> term * term -val dest_and : term -> term * term -val dest_or : term -> term * term -val dest_exists : term -> string * term * term -val dest_all : term -> string * term * term - -(* Wide-logical connectives: *) -val wand_ : term list -> term -val wor_ : term list -> term -val wimp_ : term list -> term - -(* Printing and debugging tools: *) -val fprint_str_list : out_channel -> string list -> unit -val mbreak : string -> unit -val print_strs : string list -> unit -val print_term : out_channel -> term -> unit -val print_error_msg : exn -> unit - -(* Other exported functions for [jall.ml]: *) -val make_term : 'a -> 'a -val dest_term : 'a -> 'a -val make_op : 'a -> 'a -val dest_op : 'a -> 'a -val make_bterm : 'a -> 'a -val dest_bterm : 'a -> 'a -val dest_param : 'a -> 'a -val mk_var_term : string -> term' -val mk_string_term : Opname.opname -> string -> term' diff --git a/contrib/jprover/jtunify.ml b/contrib/jprover/jtunify.ml deleted file mode 100644 index 91aa6b4b..00000000 --- a/contrib/jprover/jtunify.ml +++ /dev/null @@ -1,507 +0,0 @@ -(* - * Unification procedures for JProver. See jall.mli for more - * information on JProver. - * - * ---------------------------------------------------------------- - * - * This file is part of MetaPRL, a modular, higher order - * logical framework that provides a logical programming - * environment for OCaml and other languages. - * - * See the file doc/index.html for information on Nuprl, - * OCaml, and more information about this system. - * - * Copyright (C) 2000 Stephan Schmitt - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - * - * Author: Stephan Schmitt - * Modified by: Aleksey Nogin - *) - -exception Not_unifiable -exception Failed - -let jprover_bug = Invalid_argument "Jprover bug (Jtunify module)" - -(* ************ T-STRING UNIFICATION *********************************) - - -(* ******* printing ********** *) - -let rec list_to_string s = - match s with - [] -> "" - | f::r -> - f^"."^(list_to_string r) - -let rec print_eqlist eqlist = - match eqlist with - [] -> - print_endline "" - | (atnames,f)::r -> - let (s,t) = f in - let ls = list_to_string s - and lt = list_to_string t in - begin - print_endline ("Atom names: "^(list_to_string atnames)); - print_endline (ls^" = "^lt); - print_eqlist r - end - -let print_equations eqlist = - begin - Format.open_box 0; - Format.force_newline (); - print_endline "Equations:"; - print_eqlist eqlist; - Format.force_newline (); - end - -let rec print_subst sigma = - match sigma with - [] -> - print_endline "" - | f::r -> - let (v,s) = f in - let ls = list_to_string s in - begin - print_endline (v^" = "^ls); - print_subst r - end - -let print_tunify sigma = - let (n,subst) = sigma in - begin - print_endline " "; - print_endline ("MaxVar = "^(string_of_int (n-1))); - print_endline " "; - print_endline "Substitution:"; - print_subst subst; - print_endline " " - end - - (*****************************************************) - -let is_const name = - (String.get name 0) = 'c' - -let is_var name = - (String.get name 0) = 'v' - -let r_1 s ft rt = - (s = []) && (ft = []) && (rt = []) - -let r_2 s ft rt = - (s = []) && (ft = []) && (List.length rt >= 1) - -let r_3 s ft rt = - ft=[] && (List.length s >= 1) && (List.length rt >= 1) && (List.hd s = List.hd rt) - -let r_4 s ft rt = - ft=[] - && (List.length s >= 1) - && (List.length rt >= 1) - && is_const (List.hd s) - && is_var (List.hd rt) - -let r_5 s ft rt = - rt=[] - && (List.length s >= 1) - && is_var (List.hd s) - -let r_6 s ft rt = - ft=[] - && (List.length s >= 1) - && (List.length rt >= 1) - && is_var (List.hd s) - && is_const (List.hd rt) - -let r_7 s ft rt = - List.length s >= 1 - && (List.length rt >= 2) - && is_var (List.hd s) - && is_const (List.hd rt) - && is_const (List.hd (List.tl rt)) - -let r_8 s ft rt = - ft=[] - && List.length s >= 2 - && List.length rt >= 1 - && let v = List.hd s - and v1 = List.hd rt in - (is_var v) & (is_var v1) & (v <> v1) - -let r_9 s ft rt = - (List.length s >= 2) && (List.length ft >= 1) && (List.length rt >= 1) - && let v = (List.hd s) - and v1 = (List.hd rt) in - (is_var v) & (is_var v1) & (v <> v1) - -let r_10 s ft rt = - (List.length s >= 1) && (List.length rt >= 1) - && let v = List.hd s - and x = List.hd rt in - (is_var v) && (v <> x) - && (((List.tl s) =[]) or (is_const x) or ((List.tl rt) <> [])) - -let rec com_subst slist ((ov,ovlist) as one_subst) = - match slist with - [] -> raise jprover_bug - | f::r -> - if f = ov then - (ovlist @ r) - else - f::(com_subst r one_subst) - -let rec combine subst ((ov,oslist) as one_subst) = - match subst with - [] -> [] - | ((v, slist) as f) :: r -> - let rest_combine = (combine r one_subst) in - if (List.mem ov slist) then (* subst assumed to be idemponent *) - let com_element = com_subst slist one_subst in - ((v,com_element)::rest_combine) - else - (f::rest_combine) - -let compose ((n,subst) as _sigma) ((ov,oslist) as one_subst) = - let com = combine subst one_subst in -(* begin - print_endline "!!!!!!!!!test print!!!!!!!!!!"; - print_subst [one_subst]; - print_subst subst; - print_endline "!!!!!!!!! END test print!!!!!!!!!!"; -*) - if List.mem one_subst subst then - (n,com) - else -(* ov may multiply as variable in subst with DIFFERENT values *) -(* in order to avoid explicit atom instances!!! *) - (n,(com @ [one_subst])) -(* end *) - -let rec apply_element fs ft (v,slist) = - match (fs,ft) with - ([],[]) -> - ([],[]) - | ([],(ft_first::ft_rest)) -> - let new_ft_first = - if ft_first = v then - slist - else - [ft_first] - in - let (emptylist,new_ft_rest) = apply_element [] ft_rest (v,slist) in - (emptylist,(new_ft_first @ new_ft_rest)) - | ((fs_first::fs_rest),[]) -> - let new_fs_first = - if fs_first = v then - slist - else - [fs_first] - in - let (new_fs_rest,emptylist) = apply_element fs_rest [] (v,slist) in - ((new_fs_first @ new_fs_rest),emptylist) - | ((fs_first::fs_rest),(ft_first::ft_rest)) -> - let new_fs_first = - if fs_first = v then - slist - else - [fs_first] - and new_ft_first = - if ft_first = v then - slist - else - [ft_first] - in - let (new_fs_rest,new_ft_rest) = apply_element fs_rest ft_rest (v,slist) in - ((new_fs_first @ new_fs_rest),(new_ft_first @ new_ft_rest)) - -let rec shorten us ut = - match (us,ut) with - ([],_) | (_,[]) -> (us,ut) (*raise jprover_bug*) - | ((fs::rs),(ft::rt)) -> - if fs = ft then - shorten rs rt - else - (us,ut) - -let rec apply_subst_list eq_rest (v,slist) = - match eq_rest with - [] -> - (true,[]) - | (atomnames,(fs,ft))::r -> - let (n_fs,n_ft) = apply_element fs ft (v,slist) in - let (new_fs,new_ft) = shorten n_fs n_ft in (* delete equal first elements *) - match (new_fs,new_ft) with - [],[] -> - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,([],[]))::new_eq_rest)) - | [],(fft::rft) -> - if (is_const fft) then - (false,[]) - else - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,([],new_ft))::new_eq_rest)) - | (ffs::rfs),[] -> - if (is_const ffs) then - (false,[]) - else - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,(new_fs,[]))::new_eq_rest)) - | (ffs::rfs),(fft::rft) -> - if (is_const ffs) & (is_const fft) then - (false,[]) - (* different first constants cause local fail *) - else - (* at least one of firsts is a variable *) - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,(new_fs,new_ft))::new_eq_rest)) - -let apply_subst eq_rest (v,slist) atomnames = - if (List.mem v atomnames) then (* don't apply subst to atom variables !! *) - (true,eq_rest) - else - apply_subst_list eq_rest (v,slist) - - -(* let all_variable_check eqlist = false needs some discussion with Jens! -- NOT done *) - -(* - let rec all_variable_check eqlist = - match eqlist with - [] -> true - | ((_,(fs,ft))::rest_eq) -> - if (fs <> []) & (ft <> []) then - let fs_first = List.hd fs - and ft_first = List.hd ft - in - if (is_const fs_first) or (is_const ft_first) then - false - else - all_variable_check rest_eq - else - false -*) - -let rec tunify_list eqlist init_sigma = - let rec tunify atomnames fs ft rt rest_eq sigma = - let apply_r1 fs ft rt rest_eq sigma = - (* print_endline "r1"; *) - tunify_list rest_eq sigma - - in - let apply_r2 fs ft rt rest_eq sigma = - (* print_endline "r2"; *) - tunify atomnames rt fs ft rest_eq sigma - - in - let apply_r3 fs ft rt rest_eq sigma = - (* print_endline "r3"; *) - let rfs = (List.tl fs) - and rft = (List.tl rt) in - tunify atomnames rfs ft rft rest_eq sigma - - in - let apply_r4 fs ft rt rest_eq sigma = - (* print_endline "r4"; *) - tunify atomnames rt ft fs rest_eq sigma - - in - let apply_r5 fs ft rt rest_eq sigma = - (* print_endline "r5"; *) - let v = (List.hd fs) in - let new_sigma = compose sigma (v,ft) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,ft) atomnames in - if (bool=false) then - raise Not_unifiable - else - tunify atomnames (List.tl fs) rt rt new_rest_eq new_sigma - - in - let apply_r6 fs ft rt rest_eq sigma = - (* print_endline "r6"; *) - let v = (List.hd fs) in - let new_sigma = (compose sigma (v,[])) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,[]) atomnames in - if (bool=false) then - raise Not_unifiable - else - tunify atomnames (List.tl fs) ft rt new_rest_eq new_sigma - - in - let apply_r7 fs ft rt rest_eq sigma = - (* print_endline "r7"; *) - let v = (List.hd fs) - and c1 = (List.hd rt) - and c2t =(List.tl rt) in - let new_sigma = (compose sigma (v,(ft @ [c1]))) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [c1])) atomnames in - if bool=false then - raise Not_unifiable - else - tunify atomnames (List.tl fs) [] c2t new_rest_eq new_sigma - in - let apply_r8 fs ft rt rest_eq sigma = - (* print_endline "r8"; *) - tunify atomnames rt [(List.hd fs)] (List.tl fs) rest_eq sigma - - in - let apply_r9 fs ft rt rest_eq sigma = - (* print_endline "r9"; *) - let v = (List.hd fs) - and (max,subst) = sigma in - let v_new = ("vnew"^(string_of_int max)) in - let new_sigma = (compose ((max+1),subst) (v,(ft @ [v_new]))) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [v_new])) atomnames in - if (bool=false) then - raise Not_unifiable - else - tunify atomnames rt [v_new] (List.tl fs) new_rest_eq new_sigma - - in - let apply_r10 fs ft rt rest_eq sigma = - (* print_endline "r10"; *) - let x = List.hd rt in - tunify atomnames fs (ft @ [x]) (List.tl rt) rest_eq sigma - - in - if r_1 fs ft rt then - apply_r1 fs ft rt rest_eq sigma - else if r_2 fs ft rt then - apply_r2 fs ft rt rest_eq sigma - else if r_3 fs ft rt then - apply_r3 fs ft rt rest_eq sigma - else if r_4 fs ft rt then - apply_r4 fs ft rt rest_eq sigma - else if r_5 fs ft rt then - apply_r5 fs ft rt rest_eq sigma - else if r_6 fs ft rt then - (try - apply_r6 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_7 fs ft rt then (* r7 applicable if r6 was and tr6 = C2t' *) - (try - apply_r7 fs ft rt rest_eq sigma - with Not_unifiable -> - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r6 was *) - ) - else - (* r10 could be represented only once if we would try it before r7.*) - (* but looking at the transformation rules, r10 should be tried at last in any case *) - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable r6 was *) - ) - else if r_7 fs ft rt then (* not r6 and r7 possible if z <> [] *) - (try - apply_r7 fs ft rt rest_eq sigma - with Not_unifiable -> - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r7 was *) - ) - else if r_8 fs ft rt then - (try - apply_r8 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_10 fs ft rt then (* r10 applicable if r8 was and tr8 <> [] *) - apply_r10 fs ft rt rest_eq sigma - else - raise Not_unifiable (* simply back propagation *) - ) - else if r_9 fs ft rt then - (try - apply_r9 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_10 fs ft rt then (* r10 applicable if r9 was and tr9 <> [] *) - apply_r10 fs ft rt rest_eq sigma - else - raise Not_unifiable (* simply back propagation *) - ) - else if r_10 fs ft rt then (* not ri, i<10, and r10 possible if for instance *) - (* (s=[] and x=v1) or (z<>[] and xt=C1V1t') *) - apply_r10 fs ft rt rest_eq sigma - else (* NO rule applicable *) - raise Not_unifiable - in - match eqlist with - [] -> - init_sigma - | f::rest_eq -> - let (atomnames,(fs,ft)) = f in - tunify atomnames fs [] ft rest_eq init_sigma - -let rec test_apply_eq atomnames eqs eqt subst = - match subst with - [] -> (eqs,eqt) - | (f,flist)::r -> - let (first_appl_eqs,first_appl_eqt) = - if List.mem f atomnames then - (eqs,eqt) - else - (apply_element eqs eqt (f,flist)) - in - test_apply_eq atomnames first_appl_eqs first_appl_eqt r - -let rec test_apply_eqsubst eqlist subst = - match eqlist with - [] -> [] - | f::r -> - let (atomnames,(eqs,eqt)) = f in - let applied_element = test_apply_eq atomnames eqs eqt subst in - (atomnames,applied_element)::(test_apply_eqsubst r subst) - -let ttest us ut ns nt eqlist orderingQ atom_rel = - let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 *) - (* to eliminate common beginning *) - let new_element = ([ns;nt],(short_us,short_ut)) in - let full_eqlist = - if List.mem new_element eqlist then - eqlist - else - new_element::eqlist - in - let sigma = tunify_list full_eqlist (1,[]) in - let (n,subst) = sigma in - let test_apply = test_apply_eqsubst full_eqlist subst in - begin - print_endline ""; - print_endline "Final equations:"; - print_equations full_eqlist; - print_endline ""; - print_endline "Final substitution:"; - print_tunify sigma; - print_endline ""; - print_endline "Applied equations:"; - print_equations test_apply - end - -let do_stringunify us ut ns nt equations = - let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 to eliminate common beginning *) - let new_element = ([ns;nt],(short_us,short_ut)) in - let full_eqlist = - if List.mem new_element equations then - equations - else - new_element::equations - in -(* print_equations full_eqlist; *) - (try - let new_sigma = tunify_list full_eqlist (1,[]) in - (new_sigma,(1,full_eqlist)) - with Not_unifiable -> - raise Failed (* new connection please *) - ) - - -(* type of one unifier: int * (string * string) list *) diff --git a/contrib/jprover/jtunify.mli b/contrib/jprover/jtunify.mli deleted file mode 100644 index 0aabc79e..00000000 --- a/contrib/jprover/jtunify.mli +++ /dev/null @@ -1,35 +0,0 @@ -exception Not_unifiable -exception Failed - -(* Utilities *) - -val is_const : string -> bool -val is_var : string -> bool -val r_1 : 'a list -> 'b list -> 'c list -> bool -val r_2 : 'a list -> 'b list -> 'c list -> bool -val r_3 : 'a list -> 'b list -> 'a list -> bool -val r_4 : string list -> 'a list -> string list -> bool -val r_5 : string list -> 'a -> 'b list -> bool -val r_6 : string list -> 'a list -> string list -> bool -val r_7 : string list -> 'a -> string list -> bool -val r_8 : string list -> 'a list -> string list -> bool -val r_9 : string list -> 'a list -> string list -> bool -val r_10 : string list -> 'a -> string list -> bool -val com_subst : 'a list -> 'a * 'a list -> 'a list - -(* Debugging *) - -val print_equations : (string list * (string list * string list)) list -> unit - -val print_tunify : int * (string * string list) list -> unit - -(* Main function *) - -val do_stringunify : string list -> - string list -> - string -> - string -> - (string list * (string list * string list)) list -> - (int * (string * string list) list) * (* unifier *) - (int * ((string list * (string list * string list)) list)) (* applied new eqlist *) - diff --git a/contrib/jprover/opname.ml b/contrib/jprover/opname.ml deleted file mode 100644 index d0aa9046..00000000 --- a/contrib/jprover/opname.ml +++ /dev/null @@ -1,90 +0,0 @@ -open Printf - -type token = string -type atom = string list - -let opname_token = String.make 4 (Char.chr 0) - -type opname = - { mutable opname_token : token; - mutable opname_name : string list - } - -let (optable : (string list, opname) Hashtbl.t) = Hashtbl.create 97 - -(* * Constructors.*) -let nil_opname = { opname_token = opname_token; opname_name = [] } - -let _ = Hashtbl.add optable [] nil_opname - -let rec mk_opname s ({ opname_token = token; opname_name = name } as opname) = - if token == opname_token then - let name = s :: name in - try Hashtbl.find optable name with - Not_found -> - let op = { opname_token = opname_token; opname_name = name } in - Hashtbl.add optable name op; - op - else - mk_opname s (normalize_opname opname) - -and make_opname = function - | [] -> - nil_opname - | h :: t -> - mk_opname h (make_opname t) - -and normalize_opname opname = - if opname.opname_token == opname_token then - (* This opname is already normalized *) - opname - else - let res = make_opname opname.opname_name - in - opname.opname_name <- res.opname_name; - opname.opname_token <- opname_token; - res - -(* * Atoms are the inner string list. *) -let intern opname = - if opname.opname_token == opname_token then - opname.opname_name - else - let name = (normalize_opname opname).opname_name in - opname.opname_token <- opname_token; - opname.opname_name <- name; - name - -let eq_inner op1 op2 = - op1.opname_name <- (normalize_opname op1).opname_name; - op1.opname_token <- opname_token; - op2.opname_name <- (normalize_opname op2).opname_name; - op2.opname_token <- opname_token; - op1.opname_name == op2.opname_name - -let eq op1 op2 = - (op1.opname_name == op2.opname_name) - or ((op1.opname_token != opname_token or op2.opname_token != opname_token) & eq_inner op1 op2) - -(* * Destructor. *) -let dst_opname = function - | { opname_name = n :: name } -> n, { opname_token = opname_token; opname_name = name } - | _ -> raise (Invalid_argument "dst_opname") - -let dest_opname { opname_name = name } = - name - -let string_of_opname op = - let rec flatten = function - | [] -> - "" - | h::t -> - let rec collect s = function - | h::t -> - collect (h ^ "!" ^ s) t - | [] -> - s - in - collect h t - in - flatten op.opname_name diff --git a/contrib/jprover/opname.mli b/contrib/jprover/opname.mli deleted file mode 100644 index 56bf84e2..00000000 --- a/contrib/jprover/opname.mli +++ /dev/null @@ -1,15 +0,0 @@ -(* This module is extracted from Meta-Prl. *) - -type token = string -and atom = string list -val opname_token : token -type opname = { - mutable opname_token : token; - mutable opname_name : string list; -} -val nil_opname : opname -val mk_opname : string -> opname -> opname -val make_opname : string list -> opname -val eq : opname -> opname -> bool -val dest_opname : opname -> string list -val string_of_opname : opname -> string diff --git a/contrib/micromega/coq_micromega.ml b/contrib/micromega/coq_micromega.ml index 5ae12394..b4863ffc 100644 --- a/contrib/micromega/coq_micromega.ml +++ b/contrib/micromega/coq_micromega.ml @@ -1193,7 +1193,7 @@ let call_csdpcert provername poly = output_value ch_to (provername,poly : provername * micromega_polys); close_out ch_to; let cmdname = - List.fold_left Filename.concat Coq_config.coqlib + List.fold_left Filename.concat (Envars.coqlib ()) ["contrib"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in let c = Sys.command (cmdname ^" "^ tmp_to ^" "^ tmp_from) in (try Sys.remove tmp_to with _ -> ()); diff --git a/contrib/omega/OmegaLemmas.v b/contrib/omega/OmegaLemmas.v index ae642a3e..5c240553 100644 --- a/contrib/omega/OmegaLemmas.v +++ b/contrib/omega/OmegaLemmas.v @@ -6,12 +6,51 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i $Id: OmegaLemmas.v 7727 2005-12-25 13:42:20Z herbelin $ i*) +(*i $Id: OmegaLemmas.v 11739 2009-01-02 19:33:19Z herbelin $ i*) Require Import ZArith_base. Open Local Scope Z_scope. -(** These are specific variants of theorems dedicated for the Omega tactic *) +(** Factorization lemmas *) + +Theorem Zred_factor0 : forall n:Z, n = n * 1. + intro x; rewrite (Zmult_1_r x); reflexivity. +Qed. + +Theorem Zred_factor1 : forall n:Z, n + n = n * 2. +Proof. + exact Zplus_diag_eq_mult_2. +Qed. + +Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m). +Proof. + intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x); + rewrite <- Zmult_plus_distr_r; trivial with arith. +Qed. + +Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m). +Proof. + intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x); + rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; + trivial with arith. +Qed. + +Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p). +Proof. + intros x y z; symmetry in |- *; apply Zmult_plus_distr_r. +Qed. + +Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m. +Proof. + intros x y; rewrite <- Zmult_0_r_reverse; auto with arith. +Qed. + +Theorem Zred_factor6 : forall n:Z, n = n + 0. +Proof. + intro; rewrite Zplus_0_r; trivial with arith. +Qed. + +(** Other specific variants of theorems dedicated for the Omega tactic *) Lemma new_var : forall x : Z, exists y : Z, x = y. intros x; exists x; trivial with arith. diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml index 84092812..58873c2d 100644 --- a/contrib/omega/coq_omega.ml +++ b/contrib/omega/coq_omega.ml @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -(* $Id: coq_omega.ml 11094 2008-06-10 19:35:23Z herbelin $ *) +(* $Id: coq_omega.ml 11735 2009-01-02 17:22:31Z herbelin $ *) open Util open Pp @@ -309,6 +309,7 @@ let coq_dec_True = lazy (constant "dec_True") let coq_not_or = lazy (constant "not_or") let coq_not_and = lazy (constant "not_and") let coq_not_imp = lazy (constant "not_imp") +let coq_not_iff = lazy (constant "not_iff") let coq_not_not = lazy (constant "not_not") let coq_imp_simp = lazy (constant "imp_simp") let coq_iff = lazy (constant "iff") @@ -362,7 +363,7 @@ type omega_constant = | Eq | Neq | Zne | Zle | Zlt | Zge | Zgt | Z | Nat - | And | Or | False | True | Not + | And | Or | False | True | Not | Iff | Le | Lt | Ge | Gt | Other of string @@ -388,8 +389,7 @@ let destructurate_prop t = | _, [_;_] when c = Lazy.force coq_Zgt -> Kapp (Zgt,args) | _, [_;_] when c = build_coq_and () -> Kapp (And,args) | _, [_;_] when c = build_coq_or () -> Kapp (Or,args) - | _, [t1;t2] when c = Lazy.force coq_iff -> - Kapp (And,[mkArrow t1 t2;mkArrow t2 t1]) + | _, [_;_] when c = Lazy.force coq_iff -> Kapp (Iff, args) | _, [_] when c = build_coq_not () -> Kapp (Not,args) | _, [] when c = build_coq_False () -> Kapp (False,args) | _, [] when c = build_coq_True () -> Kapp (True,args) @@ -1557,6 +1557,9 @@ let rec decidability gl t = | Kapp(And,[t1;t2]) -> mkApp (Lazy.force coq_dec_and, [| t1; t2; decidability gl t1; decidability gl t2 |]) + | Kapp(Iff,[t1;t2]) -> + mkApp (Lazy.force coq_dec_iff, [| t1; t2; + decidability gl t1; decidability gl t2 |]) | Kimp(t1,t2) -> mkApp (Lazy.force coq_dec_imp, [| t1; t2; decidability gl t1; decidability gl t2 |]) @@ -1620,6 +1623,30 @@ let destructure_hyps gl = (introduction i2); (loop ((i1,None,t1)::(i2,None,t2)::lit)) ] gl) ] + | Kapp(Iff,[t1;t2]) -> + tclTHENLIST [ + (elim_id i); + (tclTRY (clear [i])); + (fun gl -> + let i1 = fresh_id [] (add_suffix i "_left") gl in + let i2 = fresh_id [] (add_suffix i "_right") gl in + tclTHENLIST [ + introduction i1; + generalize_tac + [mkApp (Lazy.force coq_imp_simp, + [| t1; t2; decidability gl t1; mkVar i1|])]; + onClearedName i1 (fun i1 -> + tclTHENLIST [ + introduction i2; + generalize_tac + [mkApp (Lazy.force coq_imp_simp, + [| t2; t1; decidability gl t2; mkVar i2|])]; + onClearedName i2 (fun i2 -> + loop + ((i1,None,mk_or (mk_not t1) t2):: + (i2,None,mk_or (mk_not t2) t1)::lit)) + ])] gl) + ] | Kimp(t1,t2) -> if is_Prop (pf_type_of gl t1) & @@ -1647,10 +1674,20 @@ let destructure_hyps gl = tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_and, [| t1; t2; - decidability gl t1;mkVar i|])]); + decidability gl t1; mkVar i|])]); (onClearedName i (fun i -> (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit)))) ] + | Kapp(Iff,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_iff, [| t1; t2; + decidability gl t1; decidability gl t2; mkVar i|])]); + (onClearedName i (fun i -> + (loop ((i,None, + mk_or (mk_and t1 (mk_not t2)) + (mk_and (mk_not t1) t2))::lit)))) + ] | Kimp(t1,t2) -> tclTHENLIST [ (generalize_tac diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml index 3d13a254..f2706307 100644 --- a/contrib/ring/ring.ml +++ b/contrib/ring/ring.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ring.ml 11094 2008-06-10 19:35:23Z herbelin $ *) +(* $Id: ring.ml 11800 2009-01-18 18:34:15Z msozeau $ *) (* ML part of the Ring tactic *) @@ -307,14 +307,14 @@ let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false let implement_theory env t th args = is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args)) -(* The following test checks whether the provided morphism is the default - one for the given operation. In principle the test is too strict, since - it should possible to provide another proof for the same fact (proof - irrelevance). In particular, the error message is be not very explicative. *) +(* (\* The following test checks whether the provided morphism is the default *) +(* one for the given operation. In principle the test is too strict, since *) +(* it should possible to provide another proof for the same fact (proof *) +(* irrelevance). In particular, the error message is be not very explicative. *\) *) let states_compatibility_for env plus mult opp morphs = - let check op compat = - is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem - compat in + let check op compat = true in +(* is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem *) +(* compat in *) check plus morphs.plusm && check mult morphs.multm && (match (opp,morphs.oppm) with @@ -826,12 +826,10 @@ let raw_polynom th op lc gl = c'''i; ci; c'i_eq_c''i |])))) (tclTHENS (tclORELSE - (Setoid_replace.general_s_rewrite true - Termops.all_occurrences c'i_eq_c''i - ~new_goals:[]) - (Setoid_replace.general_s_rewrite false - Termops.all_occurrences c'i_eq_c''i - ~new_goals:[])) + (Equality.general_rewrite true + Termops.all_occurrences c'i_eq_c''i) + (Equality.general_rewrite false + Termops.all_occurrences c'i_eq_c''i)) [tac])) else (tclORELSE @@ -881,7 +879,7 @@ let guess_equiv_tac th = let match_with_equiv c = match (kind_of_term c) with | App (e,a) -> - if (List.mem e (Setoid_replace.equiv_list ())) + if (List.mem e []) (* (Setoid_replace.equiv_list ())) *) then Some (decompose_app c) else None | _ -> None diff --git a/contrib/setoid_ring/Ring_base.v b/contrib/setoid_ring/Ring_base.v index 95b037e3..956a15fe 100644 --- a/contrib/setoid_ring/Ring_base.v +++ b/contrib/setoid_ring/Ring_base.v @@ -10,7 +10,6 @@ ring tactic. Abstract rings need more theory, depending on ZArith_base. *) -Declare ML Module "newring". Require Export Ring_theory. Require Export Ring_tac. Require Import InitialRing. diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v index 46d106d3..ad20fa08 100644 --- a/contrib/setoid_ring/Ring_tac.v +++ b/contrib/setoid_ring/Ring_tac.v @@ -4,7 +4,6 @@ Require Import BinPos. Require Import Ring_polynom. Require Import BinList. Require Import InitialRing. -Declare ML Module "newring". (* adds a definition id' on the normal form of t and an hypothesis id diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4 index 3d022add..50b7e47b 100644 --- a/contrib/setoid_ring/newring.ml4 +++ b/contrib/setoid_ring/newring.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id: newring.ml4 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: newring.ml4 11800 2009-01-18 18:34:15Z msozeau $ i*) open Pp open Util @@ -19,12 +19,12 @@ open Environ open Libnames open Tactics open Rawterm +open Termops open Tacticals open Tacexpr open Pcoq open Tactic open Constr -open Setoid_replace open Proof_type open Coqlib open Tacmach @@ -452,12 +452,13 @@ let (theory_to_obj, obj_to_theory) = let setoid_of_relation env a r = + let evm = Evd.empty in try lapp coq_mk_Setoid [|a ; r ; - Class_tactics.reflexive_proof env a r ; - Class_tactics.symmetric_proof env a r ; - Class_tactics.transitive_proof env a r |] + Class_tactics.get_reflexive_proof env evm a r ; + Class_tactics.get_symmetric_proof env evm a r ; + Class_tactics.get_transitive_proof env evm a r |] with Not_found -> error "cannot find setoid relation" diff --git a/contrib/subtac/equations.ml4 b/contrib/subtac/equations.ml4 new file mode 100644 index 00000000..9d120019 --- /dev/null +++ b/contrib/subtac/equations.ml4 @@ -0,0 +1,1149 @@ +(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mkRel i + | PCstr (c, p) -> + let c' = mkConstruct c in + mkApp (c', Array.of_list (constrs_of_pats ~inacc env p)) + | PInac r -> + if inacc then try mkInac env r with _ -> r else r + +and constrs_of_pats ?(inacc=true) env l = map (constr_of_pat ~inacc env) l + +let rec pat_vars = function + | PRel i -> Intset.singleton i + | PCstr (c, p) -> pats_vars p + | PInac _ -> Intset.empty + +and pats_vars l = + fold_left (fun vars p -> + let pvars = pat_vars p in + let inter = Intset.inter pvars vars in + if inter = Intset.empty then + Intset.union pvars vars + else error ("Non-linear pattern: variable " ^ + string_of_int (Intset.choose inter) ^ " appears twice")) + Intset.empty l + +let rec pats_of_constrs l = map pat_of_constr l +and pat_of_constr c = + match kind_of_term c with + | Rel i -> PRel i + | App (f, [| a ; c |]) when eq_constr f (Lazy.force coq_inacc) -> + PInac c + | App (f, args) when isConstruct f -> + PCstr (destConstruct f, pats_of_constrs (Array.to_list args)) + | Construct f -> PCstr (f, []) + | _ -> PInac c + +let inaccs_of_constrs l = map (fun x -> PInac x) l + +exception Conflict + +let rec pmatch p c = + match p, c with + | PRel i, t -> [i, t] + | PCstr (c, pl), PCstr (c', pl') when c = c' -> pmatches pl pl' + | PInac _, _ -> [] + | _, PInac _ -> [] + | _, _ -> raise Conflict + +and pmatches pl l = + match pl, l with + | [], [] -> [] + | hd :: tl, hd' :: tl' -> + pmatch hd hd' @ pmatches tl tl' + | _ -> raise Conflict + +let pattern_matches pl l = try Some (pmatches pl l) with Conflict -> None + +let rec pinclude p c = + match p, c with + | PRel i, t -> true + | PCstr (c, pl), PCstr (c', pl') when c = c' -> pincludes pl pl' + | PInac _, _ -> true + | _, PInac _ -> true + | _, _ -> false + +and pincludes pl l = + match pl, l with + | [], [] -> true + | hd :: tl, hd' :: tl' -> + pinclude hd hd' && pincludes tl tl' + | _ -> false + +let pattern_includes pl l = pincludes pl l + +(** Specialize by a substitution. *) + +let subst_tele s = replace_vars (List.map (fun (id, _, t) -> id, t) s) + +let subst_rel_subst k s c = + let rec aux depth c = + match kind_of_term c with + | Rel n -> + let k = n - depth in + if k >= 0 then + try lift depth (snd (assoc k s)) + with Not_found -> c + else c + | _ -> map_constr_with_binders succ aux depth c + in aux k c + +let subst_context s ctx = + let (_, ctx') = fold_right + (fun (id, b, t) (k, ctx') -> + (succ k, (id, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx')) + ctx (0, []) + in ctx' + +let subst_rel_context k cstr ctx = + let (_, ctx') = fold_right + (fun (id, b, t) (k, ctx') -> + (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx')) + ctx (k, []) + in ctx' + +let rec lift_pat n k p = + match p with + | PRel i -> + if i >= k then PRel (i + n) + else p + | PCstr(c, pl) -> PCstr (c, lift_pats n k pl) + | PInac r -> PInac (liftn n k r) + +and lift_pats n k = map (lift_pat n k) + +let rec subst_pat env k t p = + match p with + | PRel i -> + if i = k then t + else if i > k then PRel (pred i) + else p + | PCstr(c, pl) -> + PCstr (c, subst_pats env k t pl) + | PInac r -> PInac (substnl [constr_of_pat ~inacc:false env t] (pred k) r) + +and subst_pats env k t = map (subst_pat env k t) + +let rec specialize s p = + match p with + | PRel i -> + if mem_assoc i s then + let b, t = assoc i s in + if b then PInac t + else PRel (destRel t) + else p + | PCstr(c, pl) -> + PCstr (c, specialize_pats s pl) + | PInac r -> PInac (specialize_constr s r) + +and specialize_constr s c = subst_rel_subst 0 s c +and specialize_pats s = map (specialize s) + +let specialize_patterns = function + | [] -> fun p -> p + | s -> specialize_pats s + +let specialize_rel_context s ctx = + snd (fold_right (fun (n, b, t) (k, ctx) -> + (succ k, (n, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx)) + ctx (0, [])) + +let lift_contextn n k sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) + | [] -> [] + in + liftrec (rel_context_length sign + k) sign + +type program = + signature * clause list + +and signature = identifier * rel_context * constr + +and clause = lhs * (constr, int) rhs + +and lhs = rel_context * identifier * pat list + +and ('a, 'b) rhs = + | Program of 'a + | Empty of 'b + +type splitting = + | Compute of clause + | Split of lhs * int * inductive_family * + unification_result array * splitting option array + +and unification_result = + rel_context * int * constr * pat * substitution option + +and substitution = (int * (bool * constr)) list + +type problem = identifier * lhs + +let rels_of_tele tele = rel_list 0 (List.length tele) + +let patvars_of_tele tele = map (fun c -> PRel (destRel c)) (rels_of_tele tele) + +let split_solves split prob = + match split with + | Compute (lhs, rhs) -> lhs = prob + | Split (lhs, id, indf, us, ls) -> lhs = prob + +let ids_of_constr c = + let rec aux vars c = + match kind_of_term c with + | Var id -> Idset.add id vars + | _ -> fold_constr aux vars c + in aux Idset.empty c + +let ids_of_constrs = + fold_left (fun acc x -> Idset.union (ids_of_constr x) acc) Idset.empty + +let idset_of_list = + fold_left (fun s x -> Idset.add x s) Idset.empty + +let intset_of_list = + fold_left (fun s x -> Intset.add x s) Intset.empty + +let solves split (delta, id, pats as prob) = + split_solves split prob && + Intset.equal (pats_vars pats) (intset_of_list (map destRel (rels_of_tele delta))) + +let check_judgment ctx c t = + ignore(Typing.check (push_rel_context ctx (Global.env ())) Evd.empty c t); true + +let check_context env ctx = + fold_right + (fun (_, _, t as decl) env -> + ignore(Typing.sort_of env Evd.empty t); push_rel decl env) + ctx env + +let split_context n c = + let after, before = list_chop n c in + match before with + | hd :: tl -> after, hd, tl + | [] -> raise (Invalid_argument "split_context") + +let split_tele n (ctx : rel_context) = + let rec aux after n l = + match n, l with + | 0, decl :: before -> before, decl, List.rev after + | n, decl :: before -> aux (decl :: after) (pred n) before + | _ -> raise (Invalid_argument "split_tele") + in aux [] n ctx + +let rec add_var_subst env subst n c = + if mem_assoc n subst then + let t = assoc n subst in + if eq_constr t c then subst + else unify env subst t c + else + let rel = mkRel n in + if rel = c then subst + else if dependent rel c then raise Conflict + else (n, c) :: subst + +and unify env subst x y = + match kind_of_term x, kind_of_term y with + | Rel n, _ -> add_var_subst env subst n y + | _, Rel n -> add_var_subst env subst n x + | App (c, l), App (c', l') when eq_constr c c' -> + unify_constrs env subst (Array.to_list l) (Array.to_list l') + | _, _ -> if eq_constr x y then subst else raise Conflict + +and unify_constrs (env : env) subst l l' = + if List.length l = List.length l' then + fold_left2 (unify env) subst l l' + else raise Conflict + +let fold_rel_context_with_binders f ctx init = + snd (List.fold_right (fun decl (depth, acc) -> + (succ depth, f depth decl acc)) ctx (0, init)) + +let dependent_rel_context (ctx : rel_context) k = + fold_rel_context_with_binders + (fun depth (n,b,t) acc -> + let r = mkRel (depth + k) in + acc || dependent r t || + (match b with + | Some b -> dependent r b + | None -> false)) + ctx false + +let liftn_between n k p c = + let rec aux depth c = match kind_of_term c with + | Rel i -> + if i <= depth then c + else if i-depth > p then c + else mkRel (i - n) + | _ -> map_constr_with_binders succ aux depth c + in aux k c + +let liftn_rel_context n k sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) + | [] -> [] + in + liftrec (k + rel_context_length sign) sign + +let substnl_rel_context n l = + map_rel_context_with_binders (fun k -> substnl l (n+k-1)) + +let reduce_rel_context (ctx : rel_context) (subst : (int * (bool * constr)) list) = + let _, s, ctx' = + fold_left (fun (k, s, ctx') (n, b, t as decl) -> + match b with + | None -> (succ k, mkRel k :: s, ctx' @ [decl]) + | Some t -> (k, lift (pred k) t :: map (substnl [t] (pred k)) s, subst_rel_context 0 t ctx')) + (1, [], []) ctx + in + let s = rev s in + let s' = map (fun (korig, (b, knew)) -> korig, (b, substl s knew)) subst in + s', ctx' + +(* Compute the transitive closure of the dependency relation for a term in a context *) + +let rec dependencies_of_rel ctx k = + let (n,b,t) = nth ctx (pred k) in + let b = Option.map (lift k) b and t = lift k t in + let bdeps = match b with Some b -> dependencies_of_term ctx b | None -> Intset.empty in + Intset.union (Intset.singleton k) (Intset.union bdeps (dependencies_of_term ctx t)) + +and dependencies_of_term ctx t = + let rels = free_rels t in + Intset.fold (fun i -> Intset.union (dependencies_of_rel ctx i)) rels Intset.empty + +let subst_telescope k cstr ctx = + let (_, ctx') = fold_left + (fun (k, ctx') (id, b, t) -> + (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx')) + (k, []) ctx + in rev ctx' + +let lift_telescope n k sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (succ k) sign) + | [] -> [] + in liftrec k sign + +type ('a,'b) either = Inl of 'a | Inr of 'b + +let strengthen (ctx : rel_context) (t : constr) : rel_context * rel_context * (int * (int, int) either) list = + let rels = dependencies_of_term ctx t in + let len = length ctx in + let nbdeps = Intset.cardinal rels in + let lifting = len - nbdeps in (* Number of variables not linked to t *) + let rec aux k n acc m rest s = function + | decl :: ctx' -> + if Intset.mem k rels then + let rest' = subst_telescope 0 (mkRel (nbdeps + lifting - pred m)) rest in + aux (succ k) (succ n) (decl :: acc) m rest' ((k, Inl n) :: s) ctx' + else aux (succ k) n (subst_telescope 0 mkProp acc) (succ m) (decl :: rest) ((k, Inr m) :: s) ctx' + | [] -> rev acc, rev rest, s + in aux 1 1 [] 1 [] [] ctx + +let merge_subst (ctx', rest, s) = + let lenrest = length rest in + map (function (k, Inl x) -> (k, (false, mkRel (x + lenrest))) | (k, Inr x) -> k, (false, mkRel x)) s + +(* let simplify_subst s = *) +(* fold_left (fun s (k, t) -> *) +(* match kind_of_term t with *) +(* | Rel n when n = k -> s *) +(* | _ -> (k, t) :: s) *) +(* [] s *) + +let compose_subst s' s = + map (fun (k, (b, t)) -> (k, (b, specialize_constr s' t))) s + +let substitute_in_ctx n c ctx = + let rec aux k after = function + | [] -> [] + | (name, b, t as decl) :: before -> + if k = n then rev after @ (name, Some c, t) :: before + else aux (succ k) (decl :: after) before + in aux 1 [] ctx + +let rec reduce_subst (ctx : rel_context) (substacc : (int * (bool * constr)) list) (cursubst : (int * (bool * constr)) list) = + match cursubst with + | [] -> ctx, substacc + | (k, (b, t)) :: rest -> + if t = mkRel k then reduce_subst ctx substacc rest + else if noccur_between 1 k t then + (* The term to substitute refers only to previous variables. *) + let t' = lift (-k) t in + let ctx' = substitute_in_ctx k t' ctx in + reduce_subst ctx' substacc rest + else (* The term refers to variables declared after [k], so we have + to move these dependencies before [k]. *) + let (minctx, ctxrest, subst as str) = strengthen ctx t in + match assoc k subst with + | Inl _ -> error "Occurs check in substituted_context" + | Inr k' -> + let s = merge_subst str in + let ctx' = ctxrest @ minctx in + let rest' = + let substsubst (k', (b, t')) = + match kind_of_term (snd (assoc k' s)) with + | Rel k'' -> (k'', (b, specialize_constr s t')) + | _ -> error "Non-variable substituted for variable by strenghtening" + in map substsubst ((k, (b, t)) :: rest) + in + reduce_subst ctx' (compose_subst s substacc) rest' (* (compose_subst s ((k, (b, t)) :: rest)) *) + + +let substituted_context (subst : (int * constr) list) (ctx : rel_context) = + let _, subst = + fold_left (fun (k, s) _ -> + try let t = assoc k subst in + (succ k, (k, (true, t)) :: s) + with Not_found -> + (succ k, ((k, (false, mkRel k)) :: s))) + (1, []) ctx + in + let ctx', subst' = reduce_subst ctx subst subst in + reduce_rel_context ctx' subst' + +let unify_type before ty = + try + let envb = push_rel_context before (Global.env()) in + let IndType (indf, args) = find_rectype envb Evd.empty ty in + let ind, params = dest_ind_family indf in + let vs = map (Reduction.whd_betadeltaiota envb) args in + let cstrs = Inductiveops.arities_of_constructors envb ind in + let cstrs = + Array.mapi (fun i ty -> + let ty = prod_applist ty params in + let ctx, ty = decompose_prod_assum ty in + let ctx, ids = + let ids = ids_of_rel_context ctx in + fold_right (fun (n, b, t as decl) (acc, ids) -> + match n with Name _ -> (decl :: acc), ids + | Anonymous -> let id = next_name_away Anonymous ids in + ((Name id, b, t) :: acc), (id :: ids)) + ctx ([], ids) + in + let env' = push_rel_context ctx (Global.env ()) in + let IndType (indf, args) = find_rectype env' Evd.empty ty in + let ind, params = dest_ind_family indf in + let constr = applist (mkConstruct (ind, succ i), params @ rels_of_tele ctx) in + let constrpat = PCstr ((ind, succ i), inaccs_of_constrs params @ patvars_of_tele ctx) in + env', ctx, constr, constrpat, (* params @ *)args) + cstrs + in + let res = + Array.map (fun (env', ctxc, c, cpat, us) -> + let _beforelen = length before and ctxclen = length ctxc in + let fullctx = ctxc @ before in + try + let fullenv = push_rel_context fullctx (Global.env ()) in + let vs' = map (lift ctxclen) vs in + let subst = unify_constrs fullenv [] vs' us in + let subst', ctx' = substituted_context subst fullctx in + (ctx', ctxclen, c, cpat, Some subst') + with Conflict -> + (fullctx, ctxclen, c, cpat, None)) cstrs + in Some (res, indf) + with Not_found -> (* not an inductive type *) + None + +let rec id_of_rel n l = + match n, l with + | 0, (Name id, _, _) :: tl -> id + | n, _ :: tl -> id_of_rel (pred n) tl + | _, _ -> raise (Invalid_argument "id_of_rel") + +let constrs_of_lhs ?(inacc=true) env (ctx, _, pats) = + constrs_of_pats ~inacc (push_rel_context ctx env) pats + +let rec valid_splitting (f, delta, t, pats) tree = + split_solves tree (delta, f, pats) && + valid_splitting_tree (f, delta, t) tree + +and valid_splitting_tree (f, delta, t) = function + | Compute (lhs, Program rhs) -> + let subst = constrs_of_lhs ~inacc:false (Global.env ()) lhs in + ignore(check_judgment (pi1 lhs) rhs (substl subst t)); true + + | Compute ((ctx, id, lhs), Empty split) -> + let before, (x, _, ty), after = split_context split ctx in + let unify = + match unify_type before ty with + | Some (unify, _) -> unify + | None -> assert false + in + array_for_all (fun (_, _, _, _, x) -> x = None) unify + + | Split ((ctx, id, lhs), rel, indf, unifs, ls) -> + let before, (id, _, ty), after = split_tele (pred rel) ctx in + let unify, indf' = Option.get (unify_type before ty) in + assert(indf = indf'); + if not (array_exists (fun (_, _, _, _, x) -> x <> None) unify) then false + else + let ok, splits = + Array.fold_left (fun (ok, splits as acc) (ctx', ctxlen, cstr, cstrpat, subst) -> + match subst with + | None -> acc + | Some subst -> +(* let env' = push_rel_context ctx' (Global.env ()) in *) +(* let ctx_correct = *) +(* ignore(check_context env' (subst_context subst ctxc)); *) +(* ignore(check_context env' (subst_context subst before)); *) +(* true *) +(* in *) + let newdelta = + subst_context subst (subst_rel_context 0 cstr + (lift_contextn ctxlen 0 after)) @ before in + let liftpats = lift_pats ctxlen rel lhs in + let newpats = specialize_patterns subst (subst_pats (Global.env ()) rel cstrpat liftpats) in + (ok, (f, newdelta, newpats) :: splits)) + (true, []) unify + in + let subst = List.map2 (fun (id, _, _) x -> out_name id, x) delta + (constrs_of_pats ~inacc:false (Global.env ()) lhs) + in + let t' = replace_vars subst t in + ok && for_all + (fun (f, delta', pats') -> + array_exists (function None -> false | Some tree -> valid_splitting (f, delta', t', pats') tree) ls) splits + +let valid_tree (f, delta, t) tree = + valid_splitting (f, delta, t, patvars_of_tele delta) tree + +let is_constructor c = + match kind_of_term (fst (decompose_app c)) with + | Construct _ -> true + | _ -> false + +let find_split (_, _, curpats : lhs) (_, _, patcs : lhs) = + let rec find_split_pat curpat patc = + match patc with + | PRel _ -> None + | PCstr (f, args) -> + (match curpat with + | PCstr (f', args') when f = f' -> (* Already split at this level, continue *) + find_split_pats args' args + | PRel i -> (* Split on i *) Some i + | PInac c when isRel c -> Some (destRel c) + | _ -> None) + | PInac _ -> None + + and find_split_pats curpats patcs = + assert(List.length curpats = List.length patcs); + fold_left2 (fun acc -> + match acc with + | None -> find_split_pat | _ -> fun _ _ -> acc) + None curpats patcs + in find_split_pats curpats patcs + +open Pp +open Termops + +let pr_constr_pat env c = + let pr = print_constr_env env c in + match kind_of_term c with + | App _ -> str "(" ++ pr ++ str ")" + | _ -> pr + +let pr_pat env c = + try + let patc = constr_of_pat env c in + try pr_constr_pat env patc with _ -> str"pr_constr_pat raised an exception" + with _ -> str"constr_of_pat raised an exception" + +let pr_context env c = + let pr_decl (id,b,_) = + let bstr = match b with Some b -> str ":=" ++ spc () ++ print_constr_env env b | None -> mt() in + let idstr = match id with Name id -> pr_id id | Anonymous -> str"_" in + idstr ++ bstr + in + prlist_with_sep pr_spc pr_decl (List.rev c) +(* Printer.pr_rel_context env c *) + +let pr_lhs env (delta, f, patcs) = + let env = push_rel_context delta env in + let ctx = pr_context env delta in + (if delta = [] then ctx else str "[" ++ ctx ++ str "]" ++ spc ()) + ++ pr_id f ++ spc () ++ prlist_with_sep spc (pr_pat env) patcs + +let pr_rhs env = function + | Empty var -> spc () ++ str ":=!" ++ spc () ++ print_constr_env env (mkRel var) + | Program rhs -> spc () ++ str ":=" ++ spc () ++ print_constr_env env rhs + +let pr_clause env (lhs, rhs) = + pr_lhs env lhs ++ + (let env' = push_rel_context (pi1 lhs) env in + pr_rhs env' rhs) + +(* let pr_splitting env = function *) +(* | Compute cl -> str "Compute " ++ pr_clause env cl *) +(* | Split (lhs, n, indf, results, splits) -> *) + +(* let pr_unification_result (ctx, n, c, pat, subst) = *) + +(* unification_result array * splitting option array *) + +let pr_clauses env = + prlist_with_sep fnl (pr_clause env) + +let lhs_includes (delta, _, patcs : lhs) (delta', _, patcs' : lhs) = + pattern_includes patcs patcs' + +let lhs_matches (delta, _, patcs : lhs) (delta', _, patcs' : lhs) = + pattern_matches patcs patcs' + +let rec split_on env var (delta, f, curpats as lhs) clauses = + let before, (id, _, ty), after = split_tele (pred var) delta in + let unify, indf = + match unify_type before ty with + | Some r -> r + | None -> assert false (* We decided... so it better be inductive *) + in + let clauses = ref clauses in + let splits = + Array.map (fun (ctx', ctxlen, cstr, cstrpat, s) -> + match s with + | None -> None + | Some s -> + (* ctx' |- s cstr, s cstrpat *) + let newdelta = + subst_context s (subst_rel_context 0 cstr + (lift_contextn ctxlen 1 after)) @ ctx' in + let liftpats = + (* delta |- curpats -> before; ctxc; id; after |- liftpats *) + lift_pats ctxlen (succ var) curpats + in + let liftpat = (* before; ctxc |- cstrpat -> before; ctxc; after |- liftpat *) + lift_pat (pred var) 1 cstrpat + in + let substpat = (* before; ctxc; after |- liftpats[id:=liftpat] *) + subst_pats env var liftpat liftpats + in + let lifts = (* before; ctxc |- s : newdelta -> + before; ctxc; after |- lifts : newdelta ; after *) + map (fun (k,(b,x)) -> (pred var + k, (b, lift (pred var) x))) s + in + let newpats = specialize_patterns lifts substpat in + let newlhs = (newdelta, f, newpats) in + let matching, rest = + fold_right (fun (lhs, rhs as clause) (matching, rest) -> + if lhs_includes newlhs lhs then + (clause :: matching, rest) + else (matching, clause :: rest)) + !clauses ([], []) + in + clauses := rest; + if matching = [] then ( + (* Try finding a splittable variable *) + let (id, _) = + fold_right (fun (id, _, ty as decl) (accid, ctx) -> + match accid with + | Some _ -> (accid, ctx) + | None -> + match unify_type ctx ty with + | Some (unify, indf) -> + if array_for_all (fun (_, _, _, _, x) -> x = None) unify then + (Some id, ctx) + else (None, decl :: ctx) + | None -> (None, decl :: ctx)) + newdelta (None, []) + in + match id with + | None -> + errorlabstrm "deppat" + (str "Non-exhaustive pattern-matching, no clause found for:" ++ fnl () ++ + pr_lhs env newlhs) + | Some id -> + Some (Compute (newlhs, Empty (fst (lookup_rel_id (out_name id) newdelta)))) + ) else ( + let splitting = make_split_aux env newlhs matching in + Some splitting)) + unify + in +(* if !clauses <> [] then *) +(* errorlabstrm "deppat" *) +(* (str "Impossible clauses:" ++ fnl () ++ pr_clauses env !clauses); *) + Split (lhs, var, indf, unify, splits) + +and make_split_aux env lhs clauses = + let split = + fold_left (fun acc (lhs', rhs) -> + match acc with + | None -> find_split lhs lhs' + | _ -> acc) None clauses + in + match split with + | Some var -> split_on env var lhs clauses + | None -> + (match clauses with + | [] -> error "No clauses left" + | [(lhs', rhs)] -> + (* No need to split anymore, fix the environments so that they are correctly aligned. *) + (match lhs_matches lhs' lhs with + | Some s -> + let s = map (fun (x, p) -> x, (true, constr_of_pat ~inacc:false env p)) s in + let rhs' = match rhs with + | Program c -> Program (specialize_constr s c) + | Empty i -> Empty (destRel (snd (assoc i s))) + in Compute ((pi1 lhs, pi2 lhs, specialize_patterns s (pi3 lhs')), rhs') + | None -> anomaly "Non-matching clauses at a leaf of the splitting tree") + | _ -> + errorlabstrm "make_split_aux" + (str "Overlapping clauses:" ++ fnl () ++ pr_clauses env clauses)) + +let make_split env (f, delta, t) clauses = + make_split_aux env (delta, f, patvars_of_tele delta) clauses + +open Evd +open Evarutil + +let lift_substitution n s = map (fun (k, x) -> (k + n, x)) s +let map_substitution s t = map (subst_rel_subst 0 s) t + +let term_of_tree status isevar env (i, delta, ty) ann tree = +(* let envrec = match ann with *) +(* | None -> [] *) +(* | Some (loc, i) -> *) +(* let (n, t) = lookup_rel_id i delta in *) +(* let t' = lift n t in *) + + +(* in *) + let rec aux = function + | Compute ((ctx, _, pats as lhs), Program rhs) -> + let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in + let body = it_mkLambda_or_LetIn rhs ctx and typ = it_mkProd_or_LetIn ty' ctx in + mkCast(body, DEFAULTcast, typ), typ + + | Compute ((ctx, _, pats as lhs), Empty split) -> + let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in + let split = (Name (id_of_string "split"), + Some (Class_tactics.coq_nat_of_int (1 + (length ctx - split))), + Lazy.force Class_tactics.coq_nat) + in + let ty' = it_mkProd_or_LetIn ty' ctx in + let let_ty' = mkLambda_or_LetIn split (lift 1 ty') in + let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark (Define true)) let_ty' in + term, ty' + + | Split ((ctx, _, pats as lhs), rel, indf, unif, sp) -> + let before, decl, after = split_tele (pred rel) ctx in + let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in + let branches = + array_map2 (fun (ctx', ctxlen, cstr, cstrpat, subst) split -> + match split with + | Some s -> aux s + | None -> + (* dead code, inversion will find a proof of False by splitting on the rel'th hyp *) + Class_tactics.coq_nat_of_int rel, Lazy.force Class_tactics.coq_nat) + unif sp + in + let branches_ctx = + Array.mapi (fun i (br, brt) -> (id_of_string ("m_" ^ string_of_int i), Some br, brt)) + branches + in + let n, branches_lets = + Array.fold_left (fun (n, lets) (id, b, t) -> + (succ n, (Name id, Option.map (lift n) b, lift n t) :: lets)) + (0, []) branches_ctx + in + let liftctx = lift_contextn (Array.length branches) 0 ctx in + let case = + let ty = it_mkProd_or_LetIn ty' liftctx in + let ty = it_mkLambda_or_LetIn ty branches_lets in + let nbbranches = (Name (id_of_string "branches"), + Some (Class_tactics.coq_nat_of_int (length branches_lets)), + Lazy.force Class_tactics.coq_nat) + in + let nbdiscr = (Name (id_of_string "target"), + Some (Class_tactics.coq_nat_of_int (length before)), + Lazy.force Class_tactics.coq_nat) + in + let ty = it_mkLambda_or_LetIn (lift 2 ty) [nbbranches;nbdiscr] in + let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark status) ty in + term + in + let casetyp = it_mkProd_or_LetIn ty' ctx in + mkCast(case, DEFAULTcast, casetyp), casetyp + + in aux tree + +open Topconstr +open Constrintern +open Decl_kinds + +type equation = constr_expr * (constr_expr, identifier located) rhs + +let locate_reference qid = + match Nametab.extended_locate qid with + | TrueGlobal ref -> true + | SyntacticDef kn -> true + +let is_global id = + try + locate_reference (make_short_qualid id) + with Not_found -> + false + +let is_freevar ids env x = + try + if Idset.mem x ids then false + else + try ignore(Environ.lookup_named x env) ; false + with _ -> not (is_global x) + with _ -> true + +let ids_of_patc c ?(bound=Idset.empty) l = + let found id bdvars l = + if not (is_freevar bdvars (Global.env ()) (snd id)) then l + else if List.exists (fun (_, id') -> id' = snd id) l then l + else id :: l + in + let rec aux bdvars l c = match c with + | CRef (Ident lid) -> found lid bdvars l + | CNotation (_, "{ _ : _ | _ }", ((CRef (Ident (_, id))) :: _, _)) when not (Idset.mem id bdvars) -> + fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c + | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c + in aux bound l c + +let interp_pats i isevar env impls pat sign recu = + let bound = Idset.singleton i in + let vars = ids_of_patc pat ~bound [] in + let varsctx, env' = + fold_right (fun (loc, id) (ctx, env) -> + let decl = + let ty = e_new_evar isevar env ~src:(loc, BinderType (Name id)) (new_Type ()) in + (Name id, None, ty) + in + decl::ctx, push_rel decl env) + vars ([], env) + in + let pats = + let patenv = match recu with None -> env' | Some ty -> push_named (i, None, ty) env' in + let patt, _ = interp_constr_evars_impls ~evdref:isevar patenv ~impls:([],[]) pat in + match kind_of_term patt with + | App (m, args) -> + if not (eq_constr m (mkRel (succ (length varsctx)))) then + user_err_loc (constr_loc pat, "interp_pats", + str "Expecting a pattern for " ++ pr_id i) + else Array.to_list args + | _ -> user_err_loc (constr_loc pat, "interp_pats", + str "Error parsing pattern: unnexpected left-hand side") + in + isevar := nf_evar_defs !isevar; + (nf_rel_context_evar (Evd.evars_of !isevar) varsctx, + nf_env_evar (Evd.evars_of !isevar) env', + rev_map (nf_evar (Evd.evars_of !isevar)) pats) + +let interp_eqn i isevar env impls sign arity recu (pats, rhs) = + let ctx, env', patcs = interp_pats i isevar env impls pats sign recu in + let rhs' = match rhs with + | Program p -> + let ty = nf_isevar !isevar (substl patcs arity) in + Program (interp_casted_constr_evars isevar env' ~impls p ty) + | Empty lid -> Empty (fst (lookup_rel_id (snd lid) ctx)) + in ((ctx, i, pats_of_constrs (rev patcs)), rhs') + +open Entries + +open Tacmach +open Tacexpr +open Tactics +open Tacticals + +let contrib_tactics_path = + make_dirpath (List.map id_of_string ["Equality";"Program";"Coq"]) + +let tactics_tac s = + make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s) + +let equations_tac = lazy + (Tacinterp.eval_tactic + (TacArg(TacCall(dummy_loc, + ArgArg(dummy_loc, tactics_tac "equations"), [])))) + +let define_by_eqs with_comp i (l,ann) t nt eqs = + let env = Global.env () in + let isevar = ref (create_evar_defs Evd.empty) in + let (env', sign), impls = interp_context_evars isevar env l in + let arity = interp_type_evars isevar env' t in + let sign = nf_rel_context_evar (Evd.evars_of !isevar) sign in + let arity = nf_evar (Evd.evars_of !isevar) arity in + let arity = + if with_comp then + let compid = add_suffix i "_comp" in + let ce = + { const_entry_body = it_mkLambda_or_LetIn arity sign; + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = false} + in + let c = + Declare.declare_constant compid (DefinitionEntry ce, IsDefinition Definition) + in mkApp (mkConst c, rel_vect 0 (length sign)) + else arity + in + let env = Global.env () in + let ty = it_mkProd_or_LetIn arity sign in + let data = Command.compute_interning_datas env Constrintern.Recursive [] [i] [ty] [impls] in + let fixdecls = [(Name i, None, ty)] in + let fixenv = push_rel_context fixdecls env in + let equations = + States.with_heavy_rollback (fun () -> + Option.iter (Command.declare_interning_data data) nt; + map (interp_eqn i isevar fixenv data sign arity None) eqs) () + in + let sign = nf_rel_context_evar (Evd.evars_of !isevar) sign in + let arity = nf_evar (Evd.evars_of !isevar) arity in + let prob = (i, sign, arity) in + let fixenv = nf_env_evar (Evd.evars_of !isevar) fixenv in + let fixdecls = nf_rel_context_evar (Evd.evars_of !isevar) fixdecls in + (* let ce = check_evars fixenv Evd.empty !isevar in *) + (* List.iter (function (_, _, Program rhs) -> ce rhs | _ -> ()) equations; *) + let is_recursive, env' = + let occur_eqn ((ctx, _, _), rhs) = + match rhs with + | Program c -> dependent (mkRel (succ (length ctx))) c + | _ -> false + in if exists occur_eqn equations then true, fixenv else false, env + in + let split = make_split env' prob equations in + (* if valid_tree prob split then *) + let status = (* if is_recursive then Expand else *) Define false in + let t, ty = term_of_tree status isevar env' prob ann split in + let undef = undefined_evars !isevar in + let t, ty = if is_recursive then + (it_mkLambda_or_LetIn t fixdecls, it_mkProd_or_LetIn ty fixdecls) + else t, ty + in + let obls, t', ty' = + Eterm.eterm_obligations env i !isevar (Evd.evars_of undef) 0 ~status t ty + in + if is_recursive then + ignore(Subtac_obligations.add_mutual_definitions [(i, t', ty', impls, obls)] [] + ~tactic:(Lazy.force equations_tac) + (Command.IsFixpoint [None, CStructRec])) + else + ignore(Subtac_obligations.add_definition + ~implicits:impls i t' ty' ~tactic:(Lazy.force equations_tac) obls) + +module Gram = Pcoq.Gram +module Vernac = Pcoq.Vernac_ +module Tactic = Pcoq.Tactic + +module DeppatGram = +struct + let gec s = Gram.Entry.create ("Deppat."^s) + + let deppat_equations : equation list Gram.Entry.e = gec "deppat_equations" + + let binders_let2 : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e = gec "binders_let2" + +(* let where_decl : decl_notation Gram.Entry.e = gec "where_decl" *) + +end + +open Rawterm +open DeppatGram +open Util +open Pcoq +open Prim +open Constr +open G_vernac + +GEXTEND Gram + GLOBAL: (* deppat_gallina_loc *) deppat_equations binders_let2; + + deppat_equations: + [ [ l = LIST1 equation SEP ";" -> l ] ] + ; + + binders_let2: + [ [ l = binders_let_fixannot -> l ] ] + ; + + equation: + [ [ c = Constr.lconstr; r=rhs -> (c, r) ] ] + ; + + rhs: + [ [ ":=!"; id = identref -> Empty id + |":="; c = Constr.lconstr -> Program c + ] ] + ; + + END + +type 'a deppat_equations_argtype = (equation list, 'a) Genarg.abstract_argument_type + +let (wit_deppat_equations : Genarg.tlevel deppat_equations_argtype), + (globwit_deppat_equations : Genarg.glevel deppat_equations_argtype), + (rawwit_deppat_equations : Genarg.rlevel deppat_equations_argtype) = + Genarg.create_arg "deppat_equations" + +type 'a binders_let2_argtype = (local_binder list * (identifier located option * recursion_order_expr), 'a) Genarg.abstract_argument_type + +let (wit_binders_let2 : Genarg.tlevel binders_let2_argtype), + (globwit_binders_let2 : Genarg.glevel binders_let2_argtype), + (rawwit_binders_let2 : Genarg.rlevel binders_let2_argtype) = + Genarg.create_arg "binders_let2" + +type 'a decl_notation_argtype = (Vernacexpr.decl_notation, 'a) Genarg.abstract_argument_type + +let (wit_decl_notation : Genarg.tlevel decl_notation_argtype), + (globwit_decl_notation : Genarg.glevel decl_notation_argtype), + (rawwit_decl_notation : Genarg.rlevel decl_notation_argtype) = + Genarg.create_arg "decl_notation" + +let equations wc i l t nt eqs = + try define_by_eqs wc i l t nt eqs + with e -> msg (Cerrors.explain_exn e) + +VERNAC COMMAND EXTEND Define_equations +| [ "Equations" ident(i) binders_let2(l) ":" lconstr(t) ":=" deppat_equations(eqs) + decl_notation(nt) ] -> + [ equations true i l t nt eqs ] + END + +VERNAC COMMAND EXTEND Define_equations2 +| [ "Equations_nocomp" ident(i) binders_let2(l) ":" lconstr(t) ":=" deppat_equations(eqs) + decl_notation(nt) ] -> + [ equations false i l t nt eqs ] +END + +let rec int_of_coq_nat c = + match kind_of_term c with + | App (f, [| arg |]) -> succ (int_of_coq_nat arg) + | _ -> 0 + +let solve_equations_goal destruct_tac tac gl = + let concl = pf_concl gl in + let targetn, branchesn, targ, brs, b = + match kind_of_term concl with + | LetIn (Name target, targ, _, b) -> + (match kind_of_term b with + | LetIn (Name branches, brs, _, b) -> + target, branches, int_of_coq_nat targ, int_of_coq_nat brs, b + | _ -> error "Unnexpected goal") + | _ -> error "Unnexpected goal" + in + let branches, b = + let rec aux n c = + if n = 0 then [], c + else match kind_of_term c with + | LetIn (Name id, br, brt, b) -> + let rest, b = aux (pred n) b in + (id, br, brt) :: rest, b + | _ -> error "Unnexpected goal" + in aux brs b + in + let ids = targetn :: branchesn :: map pi1 branches in + let cleantac = tclTHEN (intros_using ids) (thin ids) in + let dotac = tclDO (succ targ) intro in + let subtacs = + tclTHENS destruct_tac + (map (fun (id, br, brt) -> tclTHEN (letin_tac None (Name id) br (Some brt) onConcl) tac) branches) + in tclTHENLIST [cleantac ; dotac ; subtacs] gl + +TACTIC EXTEND solve_equations + [ "solve_equations" tactic(destruct) tactic(tac) ] -> [ solve_equations_goal (snd destruct) (snd tac) ] + END + +let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq +let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl) + +let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq") +let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl") + +let specialize_hyp id gl = + let env = pf_env gl in + let ty = pf_get_hyp_typ gl id in + let evars = ref (create_evar_defs (project gl)) in + let rec aux in_eqs acc ty = + match kind_of_term ty with + | Prod (_, t, b) -> + (match kind_of_term t with + | App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) -> + let pt = mkApp (Lazy.force coq_eq, [| eqty; x; x |]) in + let p = mkApp (Lazy.force coq_eq_refl, [| eqty; x |]) in + if e_conv env evars pt t then + aux true (mkApp (acc, [| p |])) (subst1 p b) + else error "Unconvertible members of an homogeneous equality" + | App (heq, [| eqty; x; eqty'; y |]) when eq_constr heq (Lazy.force coq_heq) -> + let pt = mkApp (Lazy.force coq_heq, [| eqty; x; eqty; x |]) in + let p = mkApp (Lazy.force coq_heq_refl, [| eqty; x |]) in + if e_conv env evars pt t then + aux true (mkApp (acc, [| p |])) (subst1 p b) + else error "Unconvertible members of an heterogeneous equality" + | _ -> + if in_eqs then acc, in_eqs, ty + else + let e = e_new_evar evars env t in + aux false (mkApp (acc, [| e |])) (subst1 e b)) + | t -> acc, in_eqs, ty + in + try + let acc, worked, ty = aux false (mkVar id) ty in + let ty = Evarutil.nf_isevar !evars ty in + if worked then + tclTHENFIRST + (fun g -> Tacmach.internal_cut true id ty g) + (exact_no_check (Evarutil.nf_isevar !evars acc)) gl + else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl + with e -> tclFAIL 0 (Cerrors.explain_exn e) gl + +TACTIC EXTEND specialize_hyp +[ "specialize_hypothesis" constr(c) ] -> [ + match kind_of_term c with + | Var id -> specialize_hyp id + | _ -> tclFAIL 0 (str "Not an hypothesis") ] +END diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml index 9bfb33ea..00a69bba 100644 --- a/contrib/subtac/eterm.ml +++ b/contrib/subtac/eterm.ml @@ -1,3 +1,4 @@ +(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) (** - Get types of existentials ; - Flatten dependency tree (prefix order) ; @@ -6,12 +7,14 @@ *) open Term +open Sign open Names open Evd open List open Pp open Util open Subtac_utils +open Proof_type let trace s = if !Flags.debug then (msgnl s; msgerr s) @@ -20,15 +23,27 @@ let trace s = let succfix (depth, fixrels) = (succ depth, List.map succ fixrels) +type oblinfo = + { ev_name: int * identifier; + ev_hyps: named_context; + ev_status: obligation_definition_status; + ev_chop: int option; + ev_loc: Util.loc; + ev_typ: types; + ev_tac: Tacexpr.raw_tactic_expr option; + ev_deps: Intset.t } + (** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) + let subst_evar_constr evs n t = let seen = ref Intset.empty in let transparent = ref Idset.empty in let evar_info id = List.assoc id evs in let rec substrec (depth, fixrels) c = match kind_of_term c with | Evar (k, args) -> - let (id, idstr), hyps, chop, _, _, _ = + let { ev_name = (id, idstr) ; + ev_hyps = hyps ; ev_chop = chop } = try evar_info k with Not_found -> anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") @@ -46,17 +61,13 @@ let subst_evar_constr evs n t = let rec aux hyps args acc = match hyps, args with ((_, None, _) :: tlh), (c :: tla) -> - aux tlh tla ((map_constr_with_binders succfix substrec (depth, fixrels) c) :: acc) + aux tlh tla ((substrec (depth, fixrels) c) :: acc) | ((_, Some _, _) :: tlh), (_ :: tla) -> aux tlh tla acc | [], [] -> acc | _, _ -> acc (*failwith "subst_evars: invalid argument"*) in aux hyps args [] in - (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (List.length args) ++ str "arguments," ++ - int (List.length hyps) ++ str " hypotheses" ++ spc () ++ - pp_list (fun x -> my_print_constr (Global.env ()) x) args); - with _ -> ()); if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then transparent := Idset.add idstr !transparent; mkApp (mkVar idstr, Array.of_list args) @@ -93,8 +104,8 @@ let etype_of_evar evs hyps concl = let trans' = Idset.union trans trans' in (match copt with Some c -> - if noccurn 1 rest then lift (-1) rest, s', trans' - else +(* if noccurn 1 rest then lift (-1) rest, s', trans' *) +(* else *) let c', s'', trans'' = subst_evar_constr evs n c in let c' = subst_vars acc 0 c' in mkNamedProd_or_LetIn (id, Some c', t'') rest, @@ -121,15 +132,34 @@ let rec chop_product n t = | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None | _ -> None -let eterm_obligations env name isevars evm fs t ty = - (* 'Serialize' the evars, we assume that the types of the existentials - refer to previous existentials in the list only *) - trace (str " In eterm: isevars: " ++ my_print_evardefs isevars); - trace (str "Term given to eterm" ++ spc () ++ - Termops.print_constr_env (Global.env ()) t); +let evar_dependencies evm ev = + 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) + 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) + +let sort_dependencies evl = + List.sort (fun (_, _, deps) (_, _, deps') -> + if Intset.subset deps deps' then (* deps' depends on deps *) -1 + else if Intset.subset deps' deps then 1 + else Intset.compare deps deps') + evl + +let eterm_obligations env name isevars evm fs ?status t ty = + (* 'Serialize' the evars *) let nc = Environ.named_context env in let nc_len = Sign.named_context_length nc in let evl = List.rev (to_list evm) in + let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in + let sevl = sort_dependencies evl in + let evl = List.map (fun (id, ev, _) -> id, ev) sevl in let evn = let i = ref (-1) in List.rev_map (fun (id, ev) -> incr i; @@ -146,20 +176,29 @@ let eterm_obligations env name isevars evm fs t ty = let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in let evtyp, hyps, chop = match chop_product fs evtyp with - Some t -> - (try - trace (str "Choped a product: " ++ spc () ++ - Termops.print_constr_env (Global.env ()) evtyp ++ str " to " ++ spc () ++ - Termops.print_constr_env (Global.env ()) t); - with _ -> ()); - t, trunc_named_context fs hyps, fs - | None -> evtyp, hyps, 0 + | Some t -> t, trunc_named_context fs hyps, fs + | None -> evtyp, hyps, 0 in let loc, k = evar_source id isevars in - let opacity = match k with QuestionMark o -> o | _ -> true in - let opaque = if not opacity || chop <> fs then None else Some chop in - let y' = (id, ((n, nstr), hyps, opaque, loc, evtyp, deps)) in - y' :: l) + let status = match k with QuestionMark o -> Some o | _ -> status in + let status, chop = match status with + | Some (Define true as stat) -> + if chop <> fs then Define false, None + else stat, Some chop + | Some s -> s, None + | None -> Define true, None + in + let tac = match ev.evar_extra with + | Some t -> + if Dyn.tag t = "tactic" then + Some (Tacinterp.globTacticIn (Tacinterp.tactic_out t)) + else None + | None -> None + in + let info = { ev_name = (n, nstr); + ev_hyps = hyps; ev_status = status; ev_chop = chop; + ev_loc = loc; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac } + in (id, info) :: l) evn [] in let t', _, transparent = (* Substitute evar refs in the term by variables *) @@ -167,28 +206,16 @@ let eterm_obligations env name isevars evm fs t ty = in let ty, _, _ = subst_evar_constr evts 0 ty in let evars = - List.map (fun (_, ((_, name), _, opaque, loc, typ, deps)) -> - name, typ, loc, not (opaque = None) && not (Idset.mem name transparent), deps) evts - in - (try - trace (str "Term constructed in eterm" ++ spc () ++ - Termops.print_constr_env (Global.env ()) t'); - ignore(iter - (fun (name, typ, _, _, deps) -> - trace (str "Evar :" ++ spc () ++ str (string_of_id name) ++ - Termops.print_constr_env (Global.env ()) typ)) - evars); - with _ -> ()); - Array.of_list (List.rev evars), t', ty + List.map (fun (_, info) -> + let { ev_name = (_, name); ev_status = status; + ev_loc = loc; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info + in + let status = match status with + | Define true when Idset.mem name transparent -> Define false + | _ -> status + in name, typ, loc, status, deps, tac) evts + in Array.of_list (List.rev evars), t', ty let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n -(* let eterm evm t (tycon : types option) = *) -(* let t, tycon, evs = eterm_term evm t tycon in *) -(* match tycon with *) -(* Some typ -> Tactics.apply_term (mkCast (t, DEFAULTcast, typ)) [] *) -(* | None -> Tactics.apply_term t (mkMetas (List.length evs)) *) - -(* open Tacmach *) - let etermtac (evm, t) = assert(false) (*eterm evm t None *) diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli index 007e327c..19e8ffe8 100644 --- a/contrib/subtac/eterm.mli +++ b/contrib/subtac/eterm.mli @@ -6,23 +6,27 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: eterm.mli 10889 2008-05-06 14:05:20Z msozeau $ i*) +(*i $Id: eterm.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) open Environ open Tacmach open Term open Evd open Names open Util +open Tacinterp val mkMetas : int -> constr list -(* val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list *) - -(* env, id, evars, number of - function prototypes to try to clear from evars contexts, object and type *) -val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> constr -> types -> - (identifier * types * loc * bool * Intset.t) array * constr * types - (* Obl. name, type as product, location of the original evar, - opacity (true = opaque) and dependencies as indexes into the array *) +val evar_dependencies : evar_map -> int -> Intset.t +val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list + +(* env, id, evars, number of function prototypes to try to clear from + evars contexts, object and type *) +val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> + ?status:obligation_definition_status -> constr -> types -> + (identifier * types * loc * obligation_definition_status * Intset.t * + Tacexpr.raw_tactic_expr option) array * constr * types + (* Obl. name, type as product, location of the original evar, associated tactic, + status and dependencies as indexes into the array *) val etermtac : open_constr -> tactic diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4 index 4cf5336d..7194d435 100644 --- a/contrib/subtac/g_subtac.ml4 +++ b/contrib/subtac/g_subtac.ml4 @@ -14,7 +14,7 @@ Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) -(* $Id: g_subtac.ml4 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: g_subtac.ml4 11576 2008-11-10 19:13:15Z msozeau $ *) open Flags @@ -112,25 +112,25 @@ END VERNAC COMMAND EXTEND Subtac_Solve_Obligation | [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligation num (Some name) (Tacinterp.interp t) ] + [ Subtac_obligations.try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligation num None (Tacinterp.interp t) ] + [ Subtac_obligations.try_solve_obligation num None (Some (Tacinterp.interp t)) ] END VERNAC COMMAND EXTEND Subtac_Solve_Obligations | [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligations (Some name) (Tacinterp.interp t) ] + [ Subtac_obligations.try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligations" "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligations None (Tacinterp.interp t) ] + [ Subtac_obligations.try_solve_obligations None (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligations" ] -> - [ Subtac_obligations.try_solve_obligations None (Subtac_obligations.default_tactic ()) ] + [ Subtac_obligations.try_solve_obligations None None ] END VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations | [ "Solve" "All" "Obligations" "using" tactic(t) ] -> - [ Subtac_obligations.solve_all_obligations (Tacinterp.interp t) ] + [ Subtac_obligations.solve_all_obligations (Some (Tacinterp.interp t)) ] | [ "Solve" "All" "Obligations" ] -> - [ Subtac_obligations.solve_all_obligations (Subtac_obligations.default_tactic ()) ] + [ Subtac_obligations.solve_all_obligations None ] END VERNAC COMMAND EXTEND Subtac_Admit_Obligations diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml index 7bfa107b..ba00fce5 100644 --- a/contrib/subtac/subtac.ml +++ b/contrib/subtac/subtac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: subtac.ml 11800 2009-01-18 18:34:15Z msozeau $ *) open Global open Pp @@ -52,16 +52,14 @@ open Tacexpr let solve_tccs_in_type env id isevars evm c typ = if not (evm = Evd.empty) then let stmt_id = Nameops.add_suffix id "_stmt" in - let obls, c', t' = eterm_obligations env stmt_id !isevars evm 0 c typ in - (** Make all obligations transparent so that real dependencies can be sorted out by the user *) - let obls = Array.map (fun (id, t, l, op, d) -> (id, t, l, false, d)) obls in + let obls, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in match Subtac_obligations.add_definition stmt_id c' typ obls with - Subtac_obligations.Defined cst -> constant_value (Global.env()) - (match cst with ConstRef kn -> kn | _ -> assert false) - | _ -> - errorlabstrm "start_proof" - (str "The statement obligations could not be resolved automatically, " ++ spc () ++ - str "write a statement definition first.") + Subtac_obligations.Defined cst -> constant_value (Global.env()) + (match cst with ConstRef kn -> kn | _ -> assert false) + | _ -> + errorlabstrm "start_proof" + (str "The statement obligations could not be resolved automatically, " ++ spc () ++ + str "write a statement definition first.") else let _ = Typeops.infer_type env c in c @@ -106,12 +104,9 @@ let declare_assumption env isevars idl is_coe k bl c nl = errorlabstrm "Command.Assumption" (str "Cannot declare an assumption while in proof editing mode.") -let dump_definition (loc, id) s = - Flags.dump_string (Printf.sprintf "%s %d %s\n" s (fst (unloc loc)) (string_of_id id)) - let dump_constraint ty ((loc, n), _, _) = match n with - | Name id -> dump_definition (loc, id) ty + | Name id -> Dumpglob.dump_definition (loc, id) false ty | Anonymous -> () let dump_variable lid = () @@ -119,9 +114,9 @@ let dump_variable lid = () let vernac_assumption env isevars kind l nl = let global = fst kind = Global in List.iter (fun (is_coe,(idl,c)) -> - if !Flags.dump then + if Dumpglob.dump () then List.iter (fun lid -> - if global then dump_definition lid "ax" + if global then Dumpglob.dump_definition lid (not global) "ax" else dump_variable lid) idl; declare_assumption env isevars idl is_coe kind [] c nl) l @@ -139,7 +134,7 @@ let subtac (loc, command) = match command with | VernacDefinition (defkind, (_, id as lid), expr, hook) -> check_fresh lid; - dump_definition lid "def"; + Dumpglob.dump_definition lid false "def"; (match expr with | ProveBody (bl, t) -> if Lib.is_modtype () then @@ -152,12 +147,12 @@ let subtac (loc, command) = | VernacFixpoint (l, b) -> List.iter (fun ((lid, _, _, _, _), _) -> check_fresh lid; - dump_definition lid "fix") l; + Dumpglob.dump_definition lid false "fix") l; let _ = trace (str "Building fixpoint") in ignore(Subtac_command.build_recursive l b) | VernacStartTheoremProof (thkind, [Some id, (bl, t)], lettop, hook) -> - if !Flags.dump then dump_definition id "prf"; + Dumpglob.dump_definition id false "prf"; if not(Pfedit.refining ()) then if lettop then errorlabstrm "Subtac_command.StartProof" @@ -172,11 +167,12 @@ let subtac (loc, command) = vernac_assumption env isevars stre l nl | VernacInstance (glob, sup, is, props, pri) -> - if !Flags.dump then dump_constraint "inst" is; + dump_constraint "inst" is; ignore(Subtac_classes.new_instance ~global:glob sup is props pri) | VernacCoFixpoint (l, b) -> - List.iter (fun ((lid, _, _, _), _) -> dump_definition lid "cofix") l; + if Dumpglob.dump () then + List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l; ignore(Subtac_command.build_corecursive l b) (*| VernacEndProof e -> diff --git a/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml index 04bf54d3..094226ff 100644 --- a/contrib/subtac/subtac_cases.ml +++ b/contrib/subtac/subtac_cases.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_cases.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: subtac_cases.ml 11576 2008-11-10 19:13:15Z msozeau $ *) open Cases open Util @@ -1572,7 +1572,7 @@ let mk_JMeq typ x typ' y = mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |]) -let hole = RHole (dummy_loc, Evd.QuestionMark true) +let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true)) let context_of_arsign l = let (x, _) = List.fold_right diff --git a/contrib/subtac/subtac_classes.ml b/contrib/subtac/subtac_classes.ml index 9a5539e2..0d44a0c0 100644 --- a/contrib/subtac/subtac_classes.ml +++ b/contrib/subtac/subtac_classes.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtac_classes.ml 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: subtac_classes.ml 11800 2009-01-18 18:34:15Z msozeau $ i*) open Pretyping open Evd @@ -92,104 +92,103 @@ let type_class_instance_params isevars env id n ctx inst subst = let substitution_of_constrs ctx cstrs = List.fold_right2 (fun c (na, _, _) acc -> (na, c) :: acc) cstrs ctx [] -let new_instance ?(global=false) ctx (instid, bk, cl) props ?(on_free_vars=Classes.default_on_free_vars) pri = +let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) pri = let env = Global.env() in let isevars = ref (Evd.create_evar_defs Evd.empty) in - let bound = Implicit_quantifiers.ids_of_list (Termops.ids_of_context env) in - let bound, fvs = Implicit_quantifiers.free_vars_of_binders ~bound [] ctx in let tclass = match bk with - | Implicit -> - let loc, id, par = Implicit_quantifiers.destClassAppExpl cl in - let k = class_info (Nametab.global id) in - let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in - let needlen = List.fold_left (fun acc (x, y) -> if x = None then succ acc else acc) 0 k.cl_context in - if needlen <> applen then - Classes.mismatched_params env (List.map fst par) (List.map snd k.cl_context); - let pars, _ = Implicit_quantifiers.combine_params Idset.empty (* need no avoid *) - (fun avoid (clname, (id, _, t)) -> - match clname with - Some (cl, b) -> - let t = - if b then - let _k = class_info cl in - CHole (Util.dummy_loc, Some Evd.InternalHole) (* (Evd.ImplicitArg (IndRef k.cl_impl, (1, None)))) *) - else CHole (Util.dummy_loc, None) - in t, avoid - | None -> failwith ("new instance: under-applied typeclass")) - par (List.rev k.cl_context) - in Topconstr.CAppExpl (loc, (None, id), pars) - + | Implicit -> + Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *) + ~allow_partial:false (fun avoid (clname, (id, _, t)) -> + match clname with + | Some (cl, b) -> + let t = + if b then + let _k = class_info cl in + CHole (Util.dummy_loc, Some Evd.InternalHole) + else CHole (Util.dummy_loc, None) + in t, avoid + | None -> failwith ("new instance: under-applied typeclass")) + cl | Explicit -> cl in - let ctx_bound = Idset.union bound (Implicit_quantifiers.ids_of_list fvs) in - let gen_ids = Implicit_quantifiers.free_vars_of_constr_expr ~bound:ctx_bound tclass [] in - let bound = Idset.union (Implicit_quantifiers.ids_of_list gen_ids) ctx_bound in - on_free_vars (List.rev (gen_ids @ fvs)); - let gen_ctx = Implicit_quantifiers.binder_list_of_ids gen_ids in - let ctx, avoid = Classes.name_typeclass_binders bound ctx in - let ctx = List.append ctx (List.rev gen_ctx) in + let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in let k, ctx', imps, subst = let c = Command.generalize_constr_expr tclass ctx in let c', imps = interp_type_evars_impls ~evdref:isevars env c in let ctx, c = Sign.decompose_prod_assum c' in - let cl, args = Typeclasses.dest_class_app c in - cl, ctx, imps, (List.rev (Array.to_list args)) + let cl, args = Typeclasses.dest_class_app (push_rel_context ctx env) c in + cl, ctx, imps, (List.rev args) in let id = match snd instid with - Name id -> - let sp = Lib.make_path id in - if Nametab.exists_cci sp then - errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists"); - id - | Anonymous -> - let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in - Termops.next_global_ident_away false i (Termops.ids_of_context env) + | Name id -> + let sp = Lib.make_path id in + if Nametab.exists_cci sp then + errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists"); + id + | Anonymous -> + let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in + Termops.next_global_ident_away false i (Termops.ids_of_context env) in let env' = push_rel_context ctx' env in isevars := Evarutil.nf_evar_defs !isevars; isevars := resolve_typeclasses ~onlyargs:false ~fail:true env' !isevars; let sigma = Evd.evars_of !isevars in - let substctx = List.map (Evarutil.nf_evar sigma) subst in - let subst, _propsctx = + let subst = List.map (Evarutil.nf_evar sigma) subst in + let subst = let props = - List.map (fun (x, l, d) -> - x, Topconstr.abstract_constr_expr d (Classes.binders_of_lidents l)) - props + match props with + | CRecord (loc, _, fs) -> + if List.length fs > List.length k.cl_props then + Classes.mismatched_props env' (List.map snd fs) k.cl_props; + fs + | _ -> + if List.length k.cl_props <> 1 then + errorlabstrm "new_instance" (Pp.str "Expected a definition for the instance body") + else [(dummy_loc, Nameops.out_name (pi1 (List.hd k.cl_props))), props] in - if List.length props > List.length k.cl_props then - Classes.mismatched_props env' (List.map snd props) k.cl_props; - let props, rest = - List.fold_left - (fun (props, rest) (id,_,_) -> - try - let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in - let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in - Constrintern.add_glob loc (ConstRef (List.assoc mid k.cl_projs)); - c :: props, rest' - with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest) - ([], props) k.cl_props - in - if rest <> [] then - unbound_method env' k.cl_impl (fst (List.hd rest)) - else - type_ctx_instance isevars env' k.cl_props props substctx + match k.cl_props with + | [(na,b,ty)] -> + let term = match props with [] -> CHole (Util.dummy_loc, None) | [(_,f)] -> f | _ -> assert false in + let ty' = substl subst ty in + let c = interp_casted_constr_evars isevars env' term ty' in + c :: subst + | _ -> + let props, rest = + List.fold_left + (fun (props, rest) (id,_,_) -> + try + let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in + let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in + Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); + c :: props, rest' + with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest) + ([], props) k.cl_props + in + if rest <> [] then + unbound_method env' k.cl_impl (fst (List.hd rest)) + else + fst (type_ctx_instance isevars env' k.cl_props props subst) + in + let subst = List.fold_left2 + (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') + [] subst (k.cl_props @ snd k.cl_context) in - let inst_constr, ty_constr = instance_constructor k (List.rev subst) in - isevars := Evarutil.nf_evar_defs !isevars; - let term = Evarutil.nf_isevar !isevars (it_mkLambda_or_LetIn inst_constr ctx') - and termtype = Evarutil.nf_isevar !isevars (it_mkProd_or_LetIn ty_constr ctx') + let inst_constr, ty_constr = instance_constructor k subst in + isevars := Evarutil.nf_evar_defs !isevars; + let term = Evarutil.nf_isevar !isevars (it_mkLambda_or_LetIn inst_constr ctx') + and termtype = Evarutil.nf_isevar !isevars (it_mkProd_or_LetIn ty_constr ctx') + in + isevars := undefined_evars !isevars; + Evarutil.check_evars env Evd.empty !isevars termtype; + let hook gr = + let cst = match gr with ConstRef kn -> kn | _ -> assert false in + let inst = Typeclasses.new_instance k pri global cst in + Impargs.declare_manual_implicits false gr ~enriching:false imps; + Typeclasses.add_instance inst in - isevars := undefined_evars !isevars; - Evarutil.check_evars env Evd.empty !isevars termtype; - let hook gr = - let cst = match gr with ConstRef kn -> kn | _ -> assert false in - let inst = Typeclasses.new_instance k pri global cst in - Impargs.declare_manual_implicits false gr false imps; - Typeclasses.add_instance inst - in - let evm = Subtac_utils.evars_of_term (Evd.evars_of !isevars) Evd.empty term in - let obls, constr, typ = Eterm.eterm_obligations env id !isevars evm 0 term termtype in - ignore(Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls); - id + let evm = Subtac_utils.evars_of_term (Evd.evars_of !isevars) Evd.empty term in + let obls, constr, typ = Eterm.eterm_obligations env id !isevars evm 0 term termtype in + id, Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls + diff --git a/contrib/subtac/subtac_classes.mli b/contrib/subtac/subtac_classes.mli index afb0d38d..96a51027 100644 --- a/contrib/subtac/subtac_classes.mli +++ b/contrib/subtac/subtac_classes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtac_classes.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: subtac_classes.mli 11709 2008-12-20 11:42:15Z msozeau $ i*) (*i*) open Names @@ -34,9 +34,9 @@ val type_ctx_instance : Evd.evar_defs ref -> val new_instance : ?global:bool -> - Topconstr.local_binder list -> + local_binder list -> typeclass_constraint -> - binder_def_list -> - ?on_free_vars:(identifier list -> unit) -> + constr_expr -> + ?generalize:bool -> int option -> - identifier + identifier * Subtac_obligations.progress diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml index 4d8f868f..1bbbfbb1 100644 --- a/contrib/subtac/subtac_coercion.ml +++ b/contrib/subtac/subtac_coercion.ml @@ -6,7 +6,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_coercion.ml 11343 2008-09-01 20:55:13Z herbelin $ *) +(* $Id: subtac_coercion.ml 11576 2008-11-10 19:13:15Z msozeau $ *) open Util open Names @@ -33,37 +33,36 @@ open Pp let pair_of_array a = (a.(0), a.(1)) let make_name s = Name (id_of_string s) +let rec disc_subset x = + match kind_of_term x with + | App (c, l) -> + (match kind_of_term c with + Ind i -> + let len = Array.length l in + let sig_ = Lazy.force sig_ in + if len = 2 && i = Term.destInd sig_.typ + then + let (a, b) = pair_of_array l in + Some (a, b) + else None + | _ -> None) + | _ -> None + +and disc_exist env x = + match kind_of_term x with + | App (c, l) -> + (match kind_of_term c with + Construct c -> + if c = Term.destConstruct (Lazy.force sig_).intro + then Some (l.(0), l.(1), l.(2), l.(3)) + else None + | _ -> None) + | _ -> None + module Coercion = struct - + exception NoSubtacCoercion - - let rec disc_subset x = - match kind_of_term x with - | App (c, l) -> - (match kind_of_term c with - Ind i -> - let len = Array.length l in - let sig_ = Lazy.force sig_ in - if len = 2 && i = Term.destInd sig_.typ - then - let (a, b) = pair_of_array l in - Some (a, b) - else None - | _ -> None) - | _ -> None - - and disc_exist env x = - match kind_of_term x with - | App (c, l) -> - (match kind_of_term c with - Construct c -> - if c = Term.destConstruct (Lazy.force sig_).intro - then Some (l.(0), l.(1), l.(2), l.(3)) - else None - | _ -> None) - | _ -> None - - + let disc_proj_exist env x = match kind_of_term x with | App (c, l) -> diff --git a/contrib/subtac/subtac_coercion.mli b/contrib/subtac/subtac_coercion.mli index 53a8d213..5678c10e 100644 --- a/contrib/subtac/subtac_coercion.mli +++ b/contrib/subtac/subtac_coercion.mli @@ -1 +1,4 @@ +open Term +val disc_subset : types -> (types * types) option + module Coercion : Coercion.S diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml index a2f54b02..4876b065 100644 --- a/contrib/subtac/subtac_command.ml +++ b/contrib/subtac/subtac_command.ml @@ -99,7 +99,7 @@ let interp_binder sigma env na t = SPretyping.pretype_gen sigma env ([], []) IsType (locate_if_isevar (loc_of_rawconstr t) na t) let interp_context_evars evdref env params = - let bl = Constrintern.intern_context (Evd.evars_of !evdref) env params in + let bl = Constrintern.intern_context false (Evd.evars_of !evdref) env params in let (env, par, _, impls) = List.fold_left (fun (env,params,n,impls) (na, k, b, t) -> @@ -284,7 +284,7 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = mkApp (constr_of_global (Lazy.force fix_sub_ref), [| argtyp ; wf_rel ; - make_existential dummy_loc ~opaque:false env isevars wf_proof ; + make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ; lift lift_cst prop ; lift lift_cst intern_body_lam |]) | Some f -> @@ -385,7 +385,7 @@ let interp_recursive fixkind l boxed = let env_rec = push_named_context rec_sign env in (* Get interpretation metadatas *) - let impls = Command.compute_interning_datas env [] fixnames fixtypes fiximps in + let impls = Command.compute_interning_datas env Constrintern.Recursive [] fixnames fixtypes fiximps in let notations = List.fold_right Option.List.cons ntnl [] in (* Interp bodies with rollback because temp use of notations/implicit *) diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml index a393e2c9..cc1e2dde 100644 --- a/contrib/subtac/subtac_obligations.ml +++ b/contrib/subtac/subtac_obligations.ml @@ -1,7 +1,9 @@ +(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) open Printf open Pp open Subtac_utils open Command +open Environ open Term open Names @@ -13,9 +15,11 @@ open Decl_kinds open Util open Evd open Declare +open Proof_type type definition_hook = global_reference -> unit +let ppwarn cmd = Pp.warn (str"Program:" ++ cmd) let pperror cmd = Util.errorlabstrm "Program" cmd let error s = pperror (str s) @@ -25,15 +29,17 @@ let explain_no_obligations = function Some ident -> str "No obligations for program " ++ str (string_of_id ident) | None -> str "No obligations remaining" -type obligation_info = (Names.identifier * Term.types * loc * bool * Intset.t) array - +type obligation_info = (Names.identifier * Term.types * loc * obligation_definition_status * Intset.t + * Tacexpr.raw_tactic_expr option) array + type obligation = { obl_name : identifier; obl_type : types; obl_location : loc; obl_body : constr option; - obl_opaque : bool; + obl_status : obligation_definition_status; obl_deps : Intset.t; + obl_tac : Tacexpr.raw_tactic_expr option; } type obligations = (obligation array * int) @@ -79,22 +85,29 @@ let _ = let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type -let subst_deps obls deps t = - Intset.fold - (fun x acc -> - let xobl = obls.(x) in - debug 3 (str "Trying to get body of obligation " ++ int x); - let oblb = - try Option.get xobl.obl_body - with _ -> - debug 3 (str "Couldn't get body of obligation " ++ int x); - assert(false) - in - Term.subst1 oblb (Term.subst_var xobl.obl_name acc)) - deps t - +let get_obligation_body expand obl = + let c = Option.get obl.obl_body in + if expand && obl.obl_status = Expand then + match kind_of_term c with + | Const c -> constant_value (Global.env ()) c + | _ -> c + else c + +let subst_deps expand obls deps t = + let subst = + Intset.fold + (fun x acc -> + let xobl = obls.(x) in + let oblb = + try get_obligation_body expand xobl + with _ -> assert(false) + in (xobl.obl_name, oblb) :: acc) + deps [] + in(* Termops.it_mkNamedProd_or_LetIn t subst *) + Term.replace_vars subst t + let subst_deps_obl obls obl = - let t' = subst_deps obls obl.obl_deps obl.obl_type in + let t' = subst_deps false obls obl.obl_deps obl.obl_type in { obl with obl_type = t' } module ProgMap = Map.Make(struct type t = identifier let compare = compare end) @@ -150,14 +163,14 @@ let rec intset_to = function -1 -> Intset.empty | n -> Intset.add n (intset_to (pred n)) -let subst_body prg = +let subst_body expand prg = let obls, _ = prg.prg_obligations in let ints = intset_to (pred (Array.length obls)) in - subst_deps obls ints prg.prg_body, - subst_deps obls ints (Termops.refresh_universes prg.prg_type) + subst_deps expand obls ints prg.prg_body, + subst_deps expand obls ints (Termops.refresh_universes prg.prg_type) let declare_definition prg = - let body, typ = subst_body prg in + let body, typ = subst_body false prg in (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++ my_print_constr (Global.env()) body ++ str " : " ++ my_print_constr (Global.env()) prg.prg_type); @@ -188,7 +201,7 @@ let declare_definition prg = in let gr = ConstRef c in if Impargs.is_implicit_args () || prg.prg_implicits <> [] then - Impargs.declare_manual_implicits false gr (Impargs.is_implicit_args ()) prg.prg_implicits; + Impargs.declare_manual_implicits false gr prg.prg_implicits; print_message (Subtac_utils.definition_message prg.prg_name); prg.prg_hook gr; gr @@ -216,14 +229,18 @@ let compute_possible_guardness_evidences (n,_) fixbody fixtype = let ctx = fst (Sign.decompose_prod_n_assum m fixtype) in list_map_i (fun i _ -> i) 0 ctx +let reduce_fix = + Reductionops.clos_norm_flags Closure.betaiotazeta (Global.env ()) Evd.empty + let declare_mutual_definition l = let len = List.length l in let fixdefs, fixtypes, fiximps = list_split3 (List.map (fun x -> - let subs, typ = (subst_body x) in + let subs, typ = (subst_body false x) in snd (decompose_lam_n len subs), snd (decompose_prod_n len typ), x.prg_implicits) l) in +(* let fixdefs = List.map reduce_fix fixdefs in *) let fixkind = Option.get (List.hd l).prg_fixkind in let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in @@ -248,41 +265,33 @@ let declare_mutual_definition l = (match List.hd kns with ConstRef kn -> kn | _ -> assert false) let declare_obligation obl body = - let ce = - { const_entry_body = body; - const_entry_type = Some obl.obl_type; - const_entry_opaque = if get_proofs_transparency () then false else obl.obl_opaque; - const_entry_boxed = false} - in - let constant = Declare.declare_constant obl.obl_name - (DefinitionEntry ce,IsProof Property) - in - print_message (Subtac_utils.definition_message obl.obl_name); - { obl with obl_body = Some (mkConst constant) } - -let try_tactics obls = - Array.map - (fun obl -> - match obl.obl_body with - None -> - (try - let ev = evar_of_obligation obl in - let c = Subtac_utils.solve_by_tac ev Auto.default_full_auto in - declare_obligation obl c - with _ -> obl) - | _ -> obl) - obls - + match obl.obl_status with + | Expand -> { obl with obl_body = Some body } + | Define opaque -> + let ce = + { const_entry_body = body; + const_entry_type = Some obl.obl_type; + const_entry_opaque = + (if get_proofs_transparency () then false + else opaque) ; + const_entry_boxed = false} + in + let constant = Declare.declare_constant obl.obl_name + (DefinitionEntry ce,IsProof Property) + in + print_message (Subtac_utils.definition_message obl.obl_name); + { obl with obl_body = Some (mkConst constant) } + let red = Reductionops.nf_betaiota let init_prog_info n b t deps fixkind notations obls impls kind hook = let obls' = Array.mapi - (fun i (n, t, l, o, d) -> + (fun i (n, t, l, o, d, tac) -> debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d)); { obl_name = n ; obl_body = None; - obl_location = l; obl_type = red t; obl_opaque = o; - obl_deps = d }) + obl_location = l; obl_type = red t; obl_status = o; + obl_deps = d; obl_tac = tac }) obls in { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls'); @@ -369,22 +378,16 @@ let has_dependencies obls n = !res let kind_of_opacity o = - if o then Subtac_utils.goal_proof_kind - else Subtac_utils.goal_kind - -let obligations_of_evars evars = - let arr = - Array.of_list - (List.map - (fun (n, t) -> - { obl_name = n; - obl_type = t; - obl_location = dummy_loc; - obl_body = None; - obl_opaque = false; - obl_deps = Intset.empty; - }) evars) - in arr, Array.length arr + match o with + | Define false | Expand -> Subtac_utils.goal_kind + | _ -> Subtac_utils.goal_proof_kind + +let not_transp_msg = + str "Obligation should be transparent but was declared opaque." ++ spc () ++ + str"Use 'Defined' instead." + +let warn_not_transp () = ppwarn not_transp_msg +let error_not_transp () = pperror not_transp_msg let rec solve_obligation prg num = let user_num = succ num in @@ -394,26 +397,37 @@ let rec solve_obligation prg num = pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.") else match deps_remaining obls obl.obl_deps with - [] -> - let obl = subst_deps_obl obls obl in - Command.start_proof obl.obl_name (kind_of_opacity obl.obl_opaque) obl.obl_type - (fun strength gr -> - debug 2 (str "Proof of obligation " ++ int user_num ++ str " finished"); - let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in - let obls = Array.copy obls in - let _ = obls.(num) <- obl in - match update_obls prg obls (pred rem) with - | Remain n when n > 0 -> - if has_dependencies obls num then - ignore(auto_solve_obligations (Some prg.prg_name)) - | _ -> ()); - trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ - Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); - Pfedit.by !default_tactic; - Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () - | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " - ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) - + | [] -> + let obl = subst_deps_obl obls obl in + Command.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type + (fun strength gr -> + let cst = match gr with ConstRef cst -> cst | _ -> assert false in + let obl = + let transparent = evaluable_constant cst (Global.env ()) in + let body = + match obl.obl_status with + | Expand -> + if not transparent then error_not_transp () + else constant_value (Global.env ()) cst + | Define opaque -> + if not opaque && not transparent then error_not_transp () + else Libnames.constr_of_global gr + in { obl with obl_body = Some body } + in + let obls = Array.copy obls in + let _ = obls.(num) <- obl in + match update_obls prg obls (pred rem) with + | Remain n when n > 0 -> + if has_dependencies obls num then + ignore(auto_solve_obligations (Some prg.prg_name) None) + | _ -> ()); + trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ + Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); + Pfedit.by !default_tactic; + Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () + | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " + ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) + and subtac_obligation (user_num, name, typ) = let num = pred user_num in let prg = get_prog_err name in @@ -434,12 +448,17 @@ and solve_obligation_by_tac prg obls i tac = (try if deps_remaining obls obl.obl_deps = [] then let obl = subst_deps_obl obls obl in + let tac = + match tac with + | Some t -> t + | None -> + match obl.obl_tac with + | Some t -> Tacinterp.interp t + | None -> !default_tactic + in let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in - if obl.obl_opaque then - obls.(i) <- declare_obligation obl t - else - obls.(i) <- { obl with obl_body = Some t }; - true + obls.(i) <- declare_obligation obl t; + true else false with | Stdpp.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s))) @@ -473,34 +492,40 @@ and try_solve_obligation n prg tac = let obls' = Array.copy obls in if solve_obligation_by_tac prg obls' n tac then ignore(update_obls prg obls' (pred rem)); - + and try_solve_obligations n tac = try ignore (solve_obligations n tac) with NoObligations _ -> () -and auto_solve_obligations n : progress = +and auto_solve_obligations n tac : progress = Flags.if_verbose msgnl (str "Solving obligations automatically..."); - try solve_obligations n !default_tactic with NoObligations _ -> Dependent + try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent open Pp let show_obligations ?(msg=true) n = let prg = get_prog_err n in let n = prg.prg_name in let obls, rem = prg.prg_obligations in + let showed = ref 5 in if msg then msgnl (int rem ++ str " obligation(s) remaining: "); Array.iteri (fun i x -> match x.obl_body with - None -> msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ - my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ()) - | Some _ -> ()) + | None -> + if !showed > 0 then ( + decr showed; + msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ + str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ + hov 1 (my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ()))) + | Some _ -> ()) obls - + let show_term n = let prg = get_prog_err n in let n = prg.prg_name in - msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++ my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () + msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++ + my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ my_print_constr (Global.env ()) prg.prg_body) -let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?(hook=fun x -> ()) obls = +let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(hook=fun x -> ()) obls = Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); let prg = init_prog_info n b t [] None [] obls implicits kind hook in let obls,_ = prg.prg_obligations in @@ -513,12 +538,12 @@ let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?(hook= let len = Array.length obls in let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in from_prg := ProgMap.add n prg !from_prg; - let res = auto_solve_obligations (Some n) in + let res = auto_solve_obligations (Some n) tactic in match res with - | Remain rem when rem < 5 -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res - | _ -> res) + | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res + | _ -> res) -let add_mutual_definitions l ?(kind=Global,false,Definition) notations fixkind = +let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) notations fixkind = let deps = List.map (fun (n, b, t, imps, obls) -> n) l in let upd = List.fold_left (fun acc (n, b, t, imps, obls) -> @@ -531,8 +556,9 @@ let add_mutual_definitions l ?(kind=Global,false,Definition) notations fixkind = List.fold_left (fun finished x -> if finished then finished else - match auto_solve_obligations (Some x) with - Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true + let res = auto_solve_obligations (Some x) tactic in + match res with + | Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true | _ -> false) false deps in () @@ -562,8 +588,8 @@ let next_obligation n = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in let i = - array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) - obls + try array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls + with Not_found -> anomaly "Could not find a solvable obligation." in solve_obligation prg i let default_tactic () = !default_tactic diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli index 6d13e3bd..60c0a413 100644 --- a/contrib/subtac/subtac_obligations.mli +++ b/contrib/subtac/subtac_obligations.mli @@ -1,9 +1,14 @@ open Names open Util open Libnames +open Evd +open Proof_type -type obligation_info = (Names.identifier * Term.types * loc * bool * Intset.t) array - (* ident, type, location, opaque or transparent, dependencies *) +type obligation_info = + (identifier * Term.types * loc * + obligation_definition_status * Intset.t * Tacexpr.raw_tactic_expr option) array + (* ident, type, location, (opaque or transparent, expand or define), + dependencies, tactic to solve it *) type progress = (* Resolution status of a program *) | Remain of int (* n obligations remaining *) @@ -21,6 +26,7 @@ type definition_hook = global_reference -> unit val add_definition : Names.identifier -> Term.constr -> Term.types -> ?implicits:(Topconstr.explicitation * (bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> + ?tactic:Proof_type.tactic -> ?hook:definition_hook -> obligation_info -> progress type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list @@ -28,6 +34,7 @@ type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) val add_mutual_definitions : (Names.identifier * Term.constr * Term.types * (Topconstr.explicitation * (bool * bool)) list * obligation_info) list -> + ?tactic:Proof_type.tactic -> ?kind:Decl_kinds.definition_kind -> notations -> Command.fixpoint_kind -> unit @@ -36,14 +43,14 @@ val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr op val next_obligation : Names.identifier option -> unit -val solve_obligations : Names.identifier option -> Proof_type.tactic -> progress +val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress (* Number of remaining obligations to be solved for this program *) -val solve_all_obligations : Proof_type.tactic -> unit +val solve_all_obligations : Proof_type.tactic option -> unit -val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic -> unit +val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit -val try_solve_obligations : Names.identifier option -> Proof_type.tactic -> unit +val try_solve_obligations : Names.identifier option -> Proof_type.tactic option -> unit val show_obligations : ?msg:bool -> Names.identifier option -> unit diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml index ad76bdeb..07a75720 100644 --- a/contrib/subtac/subtac_pretyping.ml +++ b/contrib/subtac/subtac_pretyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: subtac_pretyping.ml 11574 2008-11-10 13:45:05Z msozeau $ *) open Global open Pp @@ -73,7 +73,7 @@ let interp env isevars c tycon = let _ = isevars := Evarutil.nf_evar_defs !isevars in let evd,_ = consider_remaining_unif_problems env !isevars in (* let unevd = undefined_evars evd in *) - let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env evd in + let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in let evm = evars_of unevd' in isevars := unevd'; nf_evar evm j.uj_val, nf_evar evm j.uj_type diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml index 559b6ac1..00d37f35 100644 --- a/contrib/subtac/subtac_pretyping_F.ml +++ b/contrib/subtac/subtac_pretyping_F.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping_F.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: subtac_pretyping_F.ml 11576 2008-11-10 19:13:15Z msozeau $ *) open Pp open Util @@ -276,14 +276,19 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | RApp (loc,f,args) -> let length = List.length args in - let ftycon = - if length > 0 then - match tycon with - | None -> None - | Some (None, ty) -> mk_abstr_tycon length ty - | Some (Some (init, cur), ty) -> - Some (Some (length + init, length + cur), ty) - else tycon + let ftycon = + let ty = + if length > 0 then + match tycon with + | None -> None + | Some (None, ty) -> mk_abstr_tycon length ty + | Some (Some (init, cur), ty) -> + Some (Some (length + init, length + cur), ty) + else tycon + in + match ty with + | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty + | _ -> None in let fj = pretype ftycon env isevars lvar f in let floc = loc_of_rawconstr f in diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml index bae2731a..cdbc4023 100644 --- a/contrib/subtac/subtac_utils.ml +++ b/contrib/subtac/subtac_utils.ml @@ -159,7 +159,7 @@ let app_opt c e = 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 = true) env isevars c = +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: " ++ @@ -232,7 +232,7 @@ let build_dependent_sum l = trace (spc () ++ str ("treating evar " ^ string_of_id n)); (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype) with _ -> ()); - let tac = assert_tac true (Name n) hyptype in + let tac = assert_tac (Name n) hyptype in let conttac = (fun cont -> conttac @@ -369,7 +369,7 @@ let solve_by_tac evi t = Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl (fun _ _ -> ()); Pfedit.by (tclCOMPLETE t); - let _,(const,_,_) = Pfedit.cook_proof ignore in + let _,(const,_,_,_) = Pfedit.cook_proof ignore in Pfedit.delete_current_proof (); const.Entries.const_entry_body with e -> Pfedit.delete_current_proof(); @@ -470,4 +470,3 @@ let tactics_tac s = let tactics_call tac args = TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args)) - diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli index 49335211..964f668f 100644 --- a/contrib/subtac/subtac_utils.mli +++ b/contrib/subtac/subtac_utils.mli @@ -83,7 +83,8 @@ val wf_relations : (constr, constr lazy_t) Hashtbl.t type binders = local_binder list val app_opt : ('a -> 'a) option -> 'a -> 'a val print_args : env -> constr array -> std_ppcmds -val make_existential : loc -> ?opaque:bool -> env -> evar_defs ref -> types -> constr +val make_existential : loc -> ?opaque:obligation_definition_status -> + env -> evar_defs ref -> types -> constr 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/contrib/xml/cic2Xml.ml b/contrib/xml/cic2Xml.ml index f04a03f9..08d3a850 100644 --- a/contrib/xml/cic2Xml.ml +++ b/contrib/xml/cic2Xml.ml @@ -7,7 +7,7 @@ let print_xml_term ch env sigma cic = let seed = ref 0 in let acic = Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids - ids_to_father_ids ids_to_inner_sorts ids_to_inner_types [] + ids_to_father_ids ids_to_inner_sorts ids_to_inner_types env [] sigma (Unshare.unshare cic) None in let xml = Acic2Xml.print_term ids_to_inner_sorts acic in Xml.pp_ch xml ch diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml index 1a6cb9c8..c62db00b 100644 --- a/contrib/xml/cic2acic.ml +++ b/contrib/xml/cic2acic.ml @@ -349,7 +349,7 @@ let source_id_of_id id = "#source#" ^ id;; let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids ids_to_father_ids ids_to_inner_sorts ids_to_inner_types - pvars ?(fake_dependent_products=false) env idrefs evar_map t expectedty + ?(fake_dependent_products=false) env idrefs evar_map t expectedty = let module D = DoubleTypeInference in let module E = Environ in @@ -541,6 +541,8 @@ print_endline "PASSATO" ; flush stdout ; add_inner_type fresh_id'' ; A.ARel (fresh_id'', n, List.nth idrefs (n-1), id) | T.Var id -> + let pvars = Termops.ids_of_named_context (E.named_context env) in + let pvars = List.map N.string_of_id pvars in let path = get_uri_of_var (N.string_of_id id) pvars in Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then @@ -827,6 +829,7 @@ print_endline "PASSATO" ; flush stdout ; aux computeinnertypes None [] env idrefs t ;; +(* Obsolete [HH 1/2009] let acic_of_cic_context metasenv context t = let ids_to_terms = Hashtbl.create 503 in let constr_to_ids = Acic.CicHash.create 503 in @@ -838,8 +841,9 @@ let acic_of_cic_context metasenv context t = ids_to_inner_sorts ids_to_inner_types metasenv context t, ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types ;; +*) -let acic_object_of_cic_object pvars sigma obj = +let acic_object_of_cic_object sigma obj = let module A = Acic in let ids_to_terms = Hashtbl.create 503 in let constr_to_ids = Acic.CicHash.create 503 in @@ -853,7 +857,7 @@ let acic_object_of_cic_object pvars sigma obj = let seed = ref 0 in let acic_term_of_cic_term_context' = acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids - ids_to_inner_sorts ids_to_inner_types pvars in + ids_to_inner_sorts ids_to_inner_types in (*CSC: is this the right env to use? Hhmmm. There is a problem: in *) (*CSC: Global.env () the object we are exporting is already defined, *) (*CSC: either in the environment or in the named context (in the case *) diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4 index 05be01bc..a501fb6a 100644 --- a/contrib/xml/proofTree2Xml.ml4 +++ b/contrib/xml/proofTree2Xml.ml4 @@ -31,7 +31,6 @@ let constr_to_xml obj sigma env = let ids_to_inner_sorts = Hashtbl.create 503 in let ids_to_inner_types = Hashtbl.create 503 in - let pvars = [] in (* named_context holds section variables and local variables *) let named_context = Environ.named_context env in (* real_named_context holds only the section variables *) @@ -54,7 +53,7 @@ let constr_to_xml obj sigma env = try let annobj = Cic2acic.acic_of_cic_context' false seed ids_to_terms constr_to_ids - ids_to_father_ids ids_to_inner_sorts ids_to_inner_types pvars rel_env + ids_to_father_ids ids_to_inner_sorts ids_to_inner_types rel_env idrefs sigma (Unshare.unshare obj') None in Acic2Xml.print_term ids_to_inner_sorts annobj @@ -91,6 +90,7 @@ let string_of_prim_rule x = match x with | Proof_type.Thin _ -> "Thin" | Proof_type.ThinBody _-> "ThinBody" | Proof_type.Move (_,_,_) -> "Move" + | Proof_type.Order _ -> "Order" | Proof_type.Rename (_,_) -> "Rename" | Proof_type.Change_evars -> "Change_evars" diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml index 3c4b01f5..1ae18661 100644 --- a/contrib/xml/xmlcommand.ml +++ b/contrib/xml/xmlcommand.ml @@ -79,15 +79,6 @@ let could_have_namesakes o sp = (* namesake = omonimo in italian *) | _ -> false (* uninteresting thing that won't be printed*) ;; - -(* A SIMPLE DATA STRUCTURE AND SOME FUNCTIONS TO MANAGE THE CURRENT *) -(* ENVIRONMENT (= [(name1,l1); ...;(namen,ln)] WHERE li IS THE LIST *) -(* OF VARIABLES DECLARED IN THE i-th SUPER-SECTION OF THE CURRENT *) -(* SECTION, WHOSE PATH IS namei *) - -let pvars = ref ([] : string list);; -let cumenv = ref Environ.empty_env;; - (* filter_params pvars hyps *) (* filters out from pvars (which is a list of lists) all the variables *) (* that does not belong to hyps (which is a simple list) *) @@ -120,22 +111,6 @@ type variables_type = | Assumption of string * Term.constr ;; -let add_to_pvars x = - let module E = Environ in - let v = - match x with - Definition (v, bod, typ) -> - cumenv := - E.push_named (Names.id_of_string v, Some bod, typ) !cumenv ; - v - | Assumption (v, typ) -> - cumenv := - E.push_named (Names.id_of_string v, None, typ) !cumenv ; - v - in - pvars := v::!pvars -;; - (* The computation is very inefficient, but we can't do anything *) (* better unless this function is reimplemented in the Declare *) (* module. *) @@ -231,7 +206,7 @@ let print_object uri obj sigma proof_tree_infos filename = ignore (Unix.system ("gzip " ^ fn' ^ ".xml")) in let (annobj,_,constr_to_ids,_,ids_to_inner_sorts,ids_to_inner_types,_,_) = - Cic2acic.acic_object_of_cic_object !pvars sigma obj in + Cic2acic.acic_object_of_cic_object sigma obj in let (xml, xml') = Acic2Xml.print_object uri ids_to_inner_sorts annobj in let xmltypes = Acic2Xml.print_inner_types uri ids_to_inner_sorts ids_to_inner_types in @@ -691,7 +666,7 @@ let _ = end ; Option.iter (fun fn -> - let coqdoc = Coq_config.bindir^"/coqdoc" in + let coqdoc = Filename.concat (Envars.coqbin ()) ("coqdoc" ^ Coq_config.exec_extension) in let options = " --html -s --body-only --no-index --latin1 --raw-comments" in let dir = Option.get xml_library_root in let command cmd = diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index b7545e09..cae948a0 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -16,6 +16,11 @@ Eauto: e_resolve_constr, vernac_e_resolve_constr -> simplest_eapply Tactics: apply_with_bindings -> apply_with_bindings_wo_evars Eauto.simplest_apply -> Hiddentac.h_simplest_apply Evarutil.define_evar_as_arrow -> define_evar_as_product +Old version of Tactics.assert_tac disappears +Tactics.true_cut renamed into Tactics.assert_tac +Constrintern.interp_constrpattern -> intern_constr_pattern +Hipattern.match_with_conjunction is a bit more restrictive +Hipattern.match_with_disjunction is a bit more restrictive ** Universe names (univ.mli) diff --git a/dev/ocamldebug-coq.template b/dev/ocamldebug-coq.template index ac5ec1e0..560d06d9 100644 --- a/dev/ocamldebug-coq.template +++ b/dev/ocamldebug-coq.template @@ -17,13 +17,13 @@ exec $OCAMLDEBUG \ -I $COQTOP/library -I $COQTOP/pretyping -I $COQTOP/parsing \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics \ -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config \ - -I $COQTOP/translate \ -I $COQTOP/contrib/extraction -I $COQTOP/contrib/field \ -I $COQTOP/contrib/fourier -I $COQTOP/contrib/firstorder \ - -I $COQTOP/contrib/interface -I $COQTOP/contrib/jprover \ + -I $COQTOP/contrib/interface \ -I $COQTOP/contrib/omega -I $COQTOP/contrib/romega \ -I $COQTOP/contrib/ring -I $COQTOP/contrib/xml \ -I $COQTOP/contrib/subtac -I $COQTOP/contrib/funind \ -I $COQTOP/contrib/rtauto -I $COQTOP/contrib/setoid_ring \ -I $COQTOP/contrib/recdef -I $COQTOP/contrib/dp \ + -I $COQTOP/ide \ $* diff --git a/dev/ocamlweb-doc/Makefile b/dev/ocamlweb-doc/Makefile index 7ab1bd3f..f2c625ed 100644 --- a/dev/ocamlweb-doc/Makefile +++ b/dev/ocamlweb-doc/Makefile @@ -8,7 +8,7 @@ LOCALINCLUDES=-I ../../config -I ../../tools -I ../../tools/coqdoc \ -I ../../contrib/ring -I ../../contrib/dp -I ../../contrib/setoid_ring \ -I ../../contrib/xml -I ../../contrib/extraction \ -I ../../contrib/interface -I ../../contrib/fourier \ - -I ../../contrib/jprover -I ../../contrib/cc \ + -I ../../contrib/cc \ -I ../../contrib/funind -I ../../contrib/firstorder \ -I ../../contrib/field -I ../../contrib/subtac -I ../../contrib/rtauto \ -I ../../contrib/recdef diff --git a/dev/top_printers.ml b/dev/top_printers.ml index a2285015..d7d2f6d8 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -340,7 +340,8 @@ let rec pr_argument_type = function | StringArgType -> str"string" | PreIdentArgType -> str"pre-ident" | IntroPatternArgType -> str"intro-pattern" - | IdentArgType -> str"ident" + | IdentArgType true -> str"ident" + | IdentArgType false -> str"pattern_ident" | VarArgType -> str"var" | RefArgType -> str"ref" (* Specific types *) diff --git a/doc/stdlib/Library.tex b/doc/stdlib/Library.tex index f9764bea..61fa253c 100755 --- a/doc/stdlib/Library.tex +++ b/doc/stdlib/Library.tex @@ -3,7 +3,7 @@ \usepackage[latin1]{inputenc} \usepackage[T1]{fontenc} \usepackage{fullpage} -\usepackage{../../coqdoc} +\usepackage[color]{../../coqdoc} \input{../common/version} \input{../common/title} @@ -61,4 +61,4 @@ you can access from the \Coq\ home page at \end{document} -% $Id: Library.tex 11091 2008-06-10 18:24:52Z notin $ +% $Id: Library.tex 11576 2008-11-10 19:13:15Z msozeau $ diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 5e95a692..0ab4e47b 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -69,6 +69,7 @@ through the Require Import command.

theories/Logic/Description.v theories/Logic/Epsilon.v theories/Logic/IndefiniteDescription.v + theories/Logic/FunctionalExtensionality.v
Bool: @@ -256,12 +257,7 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
theories/Numbers/Rational/BigQ/BigQ.v - theories/Numbers/Rational/BigQ/Q0Make.v - theories/Numbers/Rational/BigQ/QbiMake.v - theories/Numbers/Rational/BigQ/QifMake.v - theories/Numbers/Rational/BigQ/QMake_base.v - theories/Numbers/Rational/BigQ/QpMake.v - theories/Numbers/Rational/BigQ/QvMake.v + theories/Numbers/Rational/BigQ/QMake.v theories/Numbers/Rational/SpecViaQ/QSig.v
@@ -273,8 +269,10 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v theories/Relations/Relation_Operators.v theories/Relations/Relations.v theories/Relations/Operators_Properties.v +
Sets: @@ -314,6 +312,7 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v theories/Classes/Morphisms_Relations.v theories/Classes/Equivalence.v theories/Classes/EquivDec.v + theories/Classes/Functions.v theories/Classes/SetoidTactics.v theories/Classes/SetoidClass.v theories/Classes/SetoidDec.v @@ -321,8 +320,11 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
Setoids: +
theories/Setoids/Setoid.v + theories/Setoids/Setoid_tac.v + theories/Setoids/Setoid_Prop.v
Lists: @@ -477,7 +479,6 @@ theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v theories/Program/Utils.v theories/Program/Syntax.v theories/Program/Program.v - theories/Program/FunctionalExtensionality.v theories/Program/Combinators.v diff --git a/doc/stdlib/make-library-files b/doc/stdlib/make-library-files index add14a13..9516a19f 100755 --- a/doc/stdlib/make-library-files +++ b/doc/stdlib/make-library-files @@ -1,6 +1,6 @@ #!/bin/sh -# Needs COQTOP and GALLINA set +# Needs COQSRC and GALLINA set # On garde la liste de tous les *.v avec dates dans library.files.ls # Si elle a change depuis la derniere fois ou library.files n'existe pas @@ -13,12 +13,12 @@ LIBDIRS="Arith NArith ZArith Reals Logic Bool Lists Relations Sets Sorting Wellfounded Setoids Program Classes" rm -f library.files.ls.tmp -(cd $COQTOP/theories; find $LIBDIR -name "*.v" -ls) > library.files.ls.tmp +(cd $COQSRC/theories; find $LIBDIR -name "*.v" -ls) > library.files.ls.tmp if ! test -e library.files || ! cmp library.files.ls library.files.ls.tmp; then mv -f library.files.ls.tmp library.files.ls rm -f library.files; touch library.files ABSOLUTE=`pwd`/library.files - cd $COQTOP/theories + cd $COQSRC/theories echo $LIBDIRS for rep in $LIBDIRS ; do (cd $rep diff --git a/ide/coq.ico b/ide/coq.ico deleted file mode 100644 index b99f6399..00000000 Binary files a/ide/coq.ico and /dev/null differ diff --git a/ide/coq.ml b/ide/coq.ml index c560f0db..e2649c82 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coq.ml 11238 2008-07-19 09:34:03Z herbelin $ *) +(* $Id: coq.ml 11826 2009-01-22 06:43:35Z notin $ *) open Vernac open Vernacexpr @@ -58,7 +58,7 @@ let get_version_date () = then Coq_config.date else "" in try - let ch = open_in (Coq_config.coqtop^"/revision") in + let ch = open_in (Coq_config.coqsrc^"/revision") in let ver = input_line ch in let rev = input_line ch in (ver,rev) @@ -79,7 +79,7 @@ let version () = ver date Coq_config.arch Sys.os_type (let x,y,z = GMain.Main.version in Printf.sprintf "%d.%d.%d" x y z) - (if Mltop.get () = Mltop.Native then "native" else "bytecode") + (if Mltop.is_native then "native" else "bytecode") (if Coq_config.best="opt" then "native" else "bytecode") let is_in_coq_lib dir = @@ -88,7 +88,7 @@ let is_in_coq_lib dir = List.exists (fun s -> let fdir = - Filename.concat Coq_config.coqlib (Filename.concat "theories" s) in + Filename.concat (Envars.coqlib ()) (Filename.concat "theories" s) in prerr_endline (" Comparing to: "^fdir); if is_same_file fdir then (prerr_endline " YES";true) else (prerr_endline"NO";false)) @@ -230,7 +230,6 @@ let rec attribute_of_vernac_command = function (* Gallina extensions *) | VernacBeginSection _ -> [] | VernacEndSegment _ -> [] - | VernacRecord _ -> [] | VernacRequire _ -> [] | VernacImport _ -> [] | VernacCanonical _ -> [] @@ -238,7 +237,6 @@ let rec attribute_of_vernac_command = function | VernacIdentityCoercion _ -> [] (* Type classes *) - | VernacClass _ -> [] | VernacInstance _ -> [] | VernacContext _ -> [] | VernacDeclareInstance _ -> [] @@ -273,6 +271,7 @@ let rec attribute_of_vernac_command = function (* Commands *) | VernacDeclareTacticDefinition _ -> [] + | VernacCreateHintDb _ -> [] | VernacHints _ -> [] | VernacSyntacticDefinition _ -> [] | VernacDeclareImplicits _ -> [] @@ -386,7 +385,7 @@ let compute_reset_info = function | VernacDefinition (_, (_,id), DefineBody _, _) | VernacAssumption (_,_ ,(_,((_,id)::_,_))::_) - | VernacInductive (_, (((_,id),_,_,_),_) :: _) -> + | VernacInductive (_, (((_,(_,id)),_,_,_,_),_) :: _) -> ResetAtRegisteredObject (reset_mark id), undo_info(), ref true | com when is_vernac_proof_ending_command com -> NoReset, undo_info(), ref true diff --git a/ide/coqide.ml b/ide/coqide.ml index 07ee698f..ea2dfe4d 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coqide.ml 11221 2008-07-11 23:28:25Z herbelin $ *) +(* $Id: coqide.ml 11853 2009-01-23 18:40:58Z notin $ *) open Preferences open Vernacexpr @@ -482,10 +482,11 @@ let input_channel b ic = Buffer.add_substring b buf 0 !len done -let with_file name ~f = - let ic = open_in_gen [Open_rdonly;Open_creat] 0o644 name in - try f ic; close_in ic with exn -> - close_in ic; !flash_info ("Error: "^Printexc.to_string exn) +let with_file handler name ~f = + try + let ic = open_in_gen [Open_rdonly;Open_creat] 0o644 name in + try f ic; close_in ic with e -> close_in ic; raise e + with Sys_error s -> handler s type info = {start:GText.mark; stop:GText.mark; @@ -713,7 +714,7 @@ object(self) try if is_active then self#reset_initial; let b = Buffer.create 1024 in - with_file f ~f:(input_channel b); + with_file !flash_info f ~f:(input_channel b); let s = try_convert (Buffer.contents b) in input_buffer#set_text s; self#update_stats; @@ -1839,7 +1840,7 @@ let main files = ~title:"CoqIde" () in (try - let icon_image = lib_ide_file "coq.ico" in + let icon_image = lib_ide_file "coq.png" in let icon = GdkPixbuf.from_file icon_image in w#set_icon (Some icon) with _ -> ()); @@ -1871,7 +1872,7 @@ let main files = let file_factory = new GMenu.factory ~accel_path:"/File/" file_menu ~accel_group in (* File/Load Menu *) - let load f = + let load_file handler f = let f = absolute_filename f in try prerr_endline "Loading file starts"; @@ -1886,7 +1887,7 @@ let main files = prerr_endline "Loading: must open"; let b = Buffer.create 1024 in prerr_endline "Loading: get raw content"; - with_file f ~f:(input_channel b); + with_file handler f ~f:(input_channel b); prerr_endline "Loading: convert content"; let s = do_convert (Buffer.contents b) in prerr_endline "Loading: create view"; @@ -1922,8 +1923,9 @@ let main files = prerr_endline "Loading: success" with | Vector.Found i -> set_current_view i - | e -> !flash_info ("Load failed: "^(Printexc.to_string e)) + | e -> handler ("Load failed: "^(Printexc.to_string e)) in + let load f = load_file !flash_info f in let load_m = file_factory#add_item "_New" ~key:GdkKeysyms._N in let load_f () = @@ -2478,7 +2480,7 @@ let main files = (fun () -> let av = Option.get ((get_current_view()).analyzed_view) in match av#filename with - | None -> () + | None -> warning "Call to external editor available only on named files" | Some f -> save_f (); let com = Flags.subst_command_placeholder !current.cmd_editor (Filename.quote f) in @@ -3632,9 +3634,9 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); begin List.iter (fun f -> if Sys.file_exists f then load f else - if Filename.check_suffix f ".v" - then load f - else load (f^".v")) files; + let f = if Filename.check_suffix f ".v" then f else f^".v" in + load_file (fun s -> print_endline s; exit 1) f) + files; activate_input 0 end else diff --git a/ide/highlight.mll b/ide/highlight.mll index 8cd55c97..f2ecaa9c 100644 --- a/ide/highlight.mll +++ b/ide/highlight.mll @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: highlight.mll 11004 2008-05-28 09:09:12Z herbelin $ *) +(* $Id: highlight.mll 11481 2008-10-20 19:23:51Z herbelin $ *) { @@ -110,13 +110,16 @@ rule next_starting_order = parse | multiword_command { starting:=false; lexeme_start lexbuf, lexeme_end lexbuf, "kwd" } | ident as id - { starting:=false; - if is_one_word_command id then - lexeme_start lexbuf, lexeme_end lexbuf, "kwd" - else if is_one_word_declaration id then - lexeme_start lexbuf, lexeme_end lexbuf, "decl" - else - next_interior_order lexbuf + { if id = "Time" then next_starting_order lexbuf else + begin + starting:=false; + if is_one_word_command id then + lexeme_start lexbuf, lexeme_end lexbuf, "kwd" + else if is_one_word_declaration id then + lexeme_start lexbuf, lexeme_end lexbuf, "decl" + else + next_interior_order lexbuf + end } | _ { starting := false; next_interior_order lexbuf} | eof { raise End_of_file } diff --git a/ide/ideutils.ml b/ide/ideutils.ml index d851dc2f..d9b5e572 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ideutils.ml 11093 2008-06-10 18:41:33Z barras $ *) +(* $Id: ideutils.ml 11749 2009-01-05 14:01:04Z notin $ *) open Preferences @@ -33,10 +33,7 @@ let prerr_string s = if !debug then (prerr_string s;flush stderr) let lib_ide_file f = - let coqlib = - System.getenv_else "COQLIB" - (if Coq_config.local || !Flags.boot then Coq_config.coqtop - else Coq_config.coqlib) in + let coqlib = Envars.coqlib () in Filename.concat (Filename.concat coqlib "ide") f let get_insert input_buffer = input_buffer#get_iter_at_mark `INSERT diff --git a/ide/undo_lablgtk_ge212.mli b/ide/undo_lablgtk_ge212.mli new file mode 100644 index 00000000..916a06e9 --- /dev/null +++ b/ide/undo_lablgtk_ge212.mli @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Gtk.text_view] Gtk.obj -> +object + inherit GText.view + method undo : bool + method redo : bool + method clear_undo : unit +end + +val undoable_view : + ?buffer:GText.buffer -> + ?editable:bool -> + ?cursor_visible:bool -> + ?justification:GtkEnums.justification -> + ?wrap_mode:GtkEnums.wrap_mode -> + ?accepts_tab:bool -> + ?border_width:int -> + ?width:int -> + ?height:int -> + ?packing:(GObj.widget -> unit) -> + ?show:bool -> + unit -> + undoable_view + + diff --git a/install.sh b/install.sh new file mode 100755 index 00000000..0719ca77 --- /dev/null +++ b/install.sh @@ -0,0 +1,13 @@ +#! /bin/sh + +dest=$1 +shift + +for f; do + bn=`basename $f` + dn=`dirname $f` + install -d $dest/$dn + install -m 644 $f $dest/$dn/$bn +done + + diff --git a/interp/constrextern.ml b/interp/constrextern.ml index efb6c853..f99af68e 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: constrextern.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: constrextern.ml 11576 2008-11-10 19:13:15Z msozeau $ *) (*i*) open Pp @@ -190,8 +190,9 @@ let rec check_same_type ty1 ty2 = check_same_type b1 b2 | CCast(_,a1,CastCoerce), CCast(_,a2, CastCoerce) -> check_same_type a1 a2 - | CNotation(_,n1,e1), CNotation(_,n2,e2) when n1=n2 -> - List.iter2 check_same_type e1 e2 + | CNotation(_,n1,(e1,el1)), CNotation(_,n2,(e2,el2)) when n1=n2 -> + List.iter2 check_same_type e1 e2; + List.iter2 (List.iter2 check_same_type) el1 el2 | CPrim(_,i1), CPrim(_,i2) when i1=i2 -> () | CDelimiters(_,s1,e1), CDelimiters(_,s2,e2) when s1=s2 -> check_same_type e1 e2 @@ -298,7 +299,7 @@ and spaces ntn n = if n = String.length ntn then [] else if ntn.[n] = ' ' then wildcards ntn (n+1) else spaces ntn (n+1) -let expand_curly_brackets loc mknot ntn l = +let expand_curly_brackets loc mknot ntn (l,ll) = let ntn' = ref ntn in let rec expand_ntn i = function @@ -311,12 +312,12 @@ let expand_curly_brackets loc mknot ntn l = ntn' := String.sub !ntn' 0 p ^ "_" ^ String.sub !ntn' (p+5) (String.length !ntn' -p-5); - mknot (loc,"{ _ }",[a]) end + mknot (loc,"{ _ }",([a],[])) end else a in a' :: expand_ntn (i+1) l in let l = expand_ntn 0 l in (* side effect *) - mknot (loc,!ntn',l) + mknot (loc,!ntn',(l,ll)) let destPrim = function CPrim(_,t) -> Some t | _ -> None let destPatPrim = function CPatPrim(_,t) -> Some t | _ -> None @@ -324,18 +325,18 @@ let destPatPrim = function CPatPrim(_,t) -> Some t | _ -> None let make_notation_gen loc ntn mknot mkprim destprim l = if has_curly_brackets ntn then expand_curly_brackets loc mknot ntn l - else match ntn,List.map destprim l with + else match ntn,List.map destprim (fst l),(snd l) with (* Special case to avoid writing "- 3" for e.g. (Zopp 3) *) - | "- _", [Some (Numeral p)] when Bigint.is_strictly_pos p -> - mknot (loc,ntn,[mknot (loc,"( _ )",l)]) + | "- _", [Some (Numeral p)],[] when Bigint.is_strictly_pos p -> + mknot (loc,ntn,([mknot (loc,"( _ )",l)],[])) | _ -> match decompose_notation_key ntn, l with - | [Terminal "-"; Terminal x], [] -> + | [Terminal "-"; Terminal x], ([],[]) -> (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x))) - with _ -> mknot (loc,ntn,[])) - | [Terminal x], [] -> + with _ -> mknot (loc,ntn,([],[]))) + | [Terminal x], ([],[]) -> (try mkprim (loc, Numeral (Bigint.of_string x)) - with _ -> mknot (loc,ntn,[])) + with _ -> mknot (loc,ntn,([],[]))) | _ -> mknot (loc,ntn,l) @@ -351,13 +352,13 @@ let make_pat_notation loc ntn l = (fun (loc,p) -> CPatPrim (loc,p)) destPatPrim l -let bind_env sigma var v = +let bind_env (sigma,sigmalist as fullsigma) var v = try let vvar = List.assoc var sigma in - if v=vvar then sigma else raise No_match + if v=vvar then fullsigma else raise No_match with Not_found -> (* TODO: handle the case of multiple occs in different scopes *) - (var,v)::sigma + (var,v)::sigma,sigmalist let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with | r1, AVar id2 when List.mem id2 metas -> bind_env sigma id2 r1 @@ -378,15 +379,18 @@ let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with (* All parameters must be _ *) List.iter (function AHole _ -> () | _ -> raise No_match) p2; List.fold_left2 (match_cases_pattern metas) sigma args1 args2 + (* TODO: use recursive notations *) | _ -> raise No_match -let match_aconstr_cases_pattern c (metas_scl,pat) = - let subst = match_cases_pattern (List.map fst metas_scl) [] c pat in +let match_aconstr_cases_pattern c ((metas_scl,metaslist_scl),pat) = + let vars = List.map fst metas_scl @ List.map fst metaslist_scl in + let subst,substlist = match_cases_pattern vars ([],[]) c pat in (* Reorder canonically the substitution *) let find x subst = - try List.assoc x subst + try List.assoc x subst with Not_found -> anomaly "match_aconstr_cases_pattern" in - List.map (fun (x,scl) -> (find x subst,scl)) metas_scl + List.map (fun (x,scl) -> (find x subst,scl)) metas_scl, + List.map (fun (x,scl) -> (find x substlist,scl)) metaslist_scl (* Better to use extern_rawconstr composed with injection/retraction ?? *) let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = @@ -424,7 +428,7 @@ and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function | PatCstr (loc,_,_,na),_ -> loc,na | PatVar (loc,na),_ -> loc,na in (* Try matching ... *) - let subst = match_aconstr_cases_pattern t pat in + let subst,substlist = match_aconstr_cases_pattern t pat in (* Try availability of interpretation ... *) let p = match keyrule with | NotationRule (sc,ntn) -> @@ -438,7 +442,13 @@ and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function List.map (fun (c,(scopt,scl)) -> extern_cases_pattern_in_scope (scopt,scl@scopes') vars c) subst in - insert_pat_delimiters loc (make_pat_notation loc ntn l) key) + let ll = + List.map (fun (c,(scopt,scl)) -> + let subscope = (scopt,scl@scopes') in + List.map (extern_cases_pattern_in_scope subscope vars) c) + substlist in + insert_pat_delimiters loc + (make_pat_notation loc ntn (l,ll)) key) | SynDefRule kn -> let qid = shortest_qualid_of_syndef vars kn in CPatAtom (loc,Some (Qualid (loc, qid))) in @@ -544,15 +554,10 @@ let rec remove_coercions inctx = function (* We skip a coercion *) let l = list_skipn n args in let (a,l) = match l with a::l -> (a,l) | [] -> assert false in - let (a,l) = - (* Recursively remove the head coercions *) - match remove_coercions true a with - | RApp (_,a,l') -> a,l'@l - | a -> a,l in - if l = [] then a - else - (* Recursively remove coercions in arguments *) - RApp (loc,a,List.map (remove_coercions true) l) + (* Recursively remove the head coercions *) + (match remove_coercions true a with + | RApp (_,a,l') -> RApp (loc,a,l'@l) + | a -> RApp (loc,a,l)) | _ -> c with Not_found -> c) | c -> c @@ -671,7 +676,7 @@ let rec extern inctx scopes vars r = let t = extern_typ scopes vars (anonymize_if_reserved na t) in let (idl,c) = factorize_lambda inctx scopes (add_vname vars na) t c in CLambdaN (loc,[(dummy_loc,na)::idl,Default bk,t],c) - + | RCases (loc,sty,rtntypopt,tml,eqns) -> let vars' = List.fold_right (name_fold Idset.add) @@ -694,7 +699,7 @@ let rec extern inctx scopes vars r = | Name id -> RVar (dummy_loc,id)) nal in let t = RApp (dummy_loc,RRef (dummy_loc,IndRef ind),params@args) in (extern_typ scopes vars t)) x))) tml in - let eqns = List.map (extern_eqn (rtntypopt<>None) scopes vars) eqns in + let eqns = List.map (extern_eqn inctx scopes vars) eqns in CCases (loc,sty,rtntypopt',tml,eqns) | RLetTuple (loc,nal,(na,typopt),tm,b) -> @@ -702,13 +707,13 @@ let rec extern inctx scopes vars r = (Option.map (fun _ -> na) typopt, Option.map (extern_typ scopes (add_vname vars na)) typopt), sub_extern false scopes vars tm, - extern false scopes (List.fold_left add_vname vars nal) b) + extern inctx scopes (List.fold_left add_vname vars nal) b) | RIf (loc,c,(na,typopt),b1,b2) -> CIf (loc,sub_extern false scopes vars c, (Option.map (fun _ -> na) typopt, Option.map (extern_typ scopes (add_vname vars na)) typopt), - sub_extern false scopes vars b1, sub_extern false scopes vars b2) + sub_extern inctx scopes vars b1, sub_extern inctx scopes vars b2) | RRec (loc,fk,idv,blv,tyv,bv) -> let vars' = Array.fold_right Idset.add idv vars in @@ -822,7 +827,7 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function | _, None -> t,[] | _ -> raise No_match in (* Try matching ... *) - let subst = match_aconstr t pat in + let subst,substlist = match_aconstr t pat in (* Try availability of interpretation ... *) let e = match keyrule with @@ -838,7 +843,11 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function extern (* assuming no overloading: *) true (scopt,scl@scopes') vars c) subst in - insert_delimiters (make_notation loc ntn l) key) + let ll = + List.map (fun (c,(scopt,scl)) -> + List.map (extern true (scopt,scl@scopes') vars) c) + substlist in + insert_delimiters (make_notation loc ntn (l,ll)) key) | SynDefRule kn -> let l = List.map (fun (c,(scopt,scl)) -> diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 9af7e769..8d6a92a2 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: constrintern.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: constrintern.ml 11739 2009-01-02 19:33:19Z herbelin $ *) open Pp open Util @@ -24,10 +24,63 @@ open Nametab open Notation open Inductiveops +open Decl_kinds + +let type_of_logical_kind = + function + | IsDefinition def -> + (match def with + | Definition -> "def" + | Coercion -> "coe" + | SubClass -> "subclass" + | CanonicalStructure -> "canonstruc" + | Example -> "ex" + | Fixpoint -> "def" + | CoFixpoint -> "def" + | Scheme -> "scheme" + | StructureComponent -> "proj" + | IdentityCoercion -> "coe" + | Instance -> "inst" + | Method -> "meth") + | IsAssumption a -> + (match a with + | Definitional -> "defax" + | Logical -> "prfax" + | Conjectural -> "prfax") + | IsProof th -> + (match th with + | Theorem + | Lemma + | Fact + | Remark + | Property + | Proposition + | Corollary -> "thm") + +let type_of_global_ref gr = + if Typeclasses.is_class gr then + "class" + else + match gr with + | ConstRef cst -> + type_of_logical_kind (Decls.constant_kind cst) + | VarRef v -> + "var" ^ type_of_logical_kind (Decls.variable_kind v) + | IndRef ind -> + let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in + if mib.Declarations.mind_record then + if mib.Declarations.mind_finite then "rec" + else "corec" + else if mib.Declarations.mind_finite then "ind" + else "coind" + | ConstructRef _ -> "constr" + (* To interpret implicits and arg scopes of recursive variables in inductive types and recursive definitions *) +type var_internalisation_type = Inductive | Recursive | Method + type var_internalisation_data = - identifier list * Impargs.implicits_list * scope_name option list + var_internalisation_type * identifier list * Impargs.implicits_list * scope_name option list type implicits_env = (identifier * var_internalisation_data) list type full_implicits_env = identifier list * implicits_env @@ -125,150 +178,6 @@ let error_inductive_parameter_not_implicit loc = ("The parameters of inductive types do not bind in\n"^ "the 'return' clauses; they must be replaced by '_' in the 'in' clauses.")) -(**********************************************************************) -(* Dump of globalization (to be used by coqdoc) *) -let token_number = ref 0 -let last_pos = ref 0 - -type coqdoc_state = Lexer.location_table * int * int - -let coqdoc_freeze () = - let lt = Lexer.location_table() in - let state = (lt,!token_number,!last_pos) in - token_number := 0; - last_pos := 0; - state - -let coqdoc_unfreeze (lt,tn,lp) = - Lexer.restore_location_table lt; - token_number := tn; - last_pos := lp - -open Decl_kinds - -let type_of_logical_kind = function - | IsDefinition def -> - (match def with - | Definition -> "def" - | Coercion -> "coe" - | SubClass -> "subclass" - | CanonicalStructure -> "canonstruc" - | Example -> "ex" - | Fixpoint -> "def" - | CoFixpoint -> "def" - | Scheme -> "scheme" - | StructureComponent -> "proj" - | IdentityCoercion -> "coe" - | Instance -> "inst" - | Method -> "meth") - | IsAssumption a -> - (match a with - | Definitional -> "defax" - | Logical -> "prfax" - | Conjectural -> "prfax") - | IsProof th -> - (match th with - | Theorem - | Lemma - | Fact - | Remark - | Property - | Proposition - | Corollary -> "thm") - -let type_of_global_ref gr = - if Typeclasses.is_class gr then - "class" - else - match gr with - | ConstRef cst -> - type_of_logical_kind (Decls.constant_kind cst) - | VarRef v -> - "var" ^ type_of_logical_kind (Decls.variable_kind v) - | IndRef ind -> - let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in - if mib.Declarations.mind_record then - if mib.Declarations.mind_finite then "rec" - else "corec" - else if mib.Declarations.mind_finite then "ind" - else "coind" - | ConstructRef _ -> "constr" - -let remove_sections dir = - if is_dirpath_prefix_of dir (Lib.cwd ()) then - (* Not yet (fully) discharged *) - extract_dirpath_prefix (Lib.sections_depth ()) (Lib.cwd ()) - else - (* Theorem/Lemma outside its outer section of definition *) - dir - -let dump_reference loc filepath modpath ident ty = - dump_string (Printf.sprintf "R%d %s %s %s %s\n" - (fst (unloc loc)) filepath modpath ident ty) - -let add_glob_gen loc sp lib_dp ty = - let mod_dp,id = repr_path sp in - let mod_dp = remove_sections mod_dp in - let mod_dp_trunc = drop_dirpath_prefix lib_dp mod_dp in - let filepath = string_of_dirpath lib_dp in - let modpath = string_of_dirpath mod_dp_trunc in - let ident = string_of_id id in - dump_reference loc filepath modpath ident ty - -let add_glob loc ref = - let sp = Nametab.sp_of_global ref in - let lib_dp = Lib.library_part ref in - let ty = type_of_global_ref ref in - add_glob_gen loc sp lib_dp ty - -let add_glob loc ref = - if !Flags.dump && loc <> dummy_loc then add_glob loc ref - -let mp_of_kn kn = - let mp,sec,l = repr_kn kn in - MPdot (mp,l) - -let add_glob_kn loc kn = - let sp = Nametab.sp_of_syntactic_definition kn in - let lib_dp = Lib.dp_of_mp (mp_of_kn kn) in - add_glob_gen loc sp lib_dp "syndef" - -let add_glob_kn loc ref = - if !Flags.dump && loc <> dummy_loc then add_glob_kn loc ref - -let add_local loc id = () -(* let mod_dp,id = repr_path sp in *) -(* let mod_dp = remove_sections mod_dp in *) -(* let mod_dp_trunc = drop_dirpath_prefix lib_dp mod_dp in *) -(* let filepath = string_of_dirpath lib_dp in *) -(* let modpath = string_of_dirpath mod_dp_trunc in *) -(* let ident = string_of_id id in *) -(* dump_string (Printf.sprintf "R%d %s %s %s %s\n" *) -(* (fst (unloc loc)) filepath modpath ident ty) *) - -let dump_binding loc id = () - -let loc_of_notation f loc args ntn = - if args=[] or ntn.[0] <> '_' then fst (unloc loc) - else snd (unloc (f (List.hd args))) - -let ntn_loc = loc_of_notation constr_loc -let patntn_loc = loc_of_notation cases_pattern_expr_loc - -let dump_notation_location pos ((path,df),sc) = - let rec next growing = - let loc = Lexer.location_function !token_number in - let (bp,_) = unloc loc in - if growing then if bp >= pos then loc else (incr token_number;next true) - else if bp = pos then loc - else if bp > pos then (decr token_number;next false) - else (incr token_number;next true) in - let loc = next (pos >= !last_pos) in - last_pos := pos; - let path = string_of_dirpath path in - let _sc = match sc with Some sc -> " "^sc | None -> "" in - dump_string (Printf.sprintf "R%d %s \"%s\" not\n" (fst (unloc loc)) path df) - (**********************************************************************) (* Contracting "{ _ }" in notations *) @@ -289,38 +198,38 @@ let expand_notation_string ntn n = (* This contracts the special case of "{ _ }" for sumbool, sumor notations *) (* Remark: expansion of squash at definition is done in metasyntax.ml *) -let contract_notation ntn l = +let contract_notation ntn (l,ll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | CNotation (_,"{ _ }",[a]) :: l -> + | CNotation (_,"{ _ }",([a],[])) :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> a::contract_squash (n+1) l in let l = contract_squash 0 l in (* side effect; don't inline *) - !ntn',l + !ntn',(l,ll) -let contract_pat_notation ntn l = +let contract_pat_notation ntn (l,ll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | CPatNotation (_,"{ _ }",[a]) :: l -> + | CPatNotation (_,"{ _ }",([a],[])) :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> a::contract_squash (n+1) l in let l = contract_squash 0 l in (* side effect; don't inline *) - !ntn',l + !ntn',(l,ll) (**********************************************************************) (* Remembering the parsing scope of variables in notations *) let make_current_scope (tmp_scope,scopes) = Option.List.cons tmp_scope scopes -let set_var_scope loc id (_,scopt,scopes) varscopes = +let set_var_scope loc id (_,_,scopt,scopes) varscopes = let idscopes = List.assoc id varscopes in if !idscopes <> None & make_current_scope (Option.get !idscopes) @@ -333,38 +242,37 @@ let set_var_scope loc id (_,scopt,scopes) varscopes = (**********************************************************************) (* Syntax extensions *) -let traverse_binder subst (renaming,(ids,tmpsc,scopes as env)) id = +let traverse_binder (subst,substlist) (renaming,(ids,unb,tmpsc,scopes as env)) id = try (* Binders bound in the notation are considered first-order objects *) let _,id' = coerce_to_id (fst (List.assoc id subst)) in - (renaming,(Idset.add id' ids,tmpsc,scopes)), id' + (renaming,(Idset.add id' ids,unb,tmpsc,scopes)), id' with Not_found -> (* Binders not bound in the notation do not capture variables *) (* outside the notation (i.e. in the substitution) *) let fvs1 = List.map (fun (_,(c,_)) -> free_vars_of_constr_expr c) subst in - let fvs2 = List.map snd renaming in - let fvs = List.flatten (List.map Idset.elements fvs1) @ fvs2 in + let fvs2 = List.flatten (List.map (fun (_,(l,_)) -> List.map free_vars_of_constr_expr l) substlist) in + let fvs3 = List.map snd renaming in + let fvs = List.flatten (List.map Idset.elements (fvs1@fvs2)) @ fvs3 in let id' = next_ident_away id fvs in let renaming' = if id=id' then renaming else (id,id')::renaming in (renaming',env), id' -let decode_constrlist_value = function - | CAppExpl (_,_,l) -> l - | _ -> anomaly "Ill-formed list argument of notation" - let rec subst_iterator y t = function | RVar (_,id) as x -> if id = y then t else x | x -> map_rawconstr (subst_iterator y t) x -let rec subst_aconstr_in_rawconstr loc interp subst (renaming,(ids,_,scopes)) = - function +let rec subst_aconstr_in_rawconstr loc interp (subst,substlist as sub) infos c = + let (renaming,(ids,unb,_,scopes)) = infos in + let subinfos = renaming,(ids,unb,None,scopes) in + match c with | AVar id -> begin (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) try let (a,(scopt,subscopes)) = List.assoc id subst in - interp (ids,scopt,subscopes@scopes) a + interp (ids,unb,scopt,subscopes@scopes) a with Not_found -> try RVar (loc,List.assoc id renaming) @@ -375,36 +283,33 @@ let rec subst_aconstr_in_rawconstr loc interp subst (renaming,(ids,_,scopes)) = | AList (x,_,iter,terminator,lassoc) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) - let (a,(scopt,subscopes)) = List.assoc x subst in + let (l,(scopt,subscopes)) = List.assoc x substlist in let termin = - subst_aconstr_in_rawconstr loc interp subst - (renaming,(ids,None,scopes)) terminator in - let l = decode_constrlist_value a in + subst_aconstr_in_rawconstr loc interp sub subinfos terminator in List.fold_right (fun a t -> subst_iterator ldots_var t (subst_aconstr_in_rawconstr loc interp - ((x,(a,(scopt,subscopes)))::subst) - (renaming,(ids,None,scopes)) iter)) + ((x,(a,(scopt,subscopes)))::subst,substlist) subinfos iter)) (if lassoc then List.rev l else l) termin with Not_found -> anomaly "Inconsistent substitution of recursive notation") | t -> - rawconstr_of_aconstr_with_binders loc (traverse_binder subst) - (subst_aconstr_in_rawconstr loc interp subst) - (renaming,(ids,None,scopes)) t + rawconstr_of_aconstr_with_binders loc (traverse_binder sub) + (subst_aconstr_in_rawconstr loc interp sub) subinfos t -let intern_notation intern (_,tmp_scope,scopes as env) loc ntn args = - let ntn,args = contract_notation ntn args in - let ((ids,c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in - if !dump then dump_notation_location (ntn_loc loc args ntn) df; - let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids args in - subst_aconstr_in_rawconstr loc intern subst ([],env) c +let intern_notation intern (_,_,tmp_scope,scopes as env) loc ntn fullargs = + let ntn,(args,argslist) = contract_notation ntn fullargs in + let (((ids,idsl),c),df) = interp_notation loc ntn (tmp_scope,scopes) in + Dumpglob.dump_notation_location (Topconstr.ntn_loc loc args ntn) df; + let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids args in + let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl argslist in + subst_aconstr_in_rawconstr loc intern (subst,substlist) ([],env) c -let set_type_scope (ids,tmp_scope,scopes) = - (ids,Some Notation.type_scope,scopes) +let set_type_scope (ids,unb,tmp_scope,scopes) = + (ids,unb,Some Notation.type_scope,scopes) -let reset_tmp_scope (ids,tmp_scope,scopes) = - (ids,None,scopes) +let reset_tmp_scope (ids,unb,tmp_scope,scopes) = + (ids,unb,None,scopes) let rec it_mkRProd env body = match env with @@ -423,19 +328,26 @@ let rec it_mkRLambda env body = [vars2] is the set of global variables, env is the set of variables abstracted until this point *) -let intern_var (env,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) loc id = +let string_of_ty = function + | Inductive -> "ind" + | Recursive -> "def" + | Method -> "meth" + +let intern_var (env,unbound_vars,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) loc id = let (vars1,unbndltacvars) = ltacvars in (* Is [id] an inductive type potentially with implicit *) try - let l,impl,argsc = List.assoc id impls in + let ty, l,impl,argsc = List.assoc id impls in let l = List.map (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) l in - RVar (loc,id), impl, argsc, l + let tys = string_of_ty ty in + Dumpglob.dump_reference loc "<>" (string_of_id id) tys; + RVar (loc,id), impl, argsc, l with Not_found -> (* Is [id] bound in current env or is an ltac var bound to constr *) if Idset.mem id env or List.mem id vars1 then - RVar (loc,id), [], [], [] + RVar (loc,id), [], [], [] (* Is [id] a notation variable *) else if List.mem_assoc id vars3 then @@ -449,17 +361,17 @@ let intern_var (env,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) loc id = str "variable " ++ pr_id id ++ str " should be bound to a term.") | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0 with Not_found -> - (* Is [id] a goal or section variable *) - let _ = Sign.lookup_named id vars2 in - try - (* [id] a section variable *) - (* Redundant: could be done in intern_qualid *) - let ref = VarRef id in - RRef (loc, ref), implicits_of_global ref, find_arguments_scope ref, [] - with _ -> - (* [id] a goal variable *) - RVar (loc,id), [], [], [] - + (* Is [id] a goal or section variable *) + let _ = Sign.lookup_named id vars2 in + try + (* [id] a section variable *) + (* Redundant: could be done in intern_qualid *) + let ref = VarRef id in + RRef (loc, ref), implicits_of_global ref, find_arguments_scope ref, [] + with _ -> + (* [id] a goal variable *) + RVar (loc,id), [], [], [] + let find_appl_head_data (_,_,_,(_,impls)) = function | RRef (_,ref) as x -> x,implicits_of_global ref,find_arguments_scope ref,[] | x -> x,[],[],[] @@ -478,17 +390,17 @@ let check_no_explicitation l = let intern_qualid loc qid intern env args = try match Nametab.extended_locate qid with | TrueGlobal ref -> - add_glob loc ref; + Dumpglob.add_glob loc ref; RRef (loc, ref), args | SyntacticDef sp -> - add_glob_kn loc sp; + Dumpglob.add_glob_kn loc sp; let (ids,c) = Syntax_def.search_syntactic_definition loc sp in let nids = List.length ids in if List.length args < nids then error_not_enough_arguments loc; let args1,args2 = list_chop nids args in check_no_explicitation args1; let subst = List.map2 (fun (id,scl) a -> (id,(fst a,scl))) ids args1 in - subst_aconstr_in_rawconstr loc intern subst ([],env) c, args2 + subst_aconstr_in_rawconstr loc intern (subst,[]) ([],env) c, args2 with Not_found -> error_global_not_found_loc loc qid @@ -498,10 +410,10 @@ let intern_non_secvar_qualid loc qid intern env args = | RRef (loc, VarRef id),_ -> error_global_not_found_loc loc qid | r -> r -let intern_applied_reference intern env lvar args = function +let intern_applied_reference intern (_, unb, _, _ as env) lvar args = function | Qualid (loc, qid) -> let r,args2 = intern_qualid loc qid intern env args in - find_appl_head_data lvar r, args2 + find_appl_head_data lvar r, args2 | Ident (loc, id) -> try intern_var env lvar loc id, args with Not_found -> @@ -511,18 +423,19 @@ let intern_applied_reference intern env lvar args = function find_appl_head_data lvar r, args2 with e -> (* Extra allowance for non globalizing functions *) - if !interning_grammar then (RVar (loc,id), [], [], []),args + if !interning_grammar || unb then + (RVar (loc,id), [], [], []),args else raise e - + let interp_reference vars r = let (r,_,_,_),_ = intern_applied_reference (fun _ -> error_not_enough_arguments dummy_loc) - (Idset.empty,None,[]) (vars,[],[],([],[])) [] r + (Idset.empty,false,None,[]) (vars,[],[],([],[])) [] r in r -let apply_scope_env (ids,_,scopes) = function - | [] -> (ids,None,scopes), [] - | sc::scl -> (ids,sc,scopes), scl +let apply_scope_env (ids,unb,_,scopes) = function + | [] -> (ids,unb,None,scopes), [] + | sc::scl -> (ids,unb,sc,scopes), scl let rec adjust_scopes env scopes = function | [] -> [] @@ -595,8 +508,8 @@ let check_constructor_length env loc cstr pl pl0 = (* [merge_aliases] returns the sets of all aliases encountered at this point and a substitution mapping extra aliases to the first one *) -let merge_aliases (ids,subst as _aliases) id = - ids@[id], if ids=[] then subst else (id, List.hd ids)::subst +let merge_aliases (ids,asubst as _aliases) id = + ids@[id], if ids=[] then asubst else (id, List.hd ids)::asubst let alias_of = function | ([],_) -> Anonymous @@ -618,10 +531,6 @@ let chop_aconstr_constructor loc (ind,k) args = | _ -> error_invalid_pattern_notation loc) params; args -let decode_patlist_value = function - | CPatCstr (_,_,l) -> l - | _ -> anomaly "Ill-formed list argument of notation" - let rec subst_pat_iterator y t (subst,p) = match p with | PatVar (_,id) as x -> if id = Name y then t else [subst,x] @@ -630,8 +539,8 @@ let rec subst_pat_iterator y t (subst,p) = match p with let pl = simple_product_of_cases_patterns l' in List.map (fun (subst',pl) -> subst'@subst,PatCstr (loc,id,pl,alias)) pl -let subst_cases_pattern loc alias intern subst scopes a = - let rec aux alias subst = function +let subst_cases_pattern loc alias intern fullsubst scopes a = + let rec aux alias (subst,substlist as fullsubst) = function | AVar id -> begin (* subst remembers the delimiters stack in the interpretation *) @@ -653,30 +562,29 @@ let subst_cases_pattern loc alias intern subst scopes a = ([],[[], PatCstr (loc,c, [], alias)]) | AApp (ARef (ConstructRef cstr),args) -> let args = chop_aconstr_constructor loc cstr args in - let idslpll = List.map (aux Anonymous subst) args in + let idslpll = List.map (aux Anonymous fullsubst) args in let ids',pll = product_of_cases_patterns [] idslpll in - let pl' = List.map (fun (subst,pl) -> - subst,PatCstr (loc,cstr,pl,alias)) pll in + let pl' = List.map (fun (asubst,pl) -> + asubst,PatCstr (loc,cstr,pl,alias)) pll in ids', pl' | AList (x,_,iter,terminator,lassoc) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) - let (a,(scopt,subscopes)) = List.assoc x subst in - let termin = aux Anonymous subst terminator in - let l = decode_patlist_value a in + let (l,(scopt,subscopes)) = List.assoc x substlist in + let termin = aux Anonymous fullsubst terminator in let idsl,v = List.fold_right (fun a (tids,t) -> - let uids,u = aux Anonymous ((x,(a,(scopt,subscopes)))::subst) iter in + let uids,u = aux Anonymous ((x,(a,(scopt,subscopes)))::subst,substlist) iter in let pll = List.map (subst_pat_iterator ldots_var t) u in tids@uids, List.flatten pll) (if lassoc then List.rev l else l) termin in - idsl, List.map (fun ((subst, pl) as x) -> - match pl with PatCstr (loc, c, pl, Anonymous) -> (subst, PatCstr (loc, c, pl, alias)) | _ -> x) v + idsl, List.map (fun ((asubst, pl) as x) -> + match pl with PatCstr (loc, c, pl, Anonymous) -> (asubst, PatCstr (loc, c, pl, alias)) | _ -> x) v with Not_found -> anomaly "Inconsistent substitution of recursive notation") | t -> error_invalid_pattern_notation loc - in aux alias subst a - + in aux alias fullsubst a + (* Differentiating between constructors and matching variables *) type pattern_qualid_kind = | ConstrPat of constructor * (identifier list * @@ -701,7 +609,7 @@ let find_constructor ref f aliases pats scopes = if List.length pats < nvars then error_not_enough_arguments loc; let pats1,pats2 = list_chop nvars pats in let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) vars pats1 in - let idspl1 = List.map (subst_cases_pattern loc (alias_of aliases) f subst scopes) args in + let idspl1 = List.map (subst_cases_pattern loc (alias_of aliases) f (subst,[]) scopes) args in cstr, idspl1, pats2 | _ -> raise Not_found) @@ -711,7 +619,7 @@ let find_constructor ref f aliases pats scopes = let v = Environ.constant_value (Global.env()) cst in unf (global_of_constr v) | ConstructRef cstr -> - add_glob loc r; + Dumpglob.add_glob loc r; cstr, [], pats | _ -> raise Not_found in unf r @@ -739,7 +647,7 @@ let mustbe_constructor loc ref f aliases patl scopes = with (Environ.NotEvaluableConst _ | Not_found) -> raise (InternalisationError (loc,NotAConstructor ref)) -let rec intern_cases_pattern genv scopes (ids,subst as aliases) tmp_scope pat = +let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat= let intern_pat = intern_cases_pattern genv in match pat with | CPatAlias (loc, p, id) -> @@ -751,28 +659,30 @@ let rec intern_cases_pattern genv scopes (ids,subst as aliases) tmp_scope pat = let argscs2 = find_remaining_constructor_scopes idslpl1 pl2 c in let idslpl2 = List.map2 (intern_pat scopes ([],[])) argscs2 pl2 in let (ids',pll) = product_of_cases_patterns ids (idslpl1@idslpl2) in - let pl' = List.map (fun (subst,pl) -> - (subst, PatCstr (loc,c,pl,alias_of aliases))) pll in + let pl' = List.map (fun (asubst,pl) -> + (asubst, PatCstr (loc,c,pl,alias_of aliases))) pll in ids',pl' - | CPatNotation (loc,"- _",[CPatPrim(_,Numeral p)]) + | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[])) when Bigint.is_strictly_pos p -> intern_pat scopes aliases tmp_scope (CPatPrim(loc,Numeral(Bigint.neg p))) - | CPatNotation (_,"( _ )",[a]) -> + | CPatNotation (_,"( _ )",([a],[])) -> intern_pat scopes aliases tmp_scope a - | CPatNotation (loc, ntn, args) -> - let ntn,args = contract_pat_notation ntn args in - let ((ids',c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in - if !dump then dump_notation_location (patntn_loc loc args ntn) df; + | CPatNotation (loc, ntn, fullargs) -> + let ntn,(args,argsl) = contract_pat_notation ntn fullargs in + let (((ids',idsl'),c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in + Dumpglob.dump_notation_location (Topconstr.patntn_loc loc args ntn) df; let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids' args in - let ids'',pl = subst_cases_pattern loc (alias_of aliases) intern_pat subst scopes - c + let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl' argsl in + let ids'',pl = + subst_cases_pattern loc (alias_of aliases) intern_pat (subst,substlist) + scopes c in ids@ids'', pl | CPatPrim (loc, p) -> let a = alias_of aliases in let (c,df) = Notation.interp_prim_token_cases_pattern loc p a (tmp_scope,scopes) in - if !dump then dump_notation_location (fst (unloc loc)) df; - (ids,[subst,c]) + Dumpglob.dump_notation_location (fst (unloc loc)) df; + (ids,[asubst,c]) | CPatDelimiters (loc, key, e) -> intern_pat (find_delimiters_scope loc key::scopes) aliases None e | CPatAtom (loc, Some head) -> @@ -780,13 +690,13 @@ let rec intern_cases_pattern genv scopes (ids,subst as aliases) tmp_scope pat = | ConstrPat (c,idspl) -> check_constructor_length genv loc c idspl []; let (ids',pll) = product_of_cases_patterns ids idspl in - (ids,List.map (fun (subst,pl) -> - (subst, PatCstr (loc,c,pl,alias_of aliases))) pll) + (ids,List.map (fun (asubst,pl) -> + (asubst, PatCstr (loc,c,pl,alias_of aliases))) pll) | VarPat id -> - let ids,subst = merge_aliases aliases id in - (ids,[subst, PatVar (loc,alias_of (ids,subst))])) + let ids,asubst = merge_aliases aliases id in + (ids,[asubst, PatVar (loc,alias_of (ids,asubst))])) | CPatAtom (loc, None) -> - (ids,[subst, PatVar (loc,alias_of aliases)]) + (ids,[asubst, PatVar (loc,alias_of aliases)]) | CPatOr (loc, pl) -> assert (pl <> []); let pl' = List.map (intern_pat scopes aliases tmp_scope) pl in @@ -821,48 +731,90 @@ let check_hidden_implicit_parameters id (_,_,_,(indnames,_)) = pr_id id ++ strbrk " must not be used as a bound variable in the type \ of its constructor.") -let push_name_env lvar (ids,tmpsc,scopes as env) = function - | Anonymous -> env +let push_name_env ?(fail_anonymous=false) lvar (ids,unb,tmpsc,scopes as env) = function + | Anonymous -> + if fail_anonymous then errorlabstrm "" (str "Anonymous variables not allowed"); + env | Name id -> check_hidden_implicit_parameters id lvar; - (Idset.add id ids,tmpsc,scopes) + (Idset.add id ids, unb,tmpsc,scopes) -let push_loc_name_env lvar (ids,tmpsc,scopes as env) loc = function - | Anonymous -> env +let push_loc_name_env ?(fail_anonymous=false) lvar (ids,unb,tmpsc,scopes as env) loc = function + | Anonymous -> + if fail_anonymous then user_err_loc (loc,"", str "Anonymous variables not allowed"); + env | Name id -> check_hidden_implicit_parameters id lvar; - dump_binding loc id; - (Idset.add id ids,tmpsc,scopes) - -let intern_typeclass_binders intern_type lvar env bl = - List.fold_left - (fun ((ids,ts,sc) as env,bl) ((loc, na), bk, ty) -> - let env = push_loc_name_env lvar env loc na in - let ty = locate_if_isevar loc na (intern_type env ty) in - (env, (na,bk,None,ty)::bl)) - env bl - -let intern_typeclass_binder intern_type lvar (env,bl) cb = - let (ids, fvs, bind) = Implicit_quantifiers.generalize_class_binder_raw (pi1 env) cb in - intern_typeclass_binders intern_type lvar (env,bl) (fvs@[bind]) - -let intern_local_binder_aux intern intern_type lvar ((ids,ts,sc as env),bl) = function + Dumpglob.dump_binding loc id; + (Idset.add id ids,unb,tmpsc,scopes) + +let intern_generalized_binder ?(fail_anonymous=false) intern_type lvar + (ids,unb,tmpsc,sc as env) bl (loc, na) b b' t ty = + let ty = + if t then ty else + Implicit_quantifiers.implicit_application ids + Implicit_quantifiers.combine_params_freevar ty + in + let ty' = intern_type (ids,true,tmpsc,sc) ty in + let fvs = Implicit_quantifiers.free_vars_of_rawconstr ~bound:ids ty' in + let env' = List.fold_left (fun env (x, l) -> push_loc_name_env ~fail_anonymous lvar env l (Name x)) env fvs in + let bl = List.map (fun (id, loc) -> (Name id, b, None, RHole (loc, Evd.BinderType (Name id)))) fvs in + let na = match na with + | Anonymous -> + if fail_anonymous then na + else + let name = + let id = + match ty with + | CApp (_, (_, CRef (Ident (loc,id))), _) -> id + | _ -> id_of_string "H" + in Implicit_quantifiers.make_fresh ids (Global.env ()) id + in Name name + | _ -> na + in (push_loc_name_env ~fail_anonymous lvar env' loc na), (na,b',None,ty') :: List.rev bl + +let intern_local_binder_aux ?(fail_anonymous=false) intern intern_type lvar ((ids,unb,ts,sc as env),bl) = function | 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 - List.fold_left - (fun ((ids,ts,sc),bl) (_,na) -> - ((name_fold Idset.add na ids,ts,sc), (na,k,None,ty)::bl)) - (env,bl) nal - | TypeClass (b,b') -> - intern_typeclass_binder intern_type lvar (env,bl) (List.hd nal, (b,b'), ty)) + | 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 + List.fold_left + (fun ((ids,unb,ts,sc),bl) (_,na) -> + ((name_fold Idset.add na ids,unb,ts,sc), (na,k,None,ty)::bl)) + (env,bl) nal + | Generalized (b,b',t) -> + let env, b = intern_generalized_binder ~fail_anonymous intern_type lvar env bl (List.hd nal) b b' t ty in + env, b @ bl) | LocalRawDef((loc,na),def) -> - ((name_fold Idset.add na ids,ts,sc), + ((name_fold Idset.add na ids,unb,ts,sc), (na,Explicit,Some(intern env def),RHole(loc,Evd.BinderType na))::bl) +let intern_generalization intern (ids,unb,tmp_scope,scopes as env) lvar loc bk ak c = + let c = intern (ids,true,tmp_scope,scopes) c in + let fvs = Implicit_quantifiers.free_vars_of_rawconstr ~bound:ids c in + let env', c' = + let abs = + let pi = + match ak with + | Some AbsPi -> true + | None when tmp_scope = Some Notation.type_scope + || List.mem Notation.type_scope scopes -> true + | _ -> false + in + if pi then + (fun (id, loc') acc -> + RProd (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc)) + else + (fun (id, loc') acc -> + RLambda (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc)) + in + List.fold_right (fun (id, loc as lid) (env, acc) -> + let env' = push_loc_name_env lvar env loc (Name id) in + (env', abs lid acc)) fvs (env,c) + in c' + (**********************************************************************) (* Utilities for application *) @@ -936,7 +888,7 @@ let extract_explicit_arg imps args = (* Main loop *) let internalise sigma globalenv env allow_patvar lvar c = - let rec intern (ids,tmp_scope,scopes as env) = function + let rec intern (ids,unb,tmp_scope,scopes as env) = function | CRef ref as x -> let (c,imp,subscopes,l),_ = intern_applied_reference intern env lvar [] ref in @@ -960,17 +912,17 @@ let internalise sigma globalenv env allow_patvar lvar c = | None -> 0 in let before, after = list_chop idx bl in - let ((ids',_,_) as env',rbefore) = + let ((ids',_,_,_) as env',rbefore) = List.fold_left intern_local_binder (env,[]) before in let ro = match c with | None -> RStructRec - | Some c' -> f (intern (ids', tmp_scope, scopes) c') + | Some c' -> f (intern (ids', unb, tmp_scope, scopes) c') in let n' = Option.map (fun _ -> List.length before) n in n', ro, List.fold_left intern_local_binder (env',rbefore) after in - let n, ro, ((ids',_,_),rbl) = + let n, ro, ((ids',_,_,_),rbl) = (match order with | CStructRec -> intern_ro_arg None (fun _ -> RStructRec) @@ -981,8 +933,8 @@ let internalise sigma globalenv env allow_patvar lvar c = in let ids'' = List.fold_right Idset.add lf ids' in ((n, ro), List.rev rbl, - intern_type (ids',tmp_scope,scopes) ty, - intern (ids'',None,scopes) bd)) dl in + intern_type (ids',unb,tmp_scope,scopes) ty, + intern (ids'',unb,None,scopes) bd)) dl in RRec (loc,RFix (Array.map (fun (ro,_,_,_) -> ro) idl,n), Array.of_list lf, @@ -999,12 +951,12 @@ let internalise sigma globalenv env allow_patvar lvar c = in let idl = Array.map (fun (id,bl,ty,bd) -> - let ((ids',_,_),rbl) = + let ((ids',_,_,_),rbl) = List.fold_left intern_local_binder (env,[]) bl in let ids'' = List.fold_right Idset.add lf ids' in (List.rev rbl, - intern_type (ids',tmp_scope,scopes) ty, - intern (ids'',None,scopes) bd)) dl in + intern_type (ids',unb,tmp_scope,scopes) ty, + intern (ids'',unb,None,scopes) bd)) dl in RRec (loc,RCoFix n, Array.of_list lf, Array.map (fun (bl,_,_) -> bl) idl, @@ -1023,18 +975,20 @@ let internalise sigma globalenv env allow_patvar lvar c = | CLetIn (loc,(loc1,na),c1,c2) -> RLetIn (loc, na, intern (reset_tmp_scope env) c1, intern (push_loc_name_env lvar env loc1 na) c2) - | CNotation (loc,"- _",[CPrim (_,Numeral p)]) + | CNotation (loc,"- _",([CPrim (_,Numeral p)],[])) when Bigint.is_strictly_pos p -> intern env (CPrim (loc,Numeral (Bigint.neg p))) - | CNotation (_,"( _ )",[a]) -> intern env a + | CNotation (_,"( _ )",([a],[])) -> intern env a | CNotation (loc,ntn,args) -> intern_notation intern env loc ntn args + | CGeneralization (loc,b,a,c) -> + intern_generalization intern env lvar loc b a c | CPrim (loc, p) -> let c,df = Notation.interp_prim_token loc p (tmp_scope,scopes) in - if !dump then dump_notation_location (fst (unloc loc)) df; + Dumpglob.dump_notation_location (fst (unloc loc)) df; c | CDelimiters (loc, key, e) -> - intern (ids,None,find_delimiters_scope loc key::scopes) e + intern (ids,unb,None,find_delimiters_scope loc key::scopes) e | CAppExpl (loc, (isproj,ref), args) -> let (f,_,args_scopes,_),args = let args = List.map (fun a -> (a,None)) args in @@ -1050,8 +1004,8 @@ let internalise sigma globalenv env allow_patvar lvar c = let (c,impargs,args_scopes,l),args = match f with | CRef ref -> intern_applied_reference intern env lvar args ref - | CNotation (loc,ntn,[]) -> - let c = intern_notation intern env loc ntn [] in + | CNotation (loc,ntn,([],[])) -> + let c = intern_notation intern env loc ntn ([],[]) in find_appl_head_data lvar c, args | x -> (intern env f,[],[],[]), args in let args = @@ -1061,6 +1015,39 @@ let internalise sigma globalenv env allow_patvar lvar c = (* Now compact "(f args') args" *) | RApp (loc', f', args') -> RApp (join_loc loc' loc, f',args'@args) | _ -> RApp (loc, c, args)) + | CRecord (loc, w, fs) -> + let id, _ = List.hd fs in + let record = + let (id,_,_,_),_ = intern_applied_reference intern env lvar [] (Ident id) in + match id with + | RRef (loc, ref) -> + (try Recordops.find_projection ref + with Not_found -> user_err_loc (loc, "intern", str"Not a projection")) + | c -> user_err_loc (loc_of_rawconstr id, "intern", str"Not a projection") + in + let args = + let pars = list_make record.Recordops.s_EXPECTEDPARAM (CHole (loc, None)) in + let fields, rest = + List.fold_left (fun (args, rest as acc) (na, b) -> + if b then + try + let id = out_name na in + let _, t = List.assoc id rest in + t :: args, List.remove_assoc id rest + with _ -> CHole (loc, Some (Evd.QuestionMark (Evd.Define true))) :: args, rest + else acc) ([], List.map (fun ((loc, id), t) -> id, (loc, t)) fs) record.Recordops.s_PROJKIND + in + if rest <> [] then + let id, (loc, t) = List.hd rest in + user_err_loc (loc,"intern",(str "Unknown field name " ++ pr_id id)) + else pars @ List.rev fields + in + let constrname = + Qualid (loc, shortest_qualid_of_global Idset.empty (ConstructRef record.Recordops.s_CONST)) + in + let app = CAppExpl (loc, (None, constrname), args) in + intern env app + | CCases (loc, sty, rtnpo, tms, eqns) -> let tms,env' = List.fold_right (fun citm (inds,env) -> @@ -1084,7 +1071,7 @@ let internalise sigma globalenv env allow_patvar lvar c = let p' = Option.map (intern_type env'') po in RIf (loc, c', (na', p'), intern env b1, intern env b2) | CHole (loc, k) -> - RHole (loc, match k with Some k -> k | None -> Evd.QuestionMark true) + RHole (loc, match k with Some k -> k | None -> Evd.QuestionMark (Evd.Define true)) | CPatVar (loc, n) when allow_patvar -> RPatVar (loc, n) | CPatVar (loc, _) -> @@ -1122,24 +1109,24 @@ let internalise sigma globalenv env allow_patvar lvar c = (ids,List.flatten mpl') (* Expands a pattern-matching clause [lhs => rhs] *) - and intern_eqn n (ids,tmp_scope,scopes) (loc,lhs,rhs) = + and intern_eqn n (ids,unb,tmp_scope,scopes) (loc,lhs,rhs) = let eqn_ids,pll = intern_disjunctive_multiple_pattern scopes loc n lhs in (* Linearity implies the order in ids is irrelevant *) check_linearity lhs eqn_ids; let env_ids = List.fold_right Idset.add eqn_ids ids in - List.map (fun (subst,pl) -> - let rhs = replace_vars_constr_expr subst rhs in - List.iter message_redundant_alias subst; - let rhs' = intern (env_ids,tmp_scope,scopes) rhs in + List.map (fun (asubst,pl) -> + let rhs = replace_vars_constr_expr asubst rhs in + List.iter message_redundant_alias asubst; + let rhs' = intern (env_ids,unb,tmp_scope,scopes) rhs in (loc,eqn_ids,pl,rhs')) pll - and intern_case_item (vars,_,scopes as env) (tm,(na,t)) = + and intern_case_item (vars,unb,_,scopes as env) (tm,(na,t)) = let tm' = intern env tm in let ids,typ = match t with | Some t -> let tids = ids_of_cases_indtype t in let tids = List.fold_right Idset.add tids Idset.empty in - let t = intern_type (tids,None,scopes) t in + let t = intern_type (tids,unb,None,scopes) t in let loc,ind,l = match t with | RRef (loc,IndRef ind) -> (loc,ind,[]) | RApp (loc,RRef (_,IndRef ind),l) -> (loc,ind,l) @@ -1175,9 +1162,9 @@ let internalise sigma globalenv env allow_patvar lvar c = in match bk with | Default b -> default env b nal - | TypeClass (b,b') -> - let env, ibind = intern_typeclass_binder intern_type lvar - (env, []) (List.hd nal,(b,b'),ty) in + | Generalized (b,b',t) -> + let env, ibind = intern_generalized_binder intern_type lvar + env [] (List.hd nal) b b' t ty in let body = intern_type env body in it_mkRProd ibind body @@ -1191,9 +1178,9 @@ let internalise sigma globalenv env allow_patvar lvar c = | [] -> intern env body in match bk with | Default b -> default env b nal - | TypeClass (b, b') -> - let env, ibind = intern_typeclass_binder intern_type lvar - (env, []) (List.hd nal,(b,b'),ty) in + | Generalized (b, b', t) -> + let env, ibind = intern_generalized_binder intern_type lvar + env [] (List.hd nal) b b' t ty in let body = intern env body in it_mkRLambda ibind body @@ -1258,7 +1245,7 @@ let intern_gen isarity sigma env c = let tmp_scope = if isarity then Some Notation.type_scope else None in - internalise sigma env (extract_ids env, tmp_scope,[]) + internalise sigma env (extract_ids env, false, tmp_scope,[]) allow_patvar (ltacvars,Environ.named_context env, [], impls) c let intern_constr sigma env c = intern_gen false sigma env c @@ -1340,22 +1327,23 @@ let interp_constr_judgment_evars evdref env c = type ltac_sign = identifier list * unbound_ltac_var_map -let interp_constrpattern sigma env c = - pattern_of_rawconstr (intern_gen false sigma env ~allow_patvar:true c) +let intern_constr_pattern sigma env ?(as_type=false) ?(ltacvars=([],[])) c = + let c = intern_gen as_type ~allow_patvar:true ~ltacvars sigma env c in + pattern_of_rawconstr c -let interp_aconstr impls vars a = +let interp_aconstr impls (vars,varslist) a = let env = Global.env () in (* [vl] is intended to remember the scope of the free variables of [a] *) - let vl = List.map (fun id -> (id,ref None)) vars in - let c = internalise Evd.empty (Global.env()) (extract_ids env, None, []) + let vl = List.map (fun id -> (id,ref None)) (vars@varslist) in + let c = internalise Evd.empty (Global.env()) (extract_ids env, false, None, []) false (([],[]),Environ.named_context env,vl,([],impls)) a in (* Translate and check that [c] has all its free variables bound in [vars] *) let a = aconstr_of_rawconstr vars c in (* Returns [a] and the ordered list of variables with their scopes *) (* Variables occurring in binders have no relevant scope since bound *) - List.map - (fun (id,r) -> (id,match !r with None -> None,[] | Some (a,l) -> a,l)) vl, - a + let vl = List.map (fun (id,r) -> + (id,match !r with None -> None,[] | Some (a,l) -> a,l)) vl in + list_chop (List.length vars) vl, a (* Interpret binders and contexts *) @@ -1377,11 +1365,11 @@ let my_intern_constr sigma env lvar acc c = let my_intern_type sigma env lvar acc c = my_intern_constr sigma env lvar (set_type_scope acc) c -let intern_context sigma env params = +let intern_context fail_anonymous sigma env params = let lvar = (([],[]),Environ.named_context env, [], ([], [])) in snd (List.fold_left - (intern_local_binder_aux (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar) - ((extract_ids env,None,[]), []) params) + (intern_local_binder_aux ~fail_anonymous (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar) + ((extract_ids env,false,None,[]), []) params) let interp_context_gen understand_type understand_judgment env bl = let (env, par, _, impls) = @@ -1402,17 +1390,17 @@ let interp_context_gen understand_type understand_judgment env bl = | Some b -> let c = understand_judgment env b in let d = (na, Some c.uj_val, c.uj_type) in - (push_rel d env,d::params, succ n, impls)) + (push_rel d env, d::params, succ n, impls)) (env,[],1,[]) (List.rev bl) in (env, par), impls -let interp_context sigma env params = - let bl = intern_context sigma env params in +let interp_context ?(fail_anonymous=false) sigma env params = + let bl = intern_context fail_anonymous sigma env params in interp_context_gen (Default.understand_type sigma) (Default.understand_judgment sigma) env bl -let interp_context_evars evdref env params = - let bl = intern_context (Evd.evars_of !evdref) env params in +let interp_context_evars ?(fail_anonymous=false) evdref env params = + let bl = intern_context fail_anonymous (Evd.evars_of !evdref) env params in interp_context_gen (fun env t -> Default.understand_tcc_evars evdref env IsType t) (Default.understand_judgment_tcc evdref) env bl diff --git a/interp/constrintern.mli b/interp/constrintern.mli index ea7020be..c5371255 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: constrintern.mli 11024 2008-05-30 12:41:39Z msozeau $ i*) +(*i $Id: constrintern.mli 11739 2009-01-02 19:33:19Z herbelin $ i*) (*i*) open Names @@ -39,8 +39,10 @@ open Pretyping argument associates a list of implicit positions and scopes to identifiers declared in the [rel_context] of [env] *) +type var_internalisation_type = Inductive | Recursive | Method + type var_internalisation_data = - identifier list * Impargs.implicits_list * scope_name option list + var_internalisation_type * identifier list * Impargs.implicits_list * scope_name option list type implicits_env = (identifier * var_internalisation_data) list type full_implicits_env = identifier list * implicits_env @@ -65,7 +67,7 @@ val intern_pattern : env -> cases_pattern_expr -> Names.identifier list * ((Names.identifier * Names.identifier) list * Rawterm.cases_pattern) list -val intern_context : evar_map -> env -> local_binder list -> raw_binder list +val intern_context : bool -> evar_map -> env -> local_binder list -> raw_binder list (*s Composing internalisation with pretyping *) @@ -111,8 +113,9 @@ val interp_constr_judgment : evar_map -> env -> constr_expr -> unsafe_judgment (* Interprets constr patterns *) -val interp_constrpattern : - evar_map -> env -> constr_expr -> patvar list * constr_pattern +val intern_constr_pattern : + evar_map -> env -> ?as_type:bool -> ?ltacvars:ltac_sign -> + constr_pattern_expr -> patvar list * constr_pattern val interp_reference : ltac_sign -> reference -> rawconstr @@ -124,9 +127,10 @@ val interp_binder_evars : evar_defs ref -> env -> name -> constr_expr -> types (* Interpret contexts: returns extended env and context *) -val interp_context : evar_map -> env -> local_binder list -> (env * rel_context) * manual_implicits +val interp_context : ?fail_anonymous:bool -> + evar_map -> env -> local_binder list -> (env * rel_context) * manual_implicits -val interp_context_evars : +val interp_context_evars : ?fail_anonymous:bool -> evar_defs ref -> env -> local_binder list -> (env * rel_context) * manual_implicits (* Locating references of constructions, possibly via a syntactic definition *) @@ -139,15 +143,8 @@ val global_reference_in_absolute_module : dir_path -> identifier -> constr (* Interprets into a abbreviatable constr *) -val interp_aconstr : implicits_env -> identifier list -> constr_expr -> - interpretation +val interp_aconstr : implicits_env -> identifier list * identifier list + -> constr_expr -> interpretation (* Globalization leak for Grammar *) val for_grammar : ('a -> 'b) -> 'a -> 'b - -(* Coqdoc utility functions *) -type coqdoc_state -val coqdoc_freeze : unit -> coqdoc_state -val coqdoc_unfreeze : coqdoc_state -> unit - -val add_glob : Util.loc -> global_reference -> unit diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml new file mode 100644 index 00000000..5ac584a7 --- /dev/null +++ b/interp/dumpglob.ml @@ -0,0 +1,228 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (match def with + | Definition -> "def" + | Coercion -> "coe" + | SubClass -> "subclass" + | CanonicalStructure -> "canonstruc" + | Example -> "ex" + | Fixpoint -> "def" + | CoFixpoint -> "def" + | Scheme -> "scheme" + | StructureComponent -> "proj" + | IdentityCoercion -> "coe" + | Instance -> "inst" + | Method -> "meth") + | IsAssumption a -> + (match a with + | Definitional -> "defax" + | Logical -> "prfax" + | Conjectural -> "prfax") + | IsProof th -> + (match th with + | Theorem + | Lemma + | Fact + | Remark + | Property + | Proposition + | Corollary -> "thm") + +let type_of_global_ref gr = + if Typeclasses.is_class gr then + "class" + else + match gr with + | Libnames.ConstRef cst -> + type_of_logical_kind (Decls.constant_kind cst) + | Libnames.VarRef v -> + "var" ^ type_of_logical_kind (Decls.variable_kind v) + | Libnames.IndRef ind -> + let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in + if mib.Declarations.mind_record then + if mib.Declarations.mind_finite then "rec" + else "corec" + else if mib.Declarations.mind_finite then "ind" + else "coind" + | Libnames.ConstructRef _ -> "constr" + +let remove_sections dir = + if Libnames.is_dirpath_prefix_of dir (Lib.cwd ()) then + (* Not yet (fully) discharged *) + Libnames.extract_dirpath_prefix (Lib.sections_depth ()) (Lib.cwd ()) + else + (* Theorem/Lemma outside its outer section of definition *) + dir + +let dump_ref loc filepath modpath ident ty = + dump_string (Printf.sprintf "R%d %s %s %s %s\n" + (fst (Util.unloc loc)) filepath modpath ident ty) + +let add_glob_gen loc sp lib_dp ty = + if dump () then + let mod_dp,id = Libnames.repr_path sp in + let mod_dp = remove_sections mod_dp in + let mod_dp_trunc = Libnames.drop_dirpath_prefix lib_dp mod_dp in + let filepath = Names.string_of_dirpath lib_dp in + let modpath = Names.string_of_dirpath mod_dp_trunc in + let ident = Names.string_of_id id in + dump_ref loc filepath modpath ident ty + +let add_glob loc ref = + if dump () && loc <> Util.dummy_loc then + let sp = Nametab.sp_of_global ref in + let lib_dp = Lib.library_part ref in + let ty = type_of_global_ref ref in + add_glob_gen loc sp lib_dp ty + +let mp_of_kn kn = + let mp,sec,l = Names.repr_kn kn in + Names.MPdot (mp,l) + +let add_glob_kn loc kn = + if dump () && loc <> Util.dummy_loc then + let sp = Nametab.sp_of_syntactic_definition kn in + let lib_dp = Lib.dp_of_mp (mp_of_kn kn) in + add_glob_gen loc sp lib_dp "syndef" + +let add_local loc id = () +(* let mod_dp,id = repr_path sp in *) +(* let mod_dp = remove_sections mod_dp in *) +(* let mod_dp_trunc = drop_dirpath_prefix lib_dp mod_dp in *) +(* let filepath = string_of_dirpath lib_dp in *) +(* let modpath = string_of_dirpath mod_dp_trunc in *) +(* let ident = string_of_id id in *) +(* dump_string (Printf.sprintf "R%d %s %s %s %s\n" *) +(* (fst (unloc loc)) filepath modpath ident ty) *) + +let dump_binding loc id = () + +let dump_definition (loc, id) sec s = + dump_string (Printf.sprintf "%s %d %s %s\n" s (fst (Util.unloc loc)) + (Names.string_of_dirpath (Lib.current_dirpath sec)) (Names.string_of_id id)) + +let dump_reference loc modpath ident ty = + dump_string (Printf.sprintf "R%d %s %s %s %s\n" + (fst (Util.unloc loc)) (Names.string_of_dirpath (Lib.library_dp ())) modpath ident ty) + +let dump_constraint ((loc, n), _, _) sec ty = + match n with + | Names.Name id -> dump_definition (loc, id) sec ty + | Names.Anonymous -> () + +let dump_name (loc, n) sec ty = + match n with + | Names.Name id -> dump_definition (loc, id) sec ty + | Names.Anonymous -> () + +let dump_local_binder b sec ty = + if dump () then + match b with + | Topconstr.LocalRawAssum (nl, _, _) -> + List.iter (fun x -> dump_name x sec ty) nl + | Topconstr.LocalRawDef _ -> () + +let dump_modref loc mp ty = + if dump () then + let (dp, l) = Lib.split_modpath mp in + let l = if l = [] then l else Util.list_drop_last l in + let fp = Names.string_of_dirpath dp in + let mp = Names.string_of_dirpath (Names.make_dirpath l) in + dump_string (Printf.sprintf "R%d %s %s %s %s\n" + (fst (Util.unloc loc)) fp mp "<>" ty) + +let dump_moddef loc mp ty = + if dump () then + let (dp, l) = Lib.split_modpath mp in + let mp = Names.string_of_dirpath (Names.make_dirpath l) in + dump_string (Printf.sprintf "%s %d %s %s\n" ty (fst (Util.unloc loc)) "<>" mp) + +let dump_libref loc dp ty = + dump_string (Printf.sprintf "R%d %s <> <> %s\n" + (fst (Util.unloc loc)) (Names.string_of_dirpath dp) ty) + +let dump_notation_location pos ((path,df),sc) = + if dump () then + let rec next growing = + let loc = Lexer.location_function !token_number in + let (bp,_) = Util.unloc loc in + if growing then if bp >= pos then loc else (incr token_number; next true) + else if bp = pos then loc + else if bp > pos then (decr token_number;next false) + else (incr token_number;next true) in + let loc = next (pos >= !last_pos) in + last_pos := pos; + let path = Names.string_of_dirpath path in + let _sc = match sc with Some sc -> " "^sc | _ -> "" in + dump_string (Printf.sprintf "R%d %s \"%s\" not\n" (fst (Util.unloc loc)) path df) + + diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli new file mode 100644 index 00000000..a0666c81 --- /dev/null +++ b/interp/dumpglob.mli @@ -0,0 +1,43 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit +val close_glob_file : unit -> unit + +val dump : unit -> bool +val multi_dump : unit -> bool + +val noglob : unit -> unit +val dump_to_stdout : unit -> unit +val dump_into_file : string -> unit +val dump_to_dotglob : unit -> unit + +val pause : unit -> unit +val continue : unit -> unit + +val coqdoc_freeze : unit -> Lexer.location_table * int * int +val coqdoc_unfreeze : Lexer.location_table * int * int -> unit + +val add_glob : Util.loc -> Libnames.global_reference -> unit +val add_glob_kn : Util.loc -> Names.kernel_name -> unit + +val dump_definition : Util.loc * Names.identifier -> bool -> string -> unit +val dump_moddef : Util.loc -> Names.module_path -> string -> unit +val dump_modref : Util.loc -> Names.module_path -> string -> unit +val dump_reference : Util.loc -> string -> string -> string -> unit +val dump_libref : Util.loc -> Names.dir_path -> string -> unit +val dump_notation_location : int -> (Notation.notation_location * Topconstr.scope_name option) -> unit +val dump_binding : Util.loc -> Names.Idset.elt -> unit +val dump_constraint : Topconstr.typeclass_constraint -> bool -> string -> unit +val dump_local_binder : Topconstr.local_binder -> bool -> string -> unit + +val dump_string : string -> unit + diff --git a/interp/genarg.ml b/interp/genarg.ml index c54dfe23..1da428be 100644 --- a/interp/genarg.ml +++ b/interp/genarg.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: genarg.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: genarg.ml 11481 2008-10-20 19:23:51Z herbelin $ *) open Pp open Util @@ -26,7 +26,7 @@ type argument_type = | StringArgType | PreIdentArgType | IntroPatternArgType - | IdentArgType + | IdentArgType of bool | VarArgType | RefArgType (* Specific types *) @@ -45,7 +45,9 @@ type argument_type = | ExtraArgType of string type 'a and_short_name = 'a * identifier located option -type 'a or_by_notation = AN of 'a | ByNotation of loc * string +type 'a or_by_notation = + | AN of 'a + | ByNotation of loc * string * Notation.delimiters option type rawconstr_and_expr = rawconstr * constr_expr option type open_constr_expr = unit * constr_expr @@ -124,9 +126,17 @@ let rawwit_intro_pattern = IntroPatternArgType let globwit_intro_pattern = IntroPatternArgType let wit_intro_pattern = IntroPatternArgType -let rawwit_ident = IdentArgType -let globwit_ident = IdentArgType -let wit_ident = IdentArgType +let rawwit_ident_gen b = IdentArgType b +let globwit_ident_gen b = IdentArgType b +let wit_ident_gen b = IdentArgType b + +let rawwit_ident = rawwit_ident_gen true +let globwit_ident = globwit_ident_gen true +let wit_ident = wit_ident_gen true + +let rawwit_pattern_ident = rawwit_ident_gen false +let globwit_pattern_ident = globwit_ident_gen false +let wit_pattern_ident = wit_ident_gen false let rawwit_var = VarArgType let globwit_var = VarArgType diff --git a/interp/genarg.mli b/interp/genarg.mli index da175078..86b19de7 100644 --- a/interp/genarg.mli +++ b/interp/genarg.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: genarg.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: genarg.mli 11481 2008-10-20 19:23:51Z herbelin $ i*) open Util open Names @@ -19,7 +19,9 @@ open Evd type 'a and_short_name = 'a * identifier located option -type 'a or_by_notation = AN of 'a | ByNotation of loc * string +type 'a or_by_notation = + | AN of 'a + | ByNotation of loc * string * Notation.delimiters option (* In globalize tactics, we need to keep the initial [constr_expr] to recompute*) (* in the environment by the effective calls to Intro, Inversion, etc *) @@ -84,7 +86,8 @@ IntArgType int int IntOrVarArgType int or_var int StringArgType string (parsed w/ "") string PreIdentArgType string (parsed w/o "") (vernac only) -IdentArgType identifier identifier +IdentArgType true identifier identifier +IdentArgType false identifier (pattern_ident) identifier IntroPatternArgType intro_pattern_expr intro_pattern_expr VarArgType identifier located identifier RefArgType reference global_reference @@ -143,6 +146,14 @@ val rawwit_ident : (identifier,rlevel) abstract_argument_type val globwit_ident : (identifier,glevel) abstract_argument_type val wit_ident : (identifier,tlevel) abstract_argument_type +val rawwit_pattern_ident : (identifier,rlevel) abstract_argument_type +val globwit_pattern_ident : (identifier,glevel) abstract_argument_type +val wit_pattern_ident : (identifier,tlevel) abstract_argument_type + +val rawwit_ident_gen : bool -> (identifier,rlevel) abstract_argument_type +val globwit_ident_gen : bool -> (identifier,glevel) abstract_argument_type +val wit_ident_gen : bool -> (identifier,tlevel) abstract_argument_type + val rawwit_var : (identifier located,rlevel) abstract_argument_type val globwit_var : (identifier located,glevel) abstract_argument_type val wit_var : (identifier,tlevel) abstract_argument_type @@ -255,7 +266,7 @@ type argument_type = | StringArgType | PreIdentArgType | IntroPatternArgType - | IdentArgType + | IdentArgType of bool | VarArgType | RefArgType (* Specific types *) diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index a83071d1..d6e207f3 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: implicit_quantifiers.ml 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: implicit_quantifiers.ml 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Names @@ -58,7 +58,7 @@ let free_vars_of_constr_expr c ?(bound=Idset.empty) l = in let rec aux bdvars l c = match c with | CRef (Ident (_,id)) -> found id bdvars l - | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id))) :: _) when not (Idset.mem id bdvars) -> + | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [])) when not (Idset.mem id bdvars) -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c in aux bound l c @@ -81,17 +81,84 @@ let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) = | [] -> bdvars, l in aux bound l binders +let add_name_to_ids set na = + match na with + | Anonymous -> set + | Name id -> Idset.add id set + +let free_vars_of_rawconstr ?(bound=Idset.empty) = + let rec vars bound vs = function + | RVar (loc,id) -> + if is_freevar bound (Global.env ()) id then + if List.mem_assoc id vs then vs + else (id, loc) :: vs + else vs + | RApp (loc,f,args) -> List.fold_left (vars bound) vs (f::args) + | RLambda (loc,na,_,ty,c) | RProd (loc,na,_,ty,c) | RLetIn (loc,na,ty,c) -> + let vs' = vars bound vs ty in + let bound' = add_name_to_ids bound na in + vars bound' vs' c + | RCases (loc,sty,rtntypopt,tml,pl) -> + let vs1 = vars_option bound vs rtntypopt in + let vs2 = List.fold_left (fun vs (tm,_) -> vars bound vs tm) vs1 tml in + List.fold_left (vars_pattern bound) vs2 pl + | RLetTuple (loc,nal,rtntyp,b,c) -> + let vs1 = vars_return_type bound vs rtntyp in + let vs2 = vars bound vs1 b in + let bound' = List.fold_left add_name_to_ids bound nal in + vars bound' vs2 c + | RIf (loc,c,rtntyp,b1,b2) -> + let vs1 = vars_return_type bound vs rtntyp in + let vs2 = vars bound vs1 c in + let vs3 = vars bound vs2 b1 in + vars bound vs3 b2 + | RRec (loc,fk,idl,bl,tyl,bv) -> + let bound' = Array.fold_right Idset.add idl bound in + let vars_fix i vs fid = + let vs1,bound1 = + List.fold_left + (fun (vs,bound) (na,k,bbd,bty) -> + let vs' = vars_option bound vs bbd in + let vs'' = vars bound vs' bty in + let bound' = add_name_to_ids bound na in + (vs'',bound') + ) + (vs,bound') + bl.(i) + in + let vs2 = vars bound1 vs1 tyl.(i) in + vars bound1 vs2 bv.(i) + in + array_fold_left_i vars_fix vs idl + | RCast (loc,c,k) -> let v = vars bound vs c in + (match k with CastConv (_,t) -> vars bound v t | _ -> v) + | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> vs + + and vars_pattern bound vs (loc,idl,p,c) = + let bound' = List.fold_right Idset.add idl bound in + vars bound' vs c + + and vars_option bound vs = function None -> vs | Some p -> vars bound vs p + + and vars_return_type bound vs (na,tyopt) = + let bound' = add_name_to_ids bound na in + vars_option bound' vs tyopt + in + fun rt -> List.rev (vars bound [] rt) + let rec make_fresh ids env x = if is_freevar ids env x then x else make_fresh ids env (Nameops.lift_ident x) let freevars_of_ids env ids = List.filter (is_freevar env (Global.env())) ids - -let binder_list_of_ids ids = - List.map (fun id -> LocalRawAssum ([dummy_loc, Name id], Default Implicit, CHole (dummy_loc, None))) ids let next_ident_away_from id avoid = make_fresh avoid (Global.env ()) id - + +let next_name_away_from na avoid = + match na with + | Anonymous -> make_fresh avoid (Global.env ()) (id_of_string "anon") + | Name id -> make_fresh avoid (Global.env ()) id + let combine_params avoid fn applied needed = let named, applied = List.partition @@ -116,7 +183,7 @@ let combine_params avoid fn applied needed = | (x, None) :: app, (None, (Name id, _, _)) :: need -> aux (x :: ids) avoid app need - | _, (Some cl, (Name id, _, _) as d) :: need -> + | _, (Some cl, (_, _, _) as d) :: need -> let t', avoid' = fn avoid d in aux (t' :: ids) avoid' app need @@ -126,26 +193,19 @@ let combine_params avoid fn applied needed = let t', avoid' = fn avoid decl in aux (t' :: ids) avoid' app need - | _ :: _, [] -> failwith "combine_params: overly applied typeclass" - - | _, _ -> raise (Invalid_argument "combine_params") + | (x,_) :: _, [] -> + user_err_loc (constr_loc x,"",str "Typeclass does not expect more arguments") in aux [] avoid applied needed -let combine_params_freevar avoid applied needed = - combine_params avoid - (fun avoid (_, (id, _, _)) -> - let id' = next_ident_away_from (Nameops.out_name id) avoid in - (CRef (Ident (dummy_loc, id')), Idset.add id' avoid)) - applied needed - -let compute_context_vars env l = - List.fold_left (fun avoid (iid, _, c) -> - (match snd iid with Name i -> [i] | Anonymous -> []) @ (free_vars_of_constr_expr c ~bound:env avoid)) - [] l - +let combine_params_freevar = + fun avoid (_, (na, _, _)) -> + let id' = next_name_away_from na avoid in + (CRef (Ident (dummy_loc, id')), Idset.add id' avoid) + let destClassApp cl = match cl with | CApp (loc, (None,CRef ref), l) -> loc, ref, List.map fst l + | CAppExpl (loc, (None, ref), l) -> loc, ref, l | CRef ref -> loc_of_reference ref, ref, [] | _ -> raise Not_found @@ -155,88 +215,34 @@ let destClassAppExpl cl = | CRef ref -> loc_of_reference ref, ref, [] | _ -> raise Not_found -let full_class_binders env l = - let avoid = Idset.union env (ids_of_list (compute_context_vars env l)) in - let l', avoid = - List.fold_left (fun (l', avoid) (iid, bk, cl as x) -> - match bk with - Implicit -> - let (loc, id, l) = - try destClassAppExpl cl - with Not_found -> - user_err_loc (constr_loc cl, "class_binders", str"Not an applied type class") - in - let gr = Nametab.global id in - (try - let c = class_info gr in - let args, avoid = combine_params_freevar avoid l (List.rev c.cl_context) in - (iid, bk, CAppExpl (loc, (None, id), args)) :: l', avoid - with Not_found -> not_a_class (Global.env ()) (constr_of_global gr)) - | Explicit -> (x :: l', avoid)) - ([], avoid) l - in List.rev l' - -let compute_context_freevars env ctx = - let bound, ids = - List.fold_left - (fun (bound, acc) (oid, id, x) -> - let bound = match snd oid with Name n -> Idset.add n bound | Anonymous -> bound in - bound, free_vars_of_constr_expr x ~bound acc) - (env,[]) ctx - in freevars_of_ids env (List.rev ids) - -let resolve_class_binders env l = - let ctx = full_class_binders env l in - let fv_ctx = - let elts = compute_context_freevars env ctx in - List.map (fun id -> (dummy_loc, id), CHole (dummy_loc, None)) elts - in - fv_ctx, ctx - -let full_class_binder env (iid, (bk, bk'), cl as c) = - let avoid = Idset.union env (ids_of_list (compute_context_vars env [c])) in - let c, avoid = - match bk' with - | Implicit -> - let (loc, id, l) = - try destClassAppExpl cl - with Not_found -> - user_err_loc (constr_loc cl, "class_binders", str"Not an applied type class") - in - let gr = Nametab.global id in - (try - let c = class_info gr in - let args, avoid = combine_params_freevar avoid l (List.rev c.cl_context) in - (iid, bk, CAppExpl (loc, (None, id), args)), avoid - with Not_found -> not_a_class (Global.env ()) (constr_of_global gr)) - | Explicit -> ((iid,bk,cl), avoid) - in c - -let compute_constraint_freevars env (oid, _, x) = - let bound = match snd oid with Name n -> Idset.add n env | Anonymous -> env in - let ids = free_vars_of_constr_expr x ~bound [] in - freevars_of_ids env (List.rev ids) - -let resolve_class_binder env c = - let cstr = full_class_binder env c in - let fv_ctx = - let elts = compute_constraint_freevars env cstr in - List.map (fun id -> (dummy_loc, id), CHole (dummy_loc, None)) elts - in fv_ctx, cstr - -let generalize_class_binder_raw env c = - let env = Idset.union env (Termops.vars_of_env (Global.env())) in - let fv_ctx, cstr = resolve_class_binder env c in - let ids' = List.fold_left (fun acc ((loc, id), t) -> Idset.add id acc) env fv_ctx in - let ctx' = List.map (fun ((loc, id), t) -> ((loc, Name id), Implicit, t)) fv_ctx in - ids', ctx', cstr - -let generalize_class_binders_raw env l = - let env = Idset.union env (Termops.vars_of_env (Global.env())) in - let fv_ctx, cstrs = resolve_class_binders env l in - List.map (fun ((loc, id), t) -> ((loc, Name id), Implicit, t)) fv_ctx, - List.map (fun (iid, bk, c) -> (iid, Implicit, c)) cstrs - +let implicit_application env ?(allow_partial=true) f ty = + let is_class = + try + let (loc, r, _ as clapp) = destClassAppExpl ty in + let (loc, qid) = qualid_of_reference r in + let gr = Nametab.locate qid in + if Typeclasses.is_class gr then Some (clapp, gr) else None + with Not_found -> None + in + match is_class with + | None -> ty + | Some ((loc, id, par), gr) -> + let avoid = Idset.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in + let c, avoid = + let c = class_info gr in + let (ci, rd) = c.cl_context in + if not allow_partial then + begin + let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in + let needlen = List.fold_left (fun acc x -> if x = None then succ acc else acc) 0 ci in + if needlen <> applen then + Typeclasses_errors.mismatched_ctx_inst (Global.env ()) Parameters (List.map fst par) rd + end; + let pars = List.rev (List.combine ci rd) in + let args, avoid = combine_params avoid f par pars in + CAppExpl (loc, (None, id), args), avoid + in c + let implicits_of_rawterm l = let rec aux i c = match c with diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli index 1ee81ce9..8dd12f72 100644 --- a/interp/implicit_quantifiers.mli +++ b/interp/implicit_quantifiers.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: implicit_quantifiers.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: implicit_quantifiers.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Names @@ -28,34 +28,27 @@ val ids_of_list : identifier list -> Idset.t val destClassApp : constr_expr -> loc * reference * constr_expr list val destClassAppExpl : constr_expr -> loc * reference * (constr_expr * explicitation located option) list -val free_vars_of_constr_expr : Topconstr.constr_expr -> - ?bound:Idset.t -> - Names.identifier list -> Names.identifier list +(* Fragile, should be used only for construction a set of identifiers to avoid *) -val binder_list_of_ids : identifier list -> local_binder list - -val make_fresh : Names.Idset.t -> Environ.env -> identifier -> identifier +val free_vars_of_constr_expr : constr_expr -> ?bound:Idset.t -> + identifier list -> identifier list val free_vars_of_binders : ?bound:Idset.t -> Names.identifier list -> local_binder list -> Idset.t * Names.identifier list -val resolve_class_binders : Idset.t -> typeclass_context -> - (identifier located * constr_expr) list * typeclass_context +(* Returns the free ids in left-to-right order with the location of their first occurence *) -val full_class_binders : Idset.t -> typeclass_context -> typeclass_context +val free_vars_of_rawconstr : ?bound:Idset.t -> rawconstr -> (Names.identifier * loc) list -val generalize_class_binder_raw : Idset.t -> name located * (binding_kind * binding_kind) * constr_expr -> - Idset.t * typeclass_context * typeclass_constraint - -val generalize_class_binders_raw : Idset.t -> typeclass_context -> - (name located * binding_kind * constr_expr) list * (name located * binding_kind * constr_expr) list +val make_fresh : Names.Idset.t -> Environ.env -> identifier -> identifier val implicits_of_rawterm : Rawterm.rawconstr -> (Topconstr.explicitation * (bool * bool)) list -val combine_params : Names.Idset.t -> +val combine_params_freevar : + Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) -> + Topconstr.constr_expr * Names.Idset.t + +val implicit_application : Idset.t -> ?allow_partial:bool -> (Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) -> Topconstr.constr_expr * Names.Idset.t) -> - (Topconstr.constr_expr * Topconstr.explicitation located option) list -> - ((global_reference * bool) option * Term.rel_declaration) list -> - Topconstr.constr_expr list * Names.Idset.t - + constr_expr -> constr_expr diff --git a/interp/modintern.ml b/interp/modintern.ml index 4cc30b26..d40205ce 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: modintern.ml 11127 2008-06-14 15:39:46Z herbelin $ *) +(* $Id: modintern.ml 11582 2008-11-12 19:49:57Z notin $ *) open Pp open Util @@ -61,34 +61,6 @@ let lookup_qualid (modtype:bool) qid = *) -let split_modpath mp = - let rec aux = function - | MPfile dp -> dp, [] - | MPbound mbid -> - Lib.library_dp (), [id_of_mbid mbid] - | MPself msid -> Lib.library_dp (), [id_of_msid msid] - | MPdot (mp,l) -> let (mp', lab) = aux mp in - (mp', id_of_label l :: lab) - in - let (mp, l) = aux mp in - mp, l - -let dump_moddef loc mp ty = - if !Flags.dump then - let (dp, l) = split_modpath mp in - let mp = string_of_dirpath (make_dirpath l) in - Flags.dump_string (Printf.sprintf "%s %d %s %s\n" ty (fst (unloc loc)) "<>" mp) - -let rec drop_last = function [] -> assert false | hd :: [] -> [] | hd :: tl -> hd :: drop_last tl - -let dump_modref loc mp ty = - if !Flags.dump then - let (dp, l) = split_modpath mp in - let fp = string_of_dirpath dp in - let mp = string_of_dirpath (make_dirpath (drop_last l)) in - Flags.dump_string (Printf.sprintf "R%d %s %s %s %s\n" - (fst (unloc loc)) fp mp "<>" ty) - (* Search for the head of [qid] in [binders]. If found, returns the module_path/kernel_name created from the dirpath and the basename. Searches Nametab otherwise. @@ -96,14 +68,14 @@ let dump_modref loc mp ty = let lookup_module (loc,qid) = try let mp = Nametab.locate_module qid in - dump_modref loc mp "modtype"; mp + Dumpglob.dump_modref loc mp "modtype"; mp with | Not_found -> Modops.error_not_a_module_loc loc (string_of_qualid qid) let lookup_modtype (loc,qid) = try let mp = Nametab.locate_modtype qid in - dump_modref loc mp "mod"; mp + Dumpglob.dump_modref loc mp "mod"; mp with | Not_found -> Modops.error_not_a_modtype_loc loc (string_of_qualid qid) diff --git a/interp/modintern.mli b/interp/modintern.mli index c92756dc..36971599 100644 --- a/interp/modintern.mli +++ b/interp/modintern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modintern.mli 11065 2008-06-06 22:39:43Z msozeau $ i*) +(*i $Id: modintern.mli 11582 2008-11-12 19:49:57Z notin $ i*) (*i*) open Declarations @@ -26,6 +26,3 @@ val interp_modtype : env -> module_type_ast -> module_struct_entry val interp_modexpr : env -> module_ast -> module_struct_entry val lookup_module : qualid located -> module_path - -val dump_moddef : loc -> module_path -> string -> unit -val dump_modref : loc -> module_path -> string -> unit diff --git a/interp/notation.ml b/interp/notation.ml index 9e83b860..fcb2b6f5 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: notation.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: notation.ml 11512 2008-10-27 12:28:36Z herbelin $ *) (*i*) open Util @@ -193,10 +193,6 @@ let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *) | ARef ref -> RefKey ref, None | _ -> Oth, None -let pattern_key = function - | PatCstr (_,cstr,_,_) -> RefKey (ConstructRef cstr) - | _ -> Oth - (**********************************************************************) (* Interpreting numbers (not in summary because functional objects) *) @@ -408,7 +404,7 @@ let exists_notation_in_scope scopt ntn r = r' = r with Not_found -> false -let isAVar = function AVar _ -> true | _ -> false +let isAVar_or_AHole = function AVar _ | AHole _ -> true | _ -> false (**********************************************************************) (* Mapping classes to scopes *) @@ -620,7 +616,7 @@ let browse_notation strict ntn map = let global_reference_of_notation test (ntn,(sc,c,_)) = match c with | ARef ref when test ref -> Some (ntn,sc,ref) - | AApp (ARef ref, l) when List.for_all isAVar l & test ref -> + | AApp (ARef ref, l) when List.for_all isAVar_or_AHole l & test ref -> Some (ntn,sc,ref) | _ -> None @@ -632,8 +628,12 @@ let error_notation_not_reference loc ntn = str "Unable to interpret " ++ quote (str ntn) ++ str " as a reference.") -let interp_notation_as_global_reference loc test ntn = - let ntns = browse_notation true ntn !scope_map in +let interp_notation_as_global_reference loc test ntn sc = + let scopes = match sc with + | Some sc -> + Gmap.add sc (find_scope (find_delimiters_scope dummy_loc sc)) Gmap.empty + | None -> !scope_map in + let ntns = browse_notation true ntn scopes in let refs = List.map (global_reference_of_notation test) ntns in match Option.List.flatten refs with | [_,_,ref] -> ref diff --git a/interp/notation.mli b/interp/notation.mli index a393aaed..4d7289c2 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: notation.mli 9804 2007-04-28 13:56:03Z herbelin $ i*) +(*i $Id: notation.mli 11445 2008-10-11 16:42:46Z herbelin $ i*) (*i*) open Util @@ -131,7 +131,7 @@ val level_of_notation : notation -> level (* raise [Not_found] if no level *) (*s** Miscellaneous *) val interp_notation_as_global_reference : loc -> (global_reference -> bool) -> - notation -> global_reference + notation -> delimiters option -> global_reference (* Checks for already existing notations *) val exists_notation_in_scope : scope_name option -> notation -> diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 884dea48..fe998cba 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: syntax_def.ml 10730 2008-03-30 21:42:58Z herbelin $ *) +(* $Id: syntax_def.ml 11512 2008-10-27 12:28:36Z herbelin $ *) open Util open Pp @@ -70,11 +70,18 @@ let (in_syntax_constant, out_syntax_constant) = classify_function = classify_syntax_constant; export_function = export_syntax_constant } +type syndef_interpretation = (identifier * subscopes) list * aconstr + +(* Coercions to the general format of notation that also supports + variables bound to list of expressions *) +let in_pat (ids,ac) = ((ids,[]),ac) +let out_pat ((ids,idsl),ac) = assert (idsl=[]); (ids,ac) + let declare_syntactic_definition local id onlyparse pat = - let _ = add_leaf id (in_syntax_constant (local,pat,onlyparse)) in () + let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in () let search_syntactic_definition loc kn = - KNmap.find kn !syntax_table + out_pat (KNmap.find kn !syntax_table) let locate_global_with_alias (loc,qid) = match Nametab.extended_locate qid with diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index a063caf0..0f5e0be7 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: syntax_def.mli 10730 2008-03-30 21:42:58Z herbelin $ i*) +(*i $Id: syntax_def.mli 11512 2008-10-27 12:28:36Z herbelin $ i*) (*i*) open Util @@ -18,10 +18,12 @@ open Libnames (* Syntactic definitions. *) -val declare_syntactic_definition : bool -> identifier -> bool -> interpretation - -> unit +type syndef_interpretation = (identifier * subscopes) list * aconstr -val search_syntactic_definition : loc -> kernel_name -> interpretation +val declare_syntactic_definition : bool -> identifier -> bool -> + syndef_interpretation -> unit + +val search_syntactic_definition : loc -> kernel_name -> syndef_interpretation (* [locate_global_with_alias] locates global reference possibly following a notation if this notation has a role of aliasing; raise Not_found diff --git a/interp/topconstr.ml b/interp/topconstr.ml index a51b6bb0..89ddd001 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: topconstr.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: topconstr.ml 11739 2009-01-02 19:33:19Z herbelin $ *) (*i*) open Pp @@ -389,8 +389,9 @@ let rec subst_aconstr subst bound raw = if r1' == r1 then raw else ACast (r1',CastCoerce) -let subst_interpretation subst (metas,pat) = - (metas,subst_aconstr subst (List.map fst metas) pat) +let subst_interpretation subst (metas,pat) = + let bound = List.map fst (fst metas @ snd metas) in + (metas,subst_aconstr subst bound pat) let encode_list_value l = RApp (dummy_loc,RVar (dummy_loc,ldots_var),l) @@ -427,16 +428,16 @@ let rec alpha_var id1 id2 = function let alpha_eq_val (x,y) = x = y -let bind_env alp sigma var v = +let bind_env alp (sigma,sigmalist as fullsigma) var v = try let vvar = List.assoc var sigma in - if alpha_eq_val (v,vvar) then sigma + if alpha_eq_val (v,vvar) then fullsigma else raise No_match with Not_found -> (* Check that no capture of binding variables occur *) if List.exists (fun (id,_) ->occur_rawconstr id v) alp then raise No_match; (* TODO: handle the case of multiple occs in different scopes *) - (var,v)::sigma + ((var,v)::sigma,sigmalist) let match_fix_kind fk1 fk2 = match (fk1,fk2) with @@ -467,6 +468,10 @@ let rec match_cases_pattern metas acc pat1 pat2 = (match_names metas acc na1 na2) patl1 patl2 | _ -> raise No_match +let adjust_application_n n loc f l = + let l1,l2 = list_chop (List.length l - n) l in + if l1 = [] then f,l else RApp (loc,f,l1), l2 + let rec match_ alp metas sigma a1 a2 = match (a1,a2) with | r1, AVar id2 when List.mem id2 metas -> bind_env alp sigma id2 r1 | RVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> sigma @@ -481,8 +486,9 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with let l11,l12 = list_chop (n1-n2) l1 in RApp (loc,f1,l11),l12, f2,l2 else f1,l1, f2, l2 in List.fold_left2 (match_ alp metas) (match_ alp metas sigma f1 f2) l1 l2 - | RApp (_,f1,l1), AList (x,_,(AApp (f2,l2) as iter),termin,lassoc) - when List.length l1 = List.length l2 -> + | RApp (loc,f1,l1), AList (x,_,(AApp (f2,l2) as iter),termin,lassoc) + when List.length l1 >= List.length l2 -> + let f1,l1 = adjust_application_n (List.length l2) loc f1 l1 in match_alist alp metas sigma (f1::l1) (f2::l2) x iter termin lassoc | RLambda (_,na1,_,t1,b1), ALambda (na2,t2,b2) -> match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2 @@ -496,9 +502,12 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with & List.length eqnl1 = List.length eqnl2 -> let rtno1' = abstract_return_type_context_rawconstr tml1 rtno1 in let rtno2' = abstract_return_type_context_aconstr tml2 rtno2 in - let sigma = Option.fold_left2 (match_ alp metas) sigma rtno1' rtno2' in + let sigma = + try Option.fold_left2 (match_ alp metas) sigma rtno1' rtno2' + with Option.Heterogeneous -> raise No_match + in let sigma = List.fold_left2 - (fun s (tm1,_) (tm2,_) -> match_ alp metas s tm1 tm2) sigma tml1 tml2 in + (fun s (tm1,_) (tm2,_) -> match_ alp metas s tm1 tm2) sigma tml1 tml2 in List.fold_left2 (match_equations alp metas) sigma eqnl1 eqnl2 | RLetTuple (_,nal1,(na1,to1),b1,c1), ALetTuple (nal2,(na2,to2),b2,c2) when List.length nal1 = List.length nal2 -> @@ -535,24 +544,26 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with and match_alist alp metas sigma l1 l2 x iter termin lassoc = (* match the iterator at least once *) - let sigma = List.fold_left2 (match_ alp (ldots_var::metas)) sigma l1 l2 in + let sigmavar,sigmalist = + List.fold_left2 (match_ alp (ldots_var::metas)) sigma l1 l2 in (* Recover the recursive position *) - let rest = List.assoc ldots_var sigma in + let rest = List.assoc ldots_var sigmavar in (* Recover the first element *) - let t1 = List.assoc x sigma in - let sigma = List.remove_assoc x (List.remove_assoc ldots_var sigma) in + let t1 = List.assoc x sigmavar in + let sigmavar = List.remove_assoc x (List.remove_assoc ldots_var sigmavar) in (* try to find the remaining elements or the terminator *) let rec match_alist_tail alp metas sigma acc rest = try - let sigma = match_ alp (ldots_var::metas) sigma rest iter in - let rest = List.assoc ldots_var sigma in - let t = List.assoc x sigma in - let sigma = List.remove_assoc x (List.remove_assoc ldots_var sigma) in - match_alist_tail alp metas sigma (t::acc) rest + let sigmavar,sigmalist = match_ alp (ldots_var::metas) sigma rest iter in + let rest = List.assoc ldots_var sigmavar in + let t = List.assoc x sigmavar in + let sigmavar = + List.remove_assoc x (List.remove_assoc ldots_var sigmavar) in + match_alist_tail alp metas (sigmavar,sigmalist) (t::acc) rest with No_match -> - List.rev acc, match_ alp metas sigma rest termin in - let tl,sigma = match_alist_tail alp metas sigma [t1] rest in - (x,encode_list_value (if lassoc then List.rev tl else tl))::sigma + List.rev acc, match_ alp metas (sigmavar,sigmalist) rest termin in + let tl,(sigmavar,sigmalist) = match_alist_tail alp metas sigma [t1] rest in + (sigmavar, (x,if lassoc then List.rev tl else tl)::sigmalist) and match_binders alp metas na1 na2 sigma b1 b2 = let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in @@ -569,19 +580,24 @@ type scope_name = string type tmp_scope_name = scope_name -type interpretation = - (identifier * (tmp_scope_name option * scope_name list)) list * aconstr +type subscopes = tmp_scope_name option * scope_name list -let match_aconstr c (metas_scl,pat) = - let subst = match_ [] (List.map fst metas_scl) [] c pat in +type interpretation = + (* regular vars of notation / recursive parts of notation / body *) + ((identifier * subscopes) list * (identifier * subscopes) list) * aconstr + +let match_aconstr c ((metas_scl,metaslist_scl),pat) = + let vars = List.map fst metas_scl @ List.map fst metaslist_scl in + let subst,substlist = match_ [] vars ([],[]) c pat in (* Reorder canonically the substitution *) - let find x subst = + let find x = try List.assoc x subst with Not_found -> (* Happens for binders bound to Anonymous *) (* Find a better way to propagate Anonymous... *) RVar (dummy_loc,x) in - List.map (fun (x,scl) -> (find x subst,scl)) metas_scl + List.map (fun (x,scl) -> (find x,scl)) metas_scl, + List.map (fun (x,scl) -> (List.assoc x substlist,scl)) metaslist_scl (**********************************************************************) (*s Concrete syntax for terms *) @@ -590,18 +606,23 @@ type notation = string type explicitation = ExplByPos of int * identifier option | ExplByName of identifier -type binder_kind = Default of binding_kind | TypeClass of binding_kind * binding_kind +type binder_kind = Default of binding_kind | Generalized of binding_kind * binding_kind * bool + +type abstraction_kind = AbsLambda | AbsPi type proj_flag = int option (* [Some n] = proj of the n-th visible argument *) type prim_token = Numeral of Bigint.bigint | String of string +type 'a notation_substitution = + 'a list * (* for recursive notations: *) 'a list list + type cases_pattern_expr = | CPatAlias of loc * cases_pattern_expr * identifier | CPatCstr of loc * reference * cases_pattern_expr list | CPatAtom of loc * reference option | CPatOr of loc * cases_pattern_expr list - | CPatNotation of loc * notation * cases_pattern_expr list + | CPatNotation of loc * notation * cases_pattern_expr notation_substitution | CPatPrim of loc * prim_token | CPatDelimiters of loc * string * cases_pattern_expr @@ -616,6 +637,7 @@ type constr_expr = | CAppExpl of loc * (proj_flag * reference) * constr_expr list | CApp of loc * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list + | CRecord of loc * constr_expr option * (identifier located * constr_expr) list | CCases of loc * case_style * constr_expr option * (constr_expr * (name option * constr_expr option)) list * (loc * cases_pattern_expr list located list * constr_expr) list @@ -628,7 +650,8 @@ type constr_expr = | CEvar of loc * existential_key * constr_expr list option | CSort of loc * rawsort | CCast of loc * constr_expr * constr_expr cast_type - | CNotation of loc * notation * constr_expr list + | CNotation of loc * notation * constr_expr notation_substitution + | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr | CPrim of loc * prim_token | CDelimiters of loc * string * constr_expr | CDynamic of loc * Dyn.t @@ -652,6 +675,8 @@ and recursion_order_expr = | CWfRec of constr_expr | CMeasureRec of constr_expr +type constr_pattern_expr = constr_expr + (***********************) (* For binders parsing *) @@ -687,6 +712,7 @@ let constr_loc = function | CLetIn (loc,_,_,_) -> loc | CAppExpl (loc,_,_) -> loc | CApp (loc,_,_) -> loc + | CRecord (loc,_,_) -> loc | CCases (loc,_,_,_,_) -> loc | CLetTuple (loc,_,_,_,_) -> loc | CIf (loc,_,_,_,_) -> loc @@ -696,6 +722,7 @@ let constr_loc = function | CSort (loc,_) -> loc | CCast (loc,_,_) -> loc | CNotation (loc,_,_) -> loc + | CGeneralization (loc,_,_,_) -> loc | CPrim (loc,_) -> loc | CDelimiters (loc,_,_) -> loc | CDynamic _ -> dummy_loc @@ -718,7 +745,7 @@ let ids_of_cases_indtype = let rec vars_of = function (* We deal only with the regular cases *) | CApp (_,_,l) -> List.fold_left add_var [] (List.map fst l) - | CNotation (_,_,l) + | CNotation (_,_,(l,[])) (* assume the ntn is applicative and does not instantiate the head !! *) | CAppExpl (_,_,l) -> List.fold_left add_var [] l | CDelimiters(_,_,c) -> vars_of c @@ -738,8 +765,10 @@ let is_constructor id = let rec cases_pattern_fold_names f a = function | CPatAlias (_,pat,id) -> f id a - | CPatCstr (_,_,patl) | CPatOr (_,patl) | CPatNotation (_,_,patl) -> + | CPatCstr (_,_,patl) | CPatOr (_,patl) -> List.fold_left (cases_pattern_fold_names f) a patl + | CPatNotation (_,_,(patl,patll)) -> + List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll) | CPatDelimiters (_,_,pat) -> cases_pattern_fold_names f a pat | CPatAtom (_,Some (Ident (_,id))) when not (is_constructor id) -> f id a | CPatPrim _ | CPatAtom _ -> a @@ -776,10 +805,12 @@ let fold_constr_expr_with_binders g f n acc = function | CLetIn (_,na,a,b) -> fold_constr_expr_binders g f n acc b [[na],default_binder_kind,a] | CCast (loc,a,CastConv(_,b)) -> f n (f n acc a) b | CCast (loc,a,CastCoerce) -> f n acc a - | CNotation (_,_,l) -> List.fold_left (f n) acc l + | CNotation (_,_,(l,ll)) -> List.fold_left (f n) acc (l@List.flatten ll) + | CGeneralization (_,_,_,c) -> f n acc c | CDelimiters (loc,_,a) -> f n acc a | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CDynamic _ | CRef _ -> acc + | CRecord (loc,_,l) -> List.fold_left (fun acc (id, c) -> f n acc c) acc l | CCases (loc,sty,rtnpo,al,bl) -> let ids = ids_of_cases_tomatch al in let acc = Option.fold_left (f (List.fold_right g ids n)) acc rtnpo in @@ -887,10 +918,13 @@ let map_constr_expr_with_binders g f e = function | CLetIn (loc,na,a,b) -> CLetIn (loc,na,f e a,f (name_fold g (snd na) e) b) | CCast (loc,a,CastConv (k,b)) -> CCast (loc,f e a,CastConv(k, f e b)) | CCast (loc,a,CastCoerce) -> CCast (loc,f e a,CastCoerce) - | CNotation (loc,n,l) -> CNotation (loc,n,List.map (f e) l) + | CNotation (loc,n,(l,ll)) -> + CNotation (loc,n,(List.map (f e) l,List.map (List.map (f e)) ll)) + | CGeneralization (loc,b,a,c) -> CGeneralization (loc,b,a,f e c) | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a) | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CDynamic _ | CRef _ as x -> x + | CRecord (loc,p,l) -> CRecord (loc,p,List.map (fun (id, c) -> (id, f e c)) l) | CCases (loc,sty,rtnpo,a,bl) -> (* TODO: apply g on the binding variables in pat... *) let bl = List.map (fun (loc,pat,rhs) -> (loc,pat,f e rhs)) bl in @@ -947,3 +981,10 @@ type module_type_ast = type include_ast = | CIMTE of module_type_ast | CIME of module_ast + +let loc_of_notation f loc args ntn = + if args=[] or ntn.[0] <> '_' then fst (Util.unloc loc) + else snd (Util.unloc (f (List.hd args))) + +let ntn_loc = loc_of_notation constr_loc +let patntn_loc = loc_of_notation cases_pattern_expr_loc diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 2ac9da11..1dd5ec97 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: topconstr.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: topconstr.mli 11739 2009-01-02 19:33:19Z herbelin $ i*) (*i*) open Pp @@ -77,11 +77,14 @@ type scope_name = string type tmp_scope_name = scope_name -type interpretation = - (identifier * (tmp_scope_name option * scope_name list)) list * aconstr +type subscopes = tmp_scope_name option * scope_name list + +type interpretation = + (* regular vars of notation / recursive parts of notation / body *) + ((identifier * subscopes) list * (identifier * subscopes) list) * aconstr val match_aconstr : rawconstr -> interpretation -> - (rawconstr * (tmp_scope_name option * scope_name list)) list + (rawconstr * subscopes) list * (rawconstr list * subscopes) list (**********************************************************************) (* Substitution of kernel names in interpretation data *) @@ -95,18 +98,27 @@ type notation = string type explicitation = ExplByPos of int * identifier option | ExplByName of identifier -type binder_kind = Default of binding_kind | TypeClass of binding_kind * binding_kind +type binder_kind = + | Default of binding_kind + | Generalized of binding_kind * binding_kind * bool + (* Inner binding, outer bindings, typeclass-specific flag + for implicit generalization of superclasses *) + +type abstraction_kind = AbsLambda | AbsPi type proj_flag = int option (* [Some n] = proj of the n-th visible argument *) type prim_token = Numeral of Bigint.bigint | String of string +type 'a notation_substitution = + 'a list * (* for recursive notations: *) 'a list list + type cases_pattern_expr = | CPatAlias of loc * cases_pattern_expr * identifier | CPatCstr of loc * reference * cases_pattern_expr list | CPatAtom of loc * reference option | CPatOr of loc * cases_pattern_expr list - | CPatNotation of loc * notation * cases_pattern_expr list + | CPatNotation of loc * notation * cases_pattern_expr notation_substitution | CPatPrim of loc * prim_token | CPatDelimiters of loc * string * cases_pattern_expr @@ -121,6 +133,7 @@ type constr_expr = | CAppExpl of loc * (proj_flag * reference) * constr_expr list | CApp of loc * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list + | CRecord of loc * constr_expr option * (identifier located * constr_expr) list | CCases of loc * case_style * constr_expr option * (constr_expr * (name option * constr_expr option)) list * (loc * cases_pattern_expr list located list * constr_expr) list @@ -133,7 +146,8 @@ type constr_expr = | CEvar of loc * existential_key * constr_expr list option | CSort of loc * rawsort | CCast of loc * constr_expr * constr_expr cast_type - | CNotation of loc * notation * constr_expr list + | CNotation of loc * notation * constr_expr notation_substitution + | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr | CPrim of loc * prim_token | CDelimiters of loc * string * constr_expr | CDynamic of loc * Dyn.t @@ -158,6 +172,8 @@ type typeclass_constraint = name located * binding_kind * constr_expr and typeclass_context = typeclass_constraint list +type constr_pattern_expr = constr_expr + (**********************************************************************) (* Utilities on constr_expr *) @@ -240,3 +256,5 @@ type include_ast = | CIMTE of module_type_ast | CIME of module_ast +val ntn_loc : Util.loc -> constr_expr list -> string -> int +val patntn_loc : Util.loc -> cases_pattern_expr list -> string -> int diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 6e99bf79..f4827029 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: declarations.ml 10664 2008-03-14 11:27:37Z soubiran $ i*) +(*i $Id: declarations.ml 11417 2008-09-17 15:06:57Z soubiran $ i*) (*i*) open Util @@ -251,7 +251,8 @@ type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * constraints option + | SFBalias of module_path * struct_expr_body option + * constraints option | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list @@ -265,7 +266,8 @@ and struct_expr_body = | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path * constraints + With_module_body of identifier list * module_path + * struct_expr_body option * constraints | With_definition_body of identifier list * constant_body and module_body = diff --git a/kernel/declarations.mli b/kernel/declarations.mli index fa03a338..b4f5f1f7 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: declarations.mli 10664 2008-03-14 11:27:37Z soubiran $ i*) +(*i $Id: declarations.mli 11417 2008-09-17 15:06:57Z soubiran $ i*) (*i*) open Names @@ -181,7 +181,8 @@ type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * constraints option + | SFBalias of module_path * struct_expr_body option + *constraints option | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list @@ -195,7 +196,8 @@ and struct_expr_body = | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path * constraints + With_module_body of identifier list * module_path + * struct_expr_body option * constraints | With_definition_body of identifier list * constant_body and module_body = diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 01b8aca1..06764834 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: indtypes.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: indtypes.ml 11784 2009-01-14 11:36:32Z herbelin $ *) open Util open Names @@ -46,6 +46,7 @@ type inductive_error = | SameNamesOverlap of identifier list | NotAnArity of identifier | BadEntry + | LargeNonPropInductiveNotInType exception InductiveError of inductive_error @@ -266,7 +267,7 @@ let typecheck_inductive env mie = | Prop Pos when engagement env <> Some ImpredicativeSet -> (* Predicative set: check that the content is indeed predicative *) if not (is_type0m_univ lev) & not (is_type0_univ lev) then - error "Large non-propositional inductive types must be in Type."; + raise (InductiveError LargeNonPropInductiveNotInType); Inl (info,full_arity,s), cst | Prop _ -> Inl (info,full_arity,s), cst in diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 0477df82..90ae70c3 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: indtypes.mli 10425 2008-01-05 17:04:16Z herbelin $ i*) +(*i $Id: indtypes.mli 11784 2009-01-14 11:36:32Z herbelin $ i*) (*i*) open Names @@ -33,6 +33,7 @@ type inductive_error = | SameNamesOverlap of identifier list | NotAnArity of identifier | BadEntry + | LargeNonPropInductiveNotInType exception InductiveError of inductive_error diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 4bb8e9d6..99ec1650 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: inductive.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: inductive.ml 11647 2008-12-02 10:40:11Z barras $ *) open Util open Names @@ -683,7 +683,8 @@ let check_one_fix renv recpos def = List.iter (check_rec_call renv) l | Some c -> try List.iter (check_rec_call renv) l - with FixGuardError _ -> check_rec_call renv (applist(c,l)) + with FixGuardError _ -> + check_rec_call renv (applist(lift p c,l)) end | Case (ci,p,c_0,lrest) -> diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 6840febd..4a9fb606 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mod_typing.ml 11170 2008-06-25 08:31:04Z soubiran $ i*) +(*i $Id: mod_typing.ml 11514 2008-10-28 13:39:02Z soubiran $ i*) open Util open Names @@ -37,14 +37,46 @@ let rec list_fold_map2 f e = function let e'',t1',t2' = list_fold_map2 f e' t in e'',h1'::t1',h2'::t2' +let rec rebuild_mp mp l = + match l with + []-> mp + | i::r -> rebuild_mp (MPdot(mp,i)) r + +let type_of_struct env b meb = + let rec aux env = function + | SEBfunctor (mp,mtb,body) -> + let env = add_module (MPbound mp) (module_body_of_type mtb) env in + SEBfunctor(mp,mtb, aux env body) + | SEBident mp -> + strengthen env (lookup_modtype mp env).typ_expr mp + | SEBapply _ as mtb -> eval_struct env mtb + | str -> str + in + if b then + Some (aux env meb) + else + None + +let rec bounded_str_expr = function + | SEBfunctor (mp,mtb,body) -> bounded_str_expr body + | SEBident mp -> (check_bound_mp mp) + | SEBapply (f,a,_)->(bounded_str_expr f) + | _ -> false + +let return_opt_type mp env mtb = + if (check_bound_mp mp) then + Some (strengthen env mtb.typ_expr mp) + else + None + let rec check_with env mtb with_decl = match with_decl with | With_Definition (id,_) -> let cb = check_with_aux_def env mtb with_decl in SEBwith(mtb,With_definition_body(id,cb)),empty_subst | With_Module (id,mp) -> - let cst,sub = check_with_aux_mod env mtb with_decl true in - SEBwith(mtb,With_module_body(id,mp,cst)),sub + let cst,sub,typ_opt = check_with_aux_mod env mtb with_decl true in + SEBwith(mtb,With_module_body(id,mp,typ_opt,cst)),sub and check_with_aux_def env mtb with_decl = let msid,sig_b = match (eval_struct env mtb) with @@ -140,7 +172,7 @@ and check_with_aux_mod env mtb with_decl now = | With_Module ([id], mp) -> let old,alias = match spec with SFBmodule msb -> Some msb,None - | SFBalias (mp',cst) -> None,Some (mp',cst) + | SFBalias (mp',_,cst) -> None,Some (mp',cst) | _ -> error_not_a_module (string_of_label l) in let mtb' = lookup_modtype mp env' in @@ -164,35 +196,48 @@ and check_with_aux_mod env mtb with_decl now = in if now then let mp' = scrape_alias mp env' in - let up_subst = update_subst mtb'.typ_alias (map_mp (mp_rec [id]) mp') in - cst, (join (map_mp (mp_rec [id]) mp') up_subst) + let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in + let up_subst = update_subst sub (map_mp (mp_rec [id]) mp') in + cst, (join (map_mp (mp_rec [id]) mp') up_subst),(return_opt_type mp env' mtb') else - cst,empty_subst + cst,empty_subst,(return_opt_type mp env' mtb') | With_Module (_::_,mp) -> - let old = match spec with - SFBmodule msb -> msb + let old,alias = match spec with + SFBmodule msb -> Some msb, None + | SFBalias (mpold,typ_opt,cst)->None, Some mpold | _ -> error_not_a_module (string_of_label l) in begin - match old.mod_expr with - None -> - let new_with_decl = match with_decl with - With_Definition (_,c) -> - With_Definition (idl,c) - | With_Module (_,c) -> With_Module (idl,c) in - let cst,_ = - check_with_aux_mod env' - (type_of_mb env old) new_with_decl false in - if now then - let mtb' = lookup_modtype mp env' in - let mp' = scrape_alias mp env' in - let up_subst = update_subst - mtb'.typ_alias (map_mp (mp_rec (List.rev (id::idl))) mp') in - cst, (join (map_mp (mp_rec (List.rev (id::idl))) mp') up_subst) + if alias = None then + let old = Option.get old in + match old.mod_expr with + None -> + let new_with_decl = match with_decl with + With_Definition (_,c) -> + With_Definition (idl,c) + | With_Module (_,c) -> With_Module (idl,c) in + let cst,_,typ_opt = + check_with_aux_mod env' + (type_of_mb env' old) new_with_decl false in + if now then + let mtb' = lookup_modtype mp env' in + let mp' = scrape_alias mp env' in + let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in + let up_subst = update_subst + sub (map_mp (mp_rec (List.rev (id::idl))) mp') in + cst, + (join (map_mp (mp_rec (List.rev (id::idl))) mp') up_subst), + typ_opt + else + cst,empty_subst,typ_opt + | Some msb -> + error_a_generative_module_expected l else - cst,empty_subst - | Some msb -> - error_a_generative_module_expected l + let mpold = Option.get alias in + let mpnew = rebuild_mp mpold (List.map label_of_id idl) in + check_modpath_equiv env' mpnew mp; + let mtb' = lookup_modtype mp env' in + Constraint.empty,empty_subst,(return_opt_type mp env' mtb') end | _ -> anomaly "Modtyping:incorrect use of with" with @@ -214,7 +259,9 @@ and translate_module env me = let meb,sub1 = translate_struct_entry env mexpr in let mod_typ,sub,cst = match me.mod_entry_type with - | None -> None,sub1,Constraint.empty + | None -> + (type_of_struct env (bounded_str_expr meb) meb) + ,sub1,Constraint.empty | Some mte -> let mtb2,sub2 = translate_struct_entry env mte in let cst = check_subtypes env @@ -304,7 +351,7 @@ let rec add_struct_expr_constraints env = function | SEBwith(meb,With_definition_body(_,cb))-> Environ.add_constraints cb.const_constraints (add_struct_expr_constraints env meb) - | SEBwith(meb,With_module_body(_,_,cst))-> + | SEBwith(meb,With_module_body(_,_,_,cst))-> Environ.add_constraints cst (add_struct_expr_constraints env meb) @@ -312,8 +359,8 @@ and add_struct_elem_constraints env = function | SFBconst cb -> Environ.add_constraints cb.const_constraints env | SFBmind mib -> Environ.add_constraints mib.mind_constraints env | SFBmodule mb -> add_module_constraints env mb - | SFBalias (mp,Some cst) -> Environ.add_constraints cst env - | SFBalias (mp,None) -> env + | SFBalias (mp,_,Some cst) -> Environ.add_constraints cst env + | SFBalias (mp,_,None) -> env | SFBmodtype mtb -> add_modtype_constraints env mtb and add_module_constraints env mb = @@ -352,15 +399,15 @@ let rec struct_expr_constraints cst = function | SEBwith(meb,With_definition_body(_,cb))-> struct_expr_constraints (Univ.Constraint.union cb.const_constraints cst) meb - | SEBwith(meb,With_module_body(_,_,cst1))-> + | SEBwith(meb,With_module_body(_,_,_,cst1))-> struct_expr_constraints (Univ.Constraint.union cst1 cst) meb and struct_elem_constraints cst = function | SFBconst cb -> cst | SFBmind mib -> cst | SFBmodule mb -> module_constraints cst mb - | SFBalias (mp,Some cst1) -> Univ.Constraint.union cst1 cst - | SFBalias (mp,None) -> cst + | SFBalias (mp,_,Some cst1) -> Univ.Constraint.union cst1 cst + | SFBalias (mp,_,None) -> cst | SFBmodtype mtb -> modtype_constraints cst mtb and module_constraints cst mb = diff --git a/kernel/modops.ml b/kernel/modops.ml index 7bed3254..25a11c69 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modops.ml 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: modops.ml 11514 2008-10-28 13:39:02Z soubiran $ i*) (*i*) open Util @@ -113,16 +113,18 @@ let module_body_of_type mtb = mod_retroknowledge = []} let module_type_of_module mp mb = - {typ_expr = + let mp1,expr = (match mb.mod_type with - | Some expr -> expr + | Some expr -> mp,expr | None -> (match mb.mod_expr with - | Some expr -> expr + | Some (SEBident mp') ->(Some mp'),(SEBident mp') + | Some expr -> mp,expr | None -> - anomaly "Modops: empty expr and type")); - typ_alias = mb.mod_alias; - typ_strength = mp - } + anomaly "Modops: empty expr and type")) in + {typ_expr = expr; + typ_alias = mb.mod_alias; + typ_strength = mp1 + } let rec check_modpath_equiv env mp1 mp2 = if mp1=mp2 then () else @@ -132,13 +134,14 @@ let rec check_modpath_equiv env mp1 mp2 = else error_not_equal mp1 mp2 -let subst_with_body sub = function - | With_module_body(id,mp,cst) -> - With_module_body(id,subst_mp sub mp,cst) +let rec subst_with_body sub = function + | With_module_body(id,mp,typ_opt,cst) -> + With_module_body(id,subst_mp sub mp,Option.smartmap + (subst_struct_expr sub) typ_opt,cst) | With_definition_body(id,cb) -> With_definition_body( id,subst_const_body sub cb) -let rec subst_modtype sub mtb = +and subst_modtype sub mtb = let typ_expr' = subst_struct_expr sub mtb.typ_expr in if typ_expr'==mtb.typ_expr then mtb @@ -156,8 +159,9 @@ and subst_structure sub sign = SFBmodule (subst_module sub mb) | SFBmodtype mtb -> SFBmodtype (subst_modtype sub mtb) - | SFBalias (mp,cst) -> - SFBalias (subst_mp sub mp,cst) + | SFBalias (mp,typ_opt,cst) -> + SFBalias (subst_mp sub mp,Option.smartmap + (subst_struct_expr sub) typ_opt,cst) in List.map (fun (l,b) -> (l,subst_body b)) sign @@ -277,7 +281,7 @@ let rec eval_struct env = function | SEBwith (mtb,(With_definition_body _ as wdb)) -> let mtb',_ = merge_with env mtb wdb empty_subst in mtb' - | SEBwith (mtb, (With_module_body (_,mp,_) as wdb)) -> + | SEBwith (mtb, (With_module_body (_,mp,_,_) as wdb)) -> let alias_in_mp = (lookup_modtype mp env).typ_alias in let alias_in_mp = match eval_struct env (SEBident mp) with @@ -303,8 +307,8 @@ and merge_with env mtb with_decl alias= | _ -> 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 + | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl + | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false in let l = label_of_id id in try @@ -314,47 +318,54 @@ and merge_with env mtb with_decl alias= | [] -> MPself msid | i::r -> MPdot(mp_rec r,label_of_id i) in + let env' = add_signature (MPself msid) before env in let new_spec,subst = match with_decl with | With_definition_body ([],_) - | With_module_body ([],_,_) -> assert false + | With_module_body ([],_,_,_) -> assert false | With_definition_body ([id],c) -> SFBconst c,None - | With_module_body ([id], mp,cst) -> - let mp' = scrape_alias mp env in + | With_module_body ([id], mp,typ_opt,cst) -> + let mp' = scrape_alias mp env' in let new_alias = update_subst alias (map_mp (mp_rec [id]) mp') in - SFBalias (mp,Some cst), + SFBalias (mp,typ_opt,Some cst), Some(join (map_mp (mp_rec [id]) mp') new_alias) | With_definition_body (_::_,_) - | With_module_body (_::_,_,_) -> - let old = match spec with - SFBmodule msb -> msb + | With_module_body (_::_,_,_,_) -> + let old,aliasold = match spec with + SFBmodule msb -> Some msb, None + | SFBalias (mpold,typ_opt,cst) ->None, Some (mpold,typ_opt,cst) | _ -> error_not_a_module (string_of_label l) in - let new_with_decl,subst1 = - match with_decl with - With_definition_body (_,c) -> With_definition_body (idl,c),None - | With_module_body (idc,mp,cst) -> - let mp' = scrape_alias mp env in - With_module_body (idl,mp,cst), - Some(map_mp (mp_rec (List.rev idc)) mp') - in - let subst = match subst1 with - | None -> None - | Some s -> Some (join s (update_subst alias s)) in - let modtype,subst_msb = - merge_with env (type_of_mb env old) new_with_decl alias in - let msb = - { mod_expr = None; - mod_type = Some modtype; - mod_constraints = old.mod_constraints; - mod_alias = begin - match subst_msb with - |None -> empty_subst - |Some s -> s - end; - mod_retroknowledge = old.mod_retroknowledge} - in - (SFBmodule msb),subst + if aliasold = None then + let old = Option.get old in + let new_with_decl,subst1 = + match with_decl with + With_definition_body (_,c) -> With_definition_body (idl,c),None + | With_module_body (idc,mp,typ_opt,cst) -> + let mp' = scrape_alias mp env' in + With_module_body (idl,mp,typ_opt,cst), + Some(map_mp (mp_rec (List.rev idc)) mp') + in + let subst = match subst1 with + | None -> None + | Some s -> Some (join s (update_subst alias s)) in + let modtype,subst_msb = + merge_with env' (type_of_mb env' old) new_with_decl alias in + let msb = + { mod_expr = None; + mod_type = Some modtype; + mod_constraints = old.mod_constraints; + mod_alias = begin + match subst_msb with + |None -> empty_subst + |Some s -> s + end; + mod_retroknowledge = old.mod_retroknowledge} + in + (SFBmodule msb),subst + else + let mpold,typ_opt,cst = Option.get aliasold in + SFBalias (mpold,typ_opt,cst),None in SEBstruct(msid, before@(l,new_spec):: (Option.fold_right subst_structure subst after)),subst @@ -371,7 +382,7 @@ and add_signature mp sign env = | SFBmodule mb -> add_module (MPdot (mp,l)) mb env (* adds components as well *) - | SFBalias (mp1,cst) -> + | SFBalias (mp1,_,cst) -> Environ.register_alias (MPdot(mp,l)) mp1 env | SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) mtb env @@ -402,7 +413,7 @@ and constants_of_specification env mp sign = let new_env = add_module (MPdot (mp,l)) mb env in new_env,(constants_of_modtype env (MPdot (mp,l)) (type_of_mb env mb)) @ res - | SFBalias (mp1,cst) -> + | SFBalias (mp1,typ_opt,cst) -> let new_env = register_alias (MPdot (mp,l)) mp1 env in new_env,(constants_of_modtype env (MPdot (mp,l)) (eval_struct env (SEBident mp1))) @ res @@ -494,7 +505,7 @@ and strengthen_sig env msid sign mp = match sign with (MPdot (MPself msid,l)) mb env in let rest' = strengthen_sig env' msid rest mp in item':: rest' - | ((l,SFBalias (mp1,cst)) as item) :: rest -> + | ((l,SFBalias (mp1,_,cst)) as item) :: rest -> let env' = register_alias (MPdot(MPself msid,l)) mp1 env in let rest' = strengthen_sig env' msid rest mp in item::rest' diff --git a/kernel/names.ml b/kernel/names.ml index 25f03495..b4dcd7c8 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: names.ml 11238 2008-07-19 09:34:03Z herbelin $ *) +(* $Id: names.ml 11750 2009-01-05 20:47:34Z herbelin $ *) open Pp open Util @@ -17,7 +17,7 @@ type identifier = string let id_ord = Pervasives.compare -let id_of_string s = check_ident s; String.copy s +let id_of_string s = check_ident_soft s; String.copy s let string_of_id id = String.copy id @@ -86,6 +86,7 @@ type label = string type mod_self_id = uniq_ident let make_msid = make_uid +let repr_msid (n, id, dp) = (n, id, dp) let debug_string_of_msid = debug_string_of_uid let refresh_msid (_,s,dir) = make_uid dir s let string_of_msid = string_of_uid @@ -94,6 +95,7 @@ let label_of_msid (_,s,_) = s type mod_bound_id = uniq_ident let make_mbid = make_uid +let repr_mbid (n, id, dp) = (n, id, dp) let debug_string_of_mbid = debug_string_of_uid let string_of_mbid = string_of_uid let id_of_mbid (_,s,_) = s @@ -115,8 +117,14 @@ type module_path = | MPself of mod_self_id | MPdot of module_path * label + +let rec check_bound_mp = function + | MPbound _ -> true + | MPdot(mp,_) ->check_bound_mp mp + | _ -> false + let rec string_of_mp = function - | MPfile sl -> string_of_dirpath sl + | MPfile sl -> "MPfile (" ^ string_of_dirpath sl ^ ")" | MPbound uid -> string_of_uid uid | MPself uid -> string_of_uid uid | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l diff --git a/kernel/names.mli b/kernel/names.mli index c6f59048..49b10bfe 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: names.mli 10919 2008-05-11 22:04:26Z msozeau $ i*) +(*i $Id: names.mli 11582 2008-11-12 19:49:57Z notin $ i*) (*s Identifiers *) @@ -48,6 +48,7 @@ type mod_self_id (* The first argument is a file name - to prevent conflict between different files *) val make_msid : dir_path -> string -> mod_self_id +val repr_msid : mod_self_id -> int * string * dir_path val id_of_msid : mod_self_id -> identifier val label_of_msid : mod_self_id -> label val refresh_msid : mod_self_id -> mod_self_id @@ -58,6 +59,7 @@ val string_of_msid : mod_self_id -> string type mod_bound_id val make_mbid : dir_path -> string -> mod_bound_id +val repr_mbid : mod_bound_id -> int * string * dir_path val id_of_mbid : mod_bound_id -> identifier val label_of_mbid : mod_bound_id -> label val debug_string_of_mbid : mod_bound_id -> string @@ -82,6 +84,7 @@ type module_path = | MPdot of module_path * label (*i | MPapply of module_path * module_path in the future (maybe) i*) +val check_bound_mp : module_path -> bool val string_of_mp : module_path -> string diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 3c7461b2..fbb05a2d 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: safe_typing.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: safe_typing.ml 11453 2008-10-15 14:42:34Z soubiran $ *) open Util open Names @@ -312,6 +312,13 @@ let add_alias l mp senv = check_label l senv.labset; let mp' = MPdot(senv.modinfo.modpath, l) in let mp1 = scrape_alias mp senv.env in + let typ_opt = + if check_bound_mp mp then + Some (strengthen senv.env + (lookup_modtype mp senv.env).typ_expr mp) + else + None + in (* we get all updated alias substitution {mp1.K\M} that comes from mp1 *) let _,sub = Modops.update_subst senv.env (lookup_module mp1 senv.env) mp1 in (* transformation of {mp1.K\M} to {mp.K\M}*) @@ -327,7 +334,7 @@ let add_alias l mp senv = alias_subst = join senv.modinfo.alias_subst sub}; labset = Labset.add l senv.labset; - revstruct = (l,SFBalias (mp,None))::senv.revstruct; + revstruct = (l,SFBalias (mp,typ_opt,None))::senv.revstruct; univ = senv.univ; engagement = senv.engagement; imports = senv.imports; @@ -502,7 +509,7 @@ let end_module l restype senv = imports = senv'.imports; loads = senv'.loads; local_retroknowledge = senv'.local_retroknowledge } - | SFBalias (mp',cst) -> + | SFBalias (mp',typ_opt,cst) -> let env' = Option.fold_right Environ.add_constraints cst senv.env in let mp = MPdot(senv.modinfo.modpath, l) in @@ -518,7 +525,7 @@ let end_module l restype senv = alias_subst = join senv.modinfo.alias_subst sub}; labset = Labset.add l senv.labset; - revstruct = (l,SFBalias (mp',cst))::senv.revstruct; + revstruct = (l,SFBalias (mp',typ_opt,cst))::senv.revstruct; univ = senv.univ; engagement = senv.engagement; imports = senv.imports; diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 14020c0b..98ee1dbb 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtyping.ml 11142 2008-06-18 15:37:31Z soubiran $ i*) +(*i $Id: subtyping.ml 11453 2008-10-15 14:42:34Z soubiran $ i*) (*i*) open Util @@ -33,7 +33,7 @@ type namedobject = | IndConstr of constructor * mutual_inductive_body | Module of module_body | Modtype of module_type_body - | Alias of module_path + | Alias of module_path * struct_expr_body option (* adds above information about one mutual inductive: all types and constructors *) @@ -64,7 +64,7 @@ let make_label_map mp list = add_nameobjects_of_mib (make_kn mp empty_dirpath l) mib map | SFBmodule mb -> add_map (Module mb) | SFBmodtype mtb -> add_map (Modtype mtb) - | SFBalias (mp,cst) -> add_map (Alias mp) + | SFBalias (mp,typ_opt,cst) -> add_map (Alias (mp,typ_opt)) in List.fold_right add_one list Labmap.empty @@ -352,23 +352,23 @@ and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = begin match info1 with | Module msb -> check_modules cst env msid1 l msb msb2 alias - | Alias mp ->let msb = + | Alias (mp,typ_opt) ->let msb = {mod_expr = Some (SEBident mp); - mod_type = Some (eval_struct env (SEBident mp)); + mod_type = typ_opt; mod_constraints = Constraint.empty; mod_alias = (lookup_modtype mp env).typ_alias; mod_retroknowledge = []} in check_modules cst env msid1 l msb msb2 alias | _ -> error_not_match l spec2 end - | SFBalias (mp,_) -> + | SFBalias (mp,typ_opt,_) -> begin match info1 with - | Alias mp1 -> check_modpath_equiv env mp mp1; cst + | Alias (mp1,_) -> check_modpath_equiv env mp mp1; cst | Module msb -> let msb1 = {mod_expr = Some (SEBident mp); - mod_type = Some (eval_struct env (SEBident mp)); + mod_type = typ_opt; mod_constraints = Constraint.empty; mod_alias = (lookup_modtype mp env).typ_alias; mod_retroknowledge = []} in diff --git a/kernel/univ.ml b/kernel/univ.ml index 11a5452c..3d254ce6 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: univ.ml 11301 2008-08-04 19:41:18Z herbelin $ *) +(* $Id: univ.ml 11596 2008-11-16 15:34:06Z letouzey $ *) (* Initial Caml version originates from CoC 4.8 [Dec 1988] *) (* Extension with algebraic universes by HH [Sep 2001] *) @@ -43,13 +43,25 @@ type universe_level = | Set | Level of Names.dir_path * int +(* A specialized comparison function: we compare the [int] part first. + This way, most of the time, the [dir_path] part is not considered. *) + +let cmp_univ_level u v = match u,v with + | Set, Set -> 0 + | Set, _ -> -1 + | _, Set -> 1 + | Level (dp1,i1), Level (dp2,i2) -> + if i1 < i2 then -1 + else if i1 > i2 then 1 + else compare dp1 dp2 + type universe = | Atom of universe_level | Max of universe_level list * universe_level list module UniverseOrdered = struct type t = universe_level - let compare = Pervasives.compare + let compare = cmp_univ_level end let string_of_univ_level = function @@ -86,7 +98,8 @@ let super = function Used to type the products. *) let sup u v = match u,v with - | Atom u, Atom v -> if u = v then Atom u else Max ([u;v],[]) + | Atom u, Atom v -> + if cmp_univ_level u v = 0 then Atom u else Max ([u;v],[]) | u, Max ([],[]) -> u | Max ([],[]), v -> v | Atom u, Max (gel,gtl) -> Max (list_add_set u gel,gtl) @@ -601,12 +614,12 @@ let dump_universes output g = let u_str = string_of_univ_level u in List.iter (fun v -> - Printf.fprintf output "%s > %s ;\n" u_str + Printf.fprintf output "%s < %s ;\n" u_str (string_of_univ_level v)) lt; List.iter (fun v -> - Printf.fprintf output "%s >= %s ;\n" u_str + Printf.fprintf output "%s <= %s ;\n" u_str (string_of_univ_level v)) le | Equiv (u,v) -> diff --git a/lib/envars.ml b/lib/envars.ml new file mode 100644 index 00000000..5887adcd --- /dev/null +++ b/lib/envars.ml @@ -0,0 +1,84 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* raise Not_found + | p :: tl -> + if Sys.file_exists (Filename.concat p f) + then p + else which tl f + +let guess_camlbin () = + let path = try Sys.getenv "PATH" with _ -> raise Not_found in + let lpath = path_to_list path in + which lpath "ocamlc" + +let guess_camlp4bin () = + let path = try Sys.getenv "PATH" with _ -> raise Not_found in + let lpath = path_to_list path in + which lpath Coq_config.camlp4 + +let camlbin () = + if !Flags.camlbin_spec then !Flags.camlbin else + if !Flags.boot then Coq_config.camlbin else + try guess_camlbin () with _ -> Coq_config.camlbin + +let camllib () = + if !Flags.boot + then Coq_config.camllib + else + let camlbin = camlbin () in + let com = (Filename.concat camlbin "ocamlc") ^ " -where" in + let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in + Util.strip res + +(* TODO : essayer aussi camlbin *) +let camlp4bin () = + if !Flags.camlp4bin_spec then !Flags.camlp4bin else + if !Flags.boot then Coq_config.camlp4bin else + try guess_camlp4bin () with _ -> Coq_config.camlp4bin + +let camlp4lib () = + if !Flags.boot + then Coq_config.camlp4lib + else + let camlp4bin = camlp4bin () in + let com = (Filename.concat camlp4bin Coq_config.camlp4) ^ " -where" in + let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in + Util.strip res + + diff --git a/lib/envars.mli b/lib/envars.mli new file mode 100644 index 00000000..62d0cb61 --- /dev/null +++ b/lib/envars.mli @@ -0,0 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* string +val coqbin : unit -> string + +val camlbin : unit -> string +val camlp4bin : unit -> string +val camllib : unit -> string +val camlp4lib : unit -> string diff --git a/lib/flags.ml b/lib/flags.ml index 16ae0c64..928912e6 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -6,13 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: flags.ml 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: flags.ml 11801 2009-01-18 20:11:41Z herbelin $ i*) let with_option o f x = let old = !o in o:=true; try let r = f x in o := old; r with e -> o := old; raise e +let without_option o f x = + let old = !o in o:=false; + try let r = f x in o := old; r + with e -> o := old; raise e + let boot = ref false let batch_mode = ref false @@ -33,13 +38,10 @@ let raw_print = ref false let unicode_syntax = ref false (* Translate *) -let translate = ref false -let make_translate f = translate := f -let do_translate () = !translate -let translate_file = ref false - -(* True only when interning from pp*new.ml *) -let translate_syntax = ref false +let beautify = ref false +let make_beautify f = beautify := f +let do_beautify () = !beautify +let beautify_file = ref false (* Silent / Verbose *) let silent = ref false @@ -47,16 +49,8 @@ let make_silent flag = silent := flag; () let is_silent () = !silent let is_verbose () = not !silent -let silently f x = - let oldsilent = !silent in - try - silent := true; - let rslt = f x in - silent := oldsilent; - rslt - with e -> begin - silent := oldsilent; raise e - end +let silently f x = with_option silent f x +let verbosely f x = without_option silent f x let if_silent f x = if !silent then f x let if_verbose f x = if not !silent then f x @@ -82,33 +76,13 @@ let unsafe_set = ref Stringset.empty let add_unsafe s = unsafe_set := Stringset.add s !unsafe_set let is_unsafe s = Stringset.mem s !unsafe_set -(* Dump of globalization (to be used by coqdoc) *) - -let dump = ref false -let dump_file = ref "" -let dump_into_file f = dump := true; dump_file := f - -let dump_buffer = Buffer.create 8192 - -let dump_string = Buffer.add_string dump_buffer - -let dump_it () = - if !dump then begin - let mode = [Open_wronly; Open_append; Open_creat] in - let c = open_out_gen mode 0o666 !dump_file in - output_string c (Buffer.contents dump_buffer); - close_out c - end - -let _ = at_exit dump_it - -(* Flags.for the virtual machine *) +(* Flags for the virtual machine *) let boxed_definitions = ref true let set_boxed_definitions b = boxed_definitions := b let boxed_definitions _ = !boxed_definitions -(* Flags.for external tools *) +(* Flags for external tools *) let subst_command_placeholder s t = let buff = Buffer.create (String.length s + String.length t) in @@ -127,3 +101,16 @@ let browser_cmd_fmt = Sys.getenv coq_netscape_remote_var with Not_found -> Coq_config.browser + +(* Options for changing coqlib *) +let coqlib_spec = ref false +let coqlib = ref Coq_config.coqlib + +(* Options for changing camlbin (used by coqmktop) *) +let camlbin_spec = ref false +let camlbin = ref Coq_config.camlbin + +(* Options for changing camlp4bin (used by coqmktop) *) +let camlp4bin_spec = ref false +let camlp4bin = ref Coq_config.camlp4bin + diff --git a/lib/flags.mli b/lib/flags.mli index 1fcae990..c5903285 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: flags.mli 10921 2008-05-12 12:27:25Z msozeau $ i*) +(*i $Id: flags.mli 11801 2009-01-18 20:11:41Z herbelin $ i*) (* Global options of the system. *) @@ -29,16 +29,16 @@ val raw_print : bool ref val unicode_syntax : bool ref -val translate : bool ref -val make_translate : bool -> unit -val do_translate : unit -> bool -val translate_file : bool ref -val translate_syntax : bool ref +val beautify : bool ref +val make_beautify : bool -> unit +val do_beautify : unit -> bool +val beautify_file : bool ref val make_silent : bool -> unit val is_silent : unit -> bool val is_verbose : unit -> bool val silently : ('a -> 'b) -> 'a -> 'b +val verbosely : ('a -> 'b) -> 'a -> 'b val if_silent : ('a -> unit) -> 'a -> unit val if_verbose : ('a -> unit) -> 'a -> unit @@ -47,9 +47,13 @@ val if_warn : ('a -> unit) -> 'a -> unit val hash_cons_proofs : bool ref -(* Temporary activate an option ('c must be an atomic type) *) +(* Temporary activate an option (to activate option [o] on [f x y z], + use [with_option o (f x y) z]) *) val with_option : bool ref -> ('a -> 'b) -> 'a -> 'b +(* Temporary deactivate an option *) +val without_option : bool ref -> ('a -> 'b) -> 'a -> 'b + (* If [None], no limit *) val set_print_hyps_limit : int option -> unit val print_hyps_limit : unit -> int option @@ -57,12 +61,6 @@ val print_hyps_limit : unit -> int option val add_unsafe : string -> unit val is_unsafe : string -> bool -(* Dump of globalization (to be used by coqdoc) *) - -val dump : bool ref -val dump_into_file : string -> unit -val dump_string : string -> unit - (* Options for the virtual machine *) val set_boxed_definitions : bool -> unit @@ -75,3 +73,13 @@ val browser_cmd_fmt : string (* Substitute %s in the first chain by the second chain *) val subst_command_placeholder : string -> string -> string + +(* Options for specifying where coq librairies reside *) +val coqlib_spec : bool ref +val coqlib : string ref + +(* Options for specifying where OCaml binaries reside *) +val camlbin_spec : bool ref +val camlbin : string ref +val camlp4bin_spec : bool ref +val camlp4bin : string ref diff --git a/lib/option.ml b/lib/option.ml index 34749b8c..85efdd44 100644 --- a/lib/option.ml +++ b/lib/option.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: option.ml 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id: option.ml 11576 2008-11-10 19:13:15Z msozeau $ i*) (** Module implementing basic combinators for OCaml option type. It tries follow closely the style of OCaml standard library. @@ -97,6 +97,10 @@ let fold_right f x a = | Some y -> f y a | _ -> a +(** [cata f a x] is [a] if [x] is [None] and [f y] if [x] is [Some y]. *) +let cata f a = function + | Some c -> f c + | None -> a (** {6 More Specific operations} ***) diff --git a/lib/option.mli b/lib/option.mli index d9c18d88..6fa89098 100644 --- a/lib/option.mli +++ b/lib/option.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: option.mli 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: option.mli 11576 2008-11-10 19:13:15Z msozeau $ *) (** Module implementing basic combinators for OCaml option type. It tries follow closely the style of OCaml standard library. @@ -66,6 +66,8 @@ val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b option -> 'c option -> 'a (** [fold_right f x a] is [f y a] if [x] is [Some y], and [a] otherwise. *) val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b +(** [cata e f x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *) +val cata : ('a -> 'b) -> 'b -> 'a option -> 'b (** {6 More Specific Operations} ***) diff --git a/lib/system.ml b/lib/system.ml index 22eb52ee..65826c81 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: system.ml 11209 2008-07-05 10:17:49Z herbelin $ *) +(* $Id: system.ml 11801 2009-01-18 20:11:41Z herbelin $ *) open Pp open Util @@ -63,6 +63,34 @@ type load_path = physical_path list let physical_path_of_string s = s let string_of_physical_path p = p +(* Hints to partially detects if two paths refer to the same repertory *) +let rec remove_path_dot p = + let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) + let n = String.length curdir in + if String.length p > n && String.sub p 0 n = curdir then + remove_path_dot (String.sub p n (String.length p - n)) + else + p + +let strip_path p = + let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *) + let n = String.length cwd in + if String.length p > n && String.sub p 0 n = cwd then + remove_path_dot (String.sub p n (String.length p - n)) + else + remove_path_dot p + +let canonical_path_name p = + let current = Sys.getcwd () in + try + Sys.chdir p; + let p' = Sys.getcwd () in + Sys.chdir current; + p' + with Sys_error _ -> + (* We give up to find a canonical name and just simplify it... *) + strip_path p + (* All subdirectories, recursively *) let exists_dir dir = @@ -100,7 +128,7 @@ let all_subdirs ~unix_path:root = if exists_dir root then traverse root []; List.rev !l -let where_in_path warn path filename = +let where_in_path ?(warn=true) path filename = let rec search = function | lpe :: rem -> let f = Filename.concat lpe filename in @@ -116,25 +144,26 @@ let where_in_path warn path filename = msg_warning (str filename ++ str " has been found in" ++ spc () ++ hov 0 (str "[ " ++ - hv 0 (prlist_with_sep pr_semicolon (fun (lpe,_) -> str lpe) l) + hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon()) + (fun (lpe,_) -> str lpe) l) ++ str " ];") ++ fnl () ++ str "loading " ++ str f); (lpe, f) in check_and_warn (search path) -let find_file_in_path paths filename = +let find_file_in_path ?(warn=true) paths filename = if not (Filename.is_implicit filename) then let root = Filename.dirname filename in root, filename else - try where_in_path true paths filename + try where_in_path ~warn paths filename with Not_found -> errorlabstrm "System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ str "on loadpath")) let is_in_path lpath filename = - try ignore (where_in_path false lpath filename); true + try ignore (where_in_path ~warn:false lpath filename); true with Not_found -> false let make_suffix name suffix = @@ -172,7 +201,7 @@ let raw_extern_intern magic suffix = in (extern_state,intern_state) -let extern_intern magic suffix = +let extern_intern ?(warn=true) magic suffix = let (raw_extern,raw_intern) = raw_extern_intern magic suffix in let extern_state name val_0 = try @@ -185,7 +214,7 @@ let extern_intern magic suffix = with Sys_error s -> error ("System error: " ^ s) and intern_state paths name = try - let _,filename = find_file_in_path paths (make_suffix name suffix) in + let _,filename = find_file_in_path ~warn paths (make_suffix name suffix) in let channel = raw_intern filename in let v = marshal_in channel in close_in channel; diff --git a/lib/system.mli b/lib/system.mli index eb83cbf8..ba5aa408 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: system.mli 11209 2008-07-05 10:17:49Z herbelin $ i*) +(*i $Id: system.mli 11801 2009-01-18 20:11:41Z herbelin $ i*) (*s Files and load paths. Load path entries remember the original root given by the user. For efficiency, we keep the full path (field @@ -16,11 +16,13 @@ type physical_path = string type load_path = physical_path list +val canonical_path_name : string -> string + val exclude_search_in_dirname : string -> unit val all_subdirs : unix_path:string -> (physical_path * string list) list val is_in_path : load_path -> string -> bool -val where_in_path : bool -> load_path -> string -> physical_path * string +val where_in_path : ?warn:bool -> load_path -> string -> physical_path * string val physical_path_of_string : string -> physical_path val string_of_physical_path : physical_path -> string @@ -34,7 +36,8 @@ val home : string val exists_dir : string -> bool -val find_file_in_path : load_path -> string -> physical_path * string +val find_file_in_path : + ?warn:bool -> load_path -> string -> physical_path * string (*s Generic input and output functions, parameterized by a magic number and a suffix. The intern functions raise the exception [Bad_magic_number] @@ -48,8 +51,8 @@ exception Bad_magic_number of string val raw_extern_intern : int -> string -> (string -> string * out_channel) * (string -> in_channel) -val extern_intern : - int -> string -> (string -> 'a -> unit) * (load_path -> string -> 'a) +val extern_intern : ?warn:bool -> int -> string -> + (string -> 'a -> unit) * (load_path -> string -> 'a) (*s Sending/receiving once with external executable *) diff --git a/lib/util.ml b/lib/util.ml index a19cc65b..a73a5558 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: util.ml 11350 2008-09-02 15:37:49Z barras $ *) +(* $Id: util.ml 11845 2009-01-22 18:55:08Z letouzey $ *) open Pp @@ -59,6 +59,9 @@ let is_letter c = (c >= 'a' && c <= 'z') or (c >= 'A' && c <= 'Z') let is_digit c = (c >= '0' && c <= '9') let is_ident_tail c = is_letter c or is_digit c or c = '\'' or c = '_' +let is_blank = function + | ' ' | '\r' | '\t' | '\n' -> true + | _ -> false (* Strings *) @@ -73,6 +76,21 @@ let explode s = let implode sl = String.concat "" sl +let strip s = + let n = String.length s in + let rec lstrip_rec i = + if i < n && is_blank s.[i] then + lstrip_rec (i+1) + else i + in + let rec rstrip_rec i = + if i >= 0 && is_blank s.[i] then + rstrip_rec (i-1) + else i + in + let a = lstrip_rec 0 and b = rstrip_rec (n-1) in + String.sub s a (b-a+1) + (* substring searching... *) (* gdzie = where, co = what *) @@ -83,6 +101,9 @@ let rec is_sub gdzie gl gi co cl ci = (is_sub gdzie gl (gi+1) co cl (ci+1))) let rec raw_str_index i gdzie l c co cl = + (* First adapt to ocaml 3.11 new semantics of index_from *) + if (i+cl > l) then raise Not_found; + (* Then proceed as in ocaml < 3.11 *) let i' = String.index_from gdzie i c in if (i'+cl <= l) && (is_sub gdzie l i' co cl 0) then i' else raw_str_index (i'+1) gdzie l c co cl @@ -106,19 +127,23 @@ let ordinal n = (* string parsing *) -let parse_loadpath s = +let split_string_at c s = let len = String.length s in - let rec decoupe_dirs n = + let rec split n = try - let pos = String.index_from s n '/' in - if pos = n then - invalid_arg "parse_loadpath: find an empty dir in loadpath"; + let pos = String.index_from s n c in let dir = String.sub s n (pos-n) in - dir :: (decoupe_dirs (succ pos)) + dir :: split (succ pos) with | Not_found -> [String.sub s n (len-n)] in - if len = 0 then [] else decoupe_dirs 0 + if len = 0 then [] else split 0 + +let parse_loadpath s = + let l = split_string_at '/' s in + if List.mem "" l then + invalid_arg "parse_loadpath: find an empty dir in loadpath"; + l module Stringset = Set.Make(struct type t = string let compare = compare end) @@ -239,6 +264,8 @@ let classify_unicode unicode = end | _ -> begin match unicode with + (* utf-8 CJC Symbols and Punctuation *) + | x when 0x3008 <= x & x <= 0x3020 -> UnicodeSymbol (* utf-8 Hiragana U3040-309F and Katakana U30A0-30FF *) | x when 0x3040 <= x & x <= 0x30FF -> UnicodeLetter (* utf-8 Unified CJK Ideographs U4E00-9FA5 *) @@ -304,27 +331,40 @@ let next_utf8 s i = (* Check the well-formedness of an identifier *) -let check_ident s = +let check_initial handle j n s = + match classify_unicode n with + | UnicodeLetter -> () + | _ -> + let c = String.sub s 0 j in + handle ("Invalid character '"^c^"' at beginning of identifier \""^s^"\".") + +let check_trailing handle i j n s = + match classify_unicode n with + | UnicodeLetter | UnicodeIdentPart -> () + | _ -> + let c = String.sub s i j in + handle ("Invalid character '"^c^"' in identifier \""^s^"\".") + +let check_ident_gen handle s = let i = ref 0 in if s <> ".." then try let j, n = next_utf8 s 0 in - match classify_unicode n with - | UnicodeLetter -> - i := !i + j; - begin try - while true do - let j, n = next_utf8 s !i in - match classify_unicode n with - | UnicodeLetter | UnicodeIdentPart -> i := !i + j - | _ -> error - ("invalid character "^(String.sub s !i j)^" in identifier "^s) - done - with End_of_input -> () end - | _ -> error (s^": an identifier should start with a letter") + check_initial handle j n s; + i := !i + j; + try + while true do + let j, n = next_utf8 s !i in + check_trailing handle !i j n s; + i := !i + j + done + with End_of_input -> () with - | End_of_input -> error "The empty string is not an identifier" - | UnsupportedUtf8 -> error (s^": unsupported character in utf8 sequence") - | Invalid_argument _ -> error (s^": invalid utf8 sequence") + | End_of_input -> error "The empty string is not an identifier." + | UnsupportedUtf8 -> error (s^": unsupported character in utf8 sequence.") + | Invalid_argument _ -> error (s^": invalid utf8 sequence.") + +let check_ident_soft = check_ident_gen warning +let check_ident = check_ident_gen error let lowercase_unicode s unicode = match unicode land 0x1F000 with @@ -626,6 +666,10 @@ let rec list_remove_first a = function | b::l -> b::list_remove_first a l | [] -> raise Not_found +let rec list_remove_assoc_in_triple x = function + | [] -> [] + | (y,_,_ as z)::l -> if x = y then l else z::list_remove_assoc_in_triple x l + let list_add_set x l = if List.mem x l then l else x::l let list_eq_set l1 l2 = @@ -726,13 +770,21 @@ let list_subset l1 l2 = in look l1 -let list_splitby p = - let rec splitby_loop x y = +let list_split_at p = + let rec split_at_loop x y = match y with | [] -> ([],[]) - | (a::l) -> if (p a) then (x,y) else (splitby_loop (x@[a]) l) + | (a::l) -> if (p a) then (List.rev x,y) else split_at_loop (a::x) l + in + split_at_loop [] + +let list_split_by p = + let rec split_loop = function + | [] -> ([],[]) + | (a::l) -> + let (l1,l2) = split_loop l in if (p a) then (a::l1,l2) else (l1,a::l2) in - splitby_loop [] + split_loop let rec list_split3 = function | [] -> ([], [], []) @@ -859,6 +911,20 @@ let list_cartesians op init ll = let list_combinations l = list_cartesians (fun x l -> x::l) [] l +(* Keep only those products that do not return None *) + +let rec list_cartesian_filter op l1 l2 = + list_map_append (fun x -> list_map_filter (op x) l2) l1 + +(* Keep only those products that do not return None *) + +let rec list_cartesians_filter op init ll = + List.fold_right (list_cartesian_filter op) ll [init] + +(* Drop the last element of a list *) + +let rec list_drop_last = function [] -> assert false | hd :: [] -> [] | hd :: tl -> hd :: list_drop_last tl + (* Arrays *) let array_exists f v = @@ -902,6 +968,10 @@ let array_for_all4 f v1 v2 v3 v4 = lv1 = Array.length v4 && allrec (pred lv1) +let array_for_all_i f i v = + let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in + allrec i 0 + let array_hd v = match Array.length v with | 0 -> failwith "array_hd" @@ -1117,15 +1187,15 @@ let array_fold_map2' f v1 v2 e = (v',!e') let array_distinct v = + let visited = Hashtbl.create 23 in try - for i=0 to Array.length v-1 do - for j=i+1 to Array.length v-1 do - if v.(i)=v.(j) then raise Exit - done - done; + Array.iter + (fun x -> + if Hashtbl.mem visited x then raise Exit + else Hashtbl.add visited x x) + v; true - with Exit -> - false + with Exit -> false let array_union_map f a acc = Array.fold_left @@ -1209,11 +1279,13 @@ let rec prlist elem l = match l with | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t) (* unlike all other functions below, [prlist] works lazily. - if a strict behavior is needed, use [prlist_strict] instead. *) + if a strict behavior is needed, use [prlist_strict] instead. + evaluation is done from left to right. *) let rec prlist_strict elem l = match l with | [] -> mt () - | h::t -> (elem h)++(prlist_strict elem t) + | h::t -> + let e = elem h in let r = prlist_strict elem t in e++r (* [prlist_with_sep sep pr [a ; ... ; c]] outputs [pr a ++ sep() ++ ... ++ sep() ++ pr c] *) @@ -1275,7 +1347,7 @@ let prvect_with_sep sep elem v = let prvect elem v = prvect_with_sep mt elem v let pr_located pr (loc,x) = - if Flags.do_translate() && loc<>dummy_loc then + if Flags.do_beautify() && loc<>dummy_loc then let (b,e) = unloc loc in comment b ++ pr x ++ comment e else pr x diff --git a/lib/util.mli b/lib/util.mli index 99ad3c03..3cd934e7 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i $Id: util.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: util.mli 11769 2009-01-08 17:59:22Z glondu $ i*) (*i*) open Pp @@ -68,15 +68,18 @@ val pi3 : 'a * 'b * 'c -> 'c val is_letter : char -> bool val is_digit : char -> bool val is_ident_tail : char -> bool +val is_blank : char -> bool (*s Strings. *) val explode : string -> string list val implode : string list -> string +val strip : string -> string val string_index_from : string -> int -> string -> int val string_string_contains : where:string -> what:string -> bool val plural : int -> string -> string val ordinal : int -> string +val split_string_at : char -> string -> string list val parse_loadpath : string -> string list @@ -89,6 +92,7 @@ exception UnsupportedUtf8 val classify_unicode : int -> utf8_status val check_ident : string -> unit +val check_ident_soft : string -> unit val lowercase_first_char_utf8 : string -> string (*s Lists. *) @@ -137,6 +141,7 @@ val list_for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool val list_except : 'a -> 'a list -> 'a list val list_remove : 'a -> 'a list -> 'a list val list_remove_first : 'a -> 'a list -> 'a list +val list_remove_assoc_in_triple : 'a -> ('a * 'b * 'c) list -> ('a * 'b * 'c) list val list_for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool val list_sep_last : 'a list -> 'a * 'a list val list_try_find_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b @@ -145,7 +150,8 @@ val list_uniquize : 'a list -> 'a list (* merges two sorted lists and preserves the uniqueness property: *) val list_merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list val list_subset : 'a list -> 'a list -> bool -val list_splitby : ('a -> bool) -> 'a list -> 'a list * 'a list +val list_split_at : ('a -> bool) -> 'a list -> 'a list * 'a list +val list_split_by : ('a -> bool) -> 'a list -> 'a list * 'a list val list_split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list val list_partition_by : ('a -> 'a -> bool) -> 'a list -> 'a list list val list_firstn : int -> 'a list -> 'a list @@ -155,6 +161,7 @@ val list_skipn : int -> 'a list -> 'a list val list_addn : int -> 'a -> 'a list -> 'a list val list_prefix_of : 'a list -> 'a list -> bool val list_drop_prefix : 'a list -> 'a list -> 'a list +val list_drop_last : 'a list -> 'a list (* [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)] *) val list_map_append : ('a -> 'b list) -> 'a list -> 'b list val list_join_map : ('a -> 'b list) -> 'a list -> 'b list @@ -175,6 +182,11 @@ val list_cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val list_cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list (* list_combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *) val list_combinations : 'a list list -> 'a list list +(* Keep only those products that do not return None *) +val list_cartesian_filter : + ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list +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 @@ -187,6 +199,7 @@ val array_for_all3 : ('a -> 'b -> 'c -> bool) -> 'a array -> 'b array -> 'c array -> bool val array_for_all4 : ('a -> 'b -> 'c -> 'd -> bool) -> 'a array -> 'b array -> 'c array -> 'd array -> bool +val array_for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool val array_hd : 'a array -> 'a val array_tl : 'a array -> 'a array val array_last : 'a array -> 'a diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml index 8f2525b8..d6dfbb6b 100644 --- a/library/decl_kinds.ml +++ b/library/decl_kinds.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: decl_kinds.ml 11024 2008-05-30 12:41:39Z msozeau $ *) +(* $Id: decl_kinds.ml 11809 2009-01-20 11:39:55Z aspiwack $ *) open Util open Libnames @@ -112,3 +112,18 @@ let strength_of_global = function let string_of_strength = function | Local -> "Local" | Global -> "Global" + + +(* Recursive power *) + +(* spiwack: this definition might be of use in the kernel, for now I do not + push them deeper than needed, though. *) +type recursivity_kind = + | Finite (* = inductive *) + | CoFinite (* = coinductive *) + | BiFinite (* = non-recursive, like in "Record" definitions *) + +(* helper, converts to "finiteness flag" booleans *) +let recursivity_flag_of_kind = function + | Finite | BiFinite -> true + | CoFinite -> false diff --git a/library/decl_kinds.mli b/library/decl_kinds.mli index 9358c4b5..70c63c39 100644 --- a/library/decl_kinds.mli +++ b/library/decl_kinds.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: decl_kinds.mli 11024 2008-05-30 12:41:39Z msozeau $ *) +(* $Id: decl_kinds.mli 11809 2009-01-20 11:39:55Z aspiwack $ *) open Util open Libnames @@ -82,3 +82,13 @@ val string_of_definition_kind : val strength_of_global : global_reference -> locality val string_of_strength : locality -> string + +(* About recursive power of type declarations *) + +type recursivity_kind = + | Finite (* = inductive *) + | CoFinite (* = coinductive *) + | BiFinite (* = non-recursive, like in "Record" definitions *) + +(* helper, converts to "finiteness flag" booleans *) +val recursivity_flag_of_kind : recursivity_kind -> bool diff --git a/library/declaremods.ml b/library/declaremods.ml index b630b5dc..de1893c7 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: declaremods.ml 11246 2008-07-22 15:10:05Z soubiran $ i*) +(*i $Id: declaremods.ml 11703 2008-12-18 15:54:41Z soubiran $ i*) open Pp open Util open Names @@ -151,37 +151,60 @@ let check_subtypes mp sub_mtb = in () (* The constraints are checked and forgot immediately! *) -let subst_substobjs dir mp (subst,mbids,msid,objs) = +let compute_subst_objects mp (subst,mbids,msid,objs) = match mbids with - | [] -> + | [] -> + let subst' = join_alias (map_msid msid mp) subst in + Some (join (map_msid msid mp) (join subst' subst), objs) + | _ -> + None + +let subst_substobjs dir mp substobjs = + match compute_subst_objects mp substobjs with + | Some (subst, objs) -> let prefix = dir,(mp,empty_dirpath) in - let subst' = join_alias (map_msid msid mp) subst in - let subst = join subst' subst in - Some (subst_objects prefix (join (map_msid msid mp) subst) objs) - | _ -> None + Some (subst_objects prefix subst objs) + | None -> None + +(* These functions register the visibility of the module and iterates + through its components. They are called by plenty module functions *) + +let compute_visibility exists what i dir dirinfo = + if exists then + if + try Nametab.locate_dir (qualid_of_dirpath dir) = dirinfo + with Not_found -> false + then + Nametab.Exactly i + else + errorlabstrm (what^"_module") + (pr_dirpath dir ++ str " should already exist!") + else + if Nametab.exists_dir dir then + errorlabstrm (what^"_module") (pr_dirpath dir ++ str " already exists") + else + Nametab.Until i -(* This function registers the visibility of the module and iterates - through its components. It is called by plenty module functions *) +let do_load_and_subst_module i dir mp substobjs keep = + let prefix = (dir,(mp,empty_dirpath)) in + let dirinfo = DirModule (dir,(mp,empty_dirpath)) in + let vis = compute_visibility false "load_and_subst" i dir dirinfo in + let objects = compute_subst_objects mp substobjs in + Nametab.push_dir vis dir dirinfo; + modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs; + match objects with + | Some (subst,seg) -> + let seg = load_and_subst_objects (i+1) prefix subst seg in + modtab_objects := MPmap.add mp (prefix,seg) !modtab_objects; + load_objects (i+1) prefix keep; + Some (seg@keep) + | None -> + None let do_module exists what iter_objects i dir mp substobjs objects = let prefix = (dir,(mp,empty_dirpath)) in let dirinfo = DirModule (dir,(mp,empty_dirpath)) in - let vis = - if exists then - if - try Nametab.locate_dir (qualid_of_dirpath dir) = dirinfo - with Not_found -> false - then - Nametab.Exactly i - else - errorlabstrm (what^"_module") - (pr_dirpath dir ++ str " should already exist!") - else - if Nametab.exists_dir dir then - errorlabstrm (what^"_module") (pr_dirpath dir ++ str " already exists") - else - Nametab.Until i - in + let vis = compute_visibility exists what i dir dirinfo in Nametab.push_dir vis dir dirinfo; modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs; match objects with @@ -324,22 +347,7 @@ and do_module_alias exists what iter_objects i dir mp alias substobjs objects = try Some (MPmap.find alias !modtab_objects) with Not_found -> None in let dirinfo = DirModule (dir,(mp,empty_dirpath)) in - let vis = - if exists then - if - try Nametab.locate_dir (qualid_of_dirpath dir) = dirinfo - with Not_found -> false - then - Nametab.Exactly i - else - errorlabstrm (what^"_module") - (pr_dirpath dir ++ str " should already exist!") - else - if Nametab.exists_dir dir then - errorlabstrm (what^"_module") (pr_dirpath dir ++ str " already exists") - else - Nametab.Until i - in + let vis = compute_visibility exists what i dir dirinfo in Nametab.push_dir vis dir dirinfo; modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs; match alias_objects,objects with @@ -588,16 +596,21 @@ let rec replace_module_object idl (subst, mbids, msid, lib_stack) modobjs mp = let rec replace_idl = function | _,[] -> [] | id::idl,(id',obj)::tail when id = id' -> - if object_tag obj = "MODULE" then + let tag = object_tag obj in + if tag = "MODULE" or tag ="MODULE ALIAS" then (match idl with [] -> (id, in_module_alias (Some ({mod_entry_type = None; mod_entry_expr = Some (MSEident mp)},None) ,modobjs,None))::tail | _ -> - let (_,substobjs,_) = out_module obj in + let (a,substobjs,_) = if tag = "MODULE ALIAS" then + out_module_alias obj else out_module obj in let substobjs' = replace_module_object idl substobjs modobjs mp in - (id, in_module (None,substobjs',None))::tail + if tag = "MODULE ALIAS" then + (id, in_module_alias (a,substobjs',None))::tail + else + (id, in_module (None,substobjs',None))::tail ) else error "MODULE expected!" | idl,lobj::tail -> lobj::replace_idl (idl,tail) @@ -645,8 +658,8 @@ let rec get_modtype_substobjs env = function (* application outside the kernel, only for substitutive objects (that are all non-logical objects) *) ((join - (join subst (map_mbid mbid mp (Some resolve))) - sub3) + (join subst sub3) + (map_mbid mbid mp (Some resolve))) , mbids, msid, objs) | [] -> match mexpr with | MSEident _ -> error "Application of a non-functor" @@ -662,8 +675,7 @@ let process_module_bindings argids args = let dir = make_dirpath [id] in let mp = MPbound mbid in let substobjs = get_modtype_substobjs (Global.env()) mty in - let substituted = subst_substobjs dir mp substobjs in - do_module false "start" load_objects 1 dir mp substobjs substituted + ignore (do_load_and_subst_module 1 dir mp substobjs []) in List.iter2 process_arg argids args @@ -677,8 +689,7 @@ let intern_args interp_modtype (idl,arg) = (fun dir mbid -> Global.add_module_parameter mbid mty; let mp = MPbound mbid in - let substituted = subst_substobjs dir mp substobjs in - do_module false "interp" load_objects 1 dir mp substobjs substituted; + ignore (do_load_and_subst_module 1 dir mp substobjs []); (mbid,mty)) dirs mbids @@ -792,25 +803,19 @@ type library_objects = let register_library dir cenv objs digest = let mp = MPfile dir in - let substobjs, objects = - try - ignore(Global.lookup_module mp); - (* if it's in the environment, the cached objects should be correct *) - Dirmap.find dir !library_cache - with - Not_found -> - if mp <> Global.import cenv digest then - anomaly "Unexpected disk module name"; - let msid,substitute,keep = objs in - let substobjs = empty_subst, [], msid, substitute in - let substituted = subst_substobjs dir mp substobjs in - let objects = Option.map (fun seg -> seg@keep) substituted in - let modobjs = substobjs, objects in - library_cache := Dirmap.add dir modobjs !library_cache; - modobjs - in + try + ignore(Global.lookup_module mp); + (* if it's in the environment, the cached objects should be correct *) + let substobjs, objects = Dirmap.find dir !library_cache in do_module false "register_library" load_objects 1 dir mp substobjs objects - + with Not_found -> + if mp <> Global.import cenv digest then + anomaly "Unexpected disk module name"; + let msid,substitute,keep = objs in + let substobjs = empty_subst, [], msid, substitute in + let objects = do_load_and_subst_module 1 dir mp substobjs keep in + let modobjs = substobjs, objects in + library_cache := Dirmap.add dir modobjs !library_cache let start_library dir = let mp = Global.start_library dir in @@ -960,8 +965,8 @@ let rec get_module_substobjs env = function (* application outside the kernel, only for substitutive objects (that are all non-logical objects) *) ((join - (join subst (map_mbid mbid mp (Some resolve))) - sub3) + (join subst sub3) + (map_mbid mbid mp (Some resolve))) , mbids, msid, objs) | [] -> match mexpr with | MSEident _ -> error "Application of a non-functor" diff --git a/library/impargs.ml b/library/impargs.ml index 3a505ddb..2b2c607c 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: impargs.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: impargs.ml 11576 2008-11-10 19:13:15Z msozeau $ *) open Util open Names @@ -71,6 +71,7 @@ let make_maximal_implicit_args flag = let is_implicit_args () = !implicit_args.main let is_manual_implicit_args () = !implicit_args.manual +let is_auto_implicit_args () = !implicit_args.main && not (is_manual_implicit_args ()) let is_strict_implicit_args () = !implicit_args.strict let is_strongly_strict_implicit_args () = !implicit_args.strongly_strict let is_reversible_pattern_implicit_args () = !implicit_args.reversible_pattern @@ -577,10 +578,11 @@ type manual_explicitation = Topconstr.explicitation * (bool * bool) let compute_implicits_with_manual env typ enriching l = compute_manual_implicits env !implicit_args typ enriching l -let declare_manual_implicits local ref enriching l = +let declare_manual_implicits local ref ?enriching l = let flags = !implicit_args in let env = Global.env () in let t = Global.type_of_global ref in + let enriching = Option.default (is_auto_implicit_args ()) enriching in let l' = compute_manual_implicits env flags t enriching l in let req = if local or isVarRef ref then ImplLocal @@ -588,9 +590,9 @@ let declare_manual_implicits local ref enriching l = in add_anonymous_leaf (inImplicits (req,[ref,l'])) -let maybe_declare_manual_implicits local ref enriching l = +let maybe_declare_manual_implicits local ref ?enriching l = if l = [] then () - else declare_manual_implicits local ref enriching l + else declare_manual_implicits local ref ?enriching l let lift_implicits n = List.map (fun x -> diff --git a/library/impargs.mli b/library/impargs.mli index 705efd31..a363effa 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: impargs.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: impargs.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Names @@ -83,14 +83,16 @@ val declare_implicits : bool -> global_reference -> unit (* [declare_manual_implicits local ref enriching l] Manual declaration of which arguments are expected implicit. + If not set, we decide if it should enrich by automatically inferd + implicits depending on the current state. Unsets implicits if [l] is empty. *) -val declare_manual_implicits : bool -> global_reference -> bool -> +val declare_manual_implicits : bool -> global_reference -> ?enriching:bool -> manual_explicitation list -> unit (* If the list is empty, do nothing, otherwise declare the implicits. *) -val maybe_declare_manual_implicits : bool -> global_reference -> bool -> +val maybe_declare_manual_implicits : bool -> global_reference -> ?enriching:bool -> manual_explicitation list -> unit val implicits_of_global : global_reference -> implicits_list diff --git a/library/lib.ml b/library/lib.ml index fa71bb2f..88bcd0b8 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -6,11 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: lib.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: lib.ml 11784 2009-01-14 11:36:32Z herbelin $ *) open Pp open Util -open Names open Libnames open Nameops open Libobject @@ -33,7 +32,7 @@ and library_entry = object_name * node and library_segment = library_entry list -type lib_objects = (identifier * obj) list +type lib_objects = (Names.identifier * obj) list let iter_objects f i prefix = List.iter (fun (id,obj) -> f i (make_oname prefix id, obj)) @@ -49,11 +48,18 @@ let subst_objects prefix subst seg = in list_smartmap subst_one seg +let load_and_subst_objects i prefix subst seg = + List.rev (List.fold_left (fun seg (id,obj as node) -> + let obj' = subst_object (make_oname prefix id, subst, obj) in + let node = if obj == obj' then node else (id, obj') in + load_object i (make_oname prefix id, obj'); + node :: seg) [] seg) + let classify_segment seg = let rec clean ((substl,keepl,anticipl) as acc) = function | (_,CompilingLibrary _) :: _ | [] -> acc | ((sp,kn as oname),Leaf o) :: stk -> - let id = id_of_label (label kn) in + let id = Names.id_of_label (Names.label kn) in (match classify_object (oname,o) with | Dispose -> clean acc stk | Keep o' -> @@ -85,7 +91,7 @@ let segment_of_objects prefix = sections, but on the contrary there are many constructions of section paths based on the library path. *) -let initial_prefix = default_library,(initial_path,empty_dirpath) +let initial_prefix = default_library,(Names.initial_path,Names.empty_dirpath) let lib_stk = ref ([] : library_segment) @@ -98,8 +104,21 @@ let library_dp () = module path and relative section path *) let path_prefix = ref initial_prefix +let sections_depth () = + List.length (Names.repr_dirpath (snd (snd !path_prefix))) + +let sections_are_opened () = + match Names.repr_dirpath (snd (snd !path_prefix)) with + [] -> false + | _ -> true + let cwd () = fst !path_prefix +let current_dirpath sec = + Libnames.drop_dirpath_prefix (library_dp ()) + (if sec then cwd () + else Libnames.extract_dirpath_prefix (sections_depth ()) (cwd ())) + let make_path id = Libnames.make_path (cwd ()) id let path_of_include () = @@ -112,25 +131,15 @@ let current_prefix () = snd !path_prefix let make_kn id = let mp,dir = current_prefix () in - Names.make_kn mp dir (label_of_id id) + Names.make_kn mp dir (Names.label_of_id id) let make_con id = let mp,dir = current_prefix () in - Names.make_con mp dir (label_of_id id) + Names.make_con mp dir (Names.label_of_id id) let make_oname id = make_path id, make_kn id - -let sections_depth () = - List.length (repr_dirpath (snd (snd !path_prefix))) - -let sections_are_opened () = - match repr_dirpath (snd (snd !path_prefix)) with - [] -> false - | _ -> true - - let recalc_path_prefix () = let rec recalc = function | (sp, OpenedSection (dir,_)) :: _ -> dir @@ -194,7 +203,7 @@ let add_entry sp node = let anonymous_id = let n = ref 0 in - fun () -> incr n; id_of_string ("_" ^ (string_of_int !n)) + fun () -> incr n; Names.id_of_string ("_" ^ (string_of_int !n)) let add_anonymous_entry node = let id = anonymous_id () in @@ -207,7 +216,7 @@ let add_absolutely_named_leaf sp obj = add_entry sp (Leaf obj) let add_leaf id obj = - if fst (current_prefix ()) = initial_path then + if fst (current_prefix ()) = Names.initial_path then error ("No session module started (use -top dir)"); let oname = make_oname id in cache_object (oname,obj); @@ -261,7 +270,7 @@ let current_mod_id () = let start_module export id mp nametab = let dir = extend_dirpath (fst !path_prefix) id in - let prefix = dir,(mp,empty_dirpath) in + let prefix = dir,(mp,Names.empty_dirpath) in let oname = make_path id, make_kn id in if Nametab.exists_module dir then errorlabstrm "open_module" (pr_id id ++ str " already exists") ; @@ -306,7 +315,7 @@ let end_module id = let start_modtype id mp nametab = let dir = extend_dirpath (fst !path_prefix) id in - let prefix = dir,(mp,empty_dirpath) in + let prefix = dir,(mp,Names.empty_dirpath) in let sp = make_path id in let name = sp, make_kn id in if Nametab.exists_cci sp then @@ -363,9 +372,9 @@ let check_for_comp_unit () = let start_compilation s mp = if !comp_name <> None then error "compilation unit is already started"; - if snd (snd (!path_prefix)) <> empty_dirpath then + if snd (snd (!path_prefix)) <> Names.empty_dirpath then error "some sections are already opened"; - let prefix = s, (mp, empty_dirpath) in + let prefix = s, (mp, Names.empty_dirpath) in let _ = add_anonymous_entry (CompilingLibrary prefix) in comp_name := Some s; path_prefix := prefix @@ -395,8 +404,8 @@ let end_compilation dir = | None -> anomaly "There should be a module name..." | Some m -> if m <> dir then anomaly - ("The current open module has name "^ (string_of_dirpath m) ^ - " and not " ^ (string_of_dirpath m)); + ("The current open module has name "^ (Names.string_of_dirpath m) ^ + " and not " ^ (Names.string_of_dirpath m)); in let (after,_,before) = split_lib oname in comp_name := None; @@ -446,7 +455,7 @@ let sectab = ref ([] : ((Names.identifier * binding_kind * Term.types option) list * Cooking.work_list * abstr_list) list) let add_section () = - sectab := ([],(Cmap.empty,KNmap.empty),(Cmap.empty,KNmap.empty)) :: !sectab + sectab := ([],(Names.Cmap.empty,Names.KNmap.empty),(Names.Cmap.empty,Names.KNmap.empty)) :: !sectab let add_section_variable id impl keep = match !sectab with @@ -489,10 +498,10 @@ let replacement_context () = pi2 (List.hd !sectab) let variables_context () = pi1 (List.hd !sectab) let section_segment_of_constant con = - Cmap.find con (fst (pi3 (List.hd !sectab))) + Names.Cmap.find con (fst (pi3 (List.hd !sectab))) let section_segment_of_mutual_inductive kn = - KNmap.find kn (snd (pi3 (List.hd !sectab))) + Names.KNmap.find kn (snd (pi3 (List.hd !sectab))) let rec list_mem_assoc_in_triple x = function [] -> raise Not_found @@ -503,9 +512,9 @@ let section_instance = function if list_mem_assoc_in_triple id (pi1 (List.hd !sectab)) then [||] else raise Not_found | ConstRef con -> - Cmap.find con (fst (pi2 (List.hd !sectab))) + Names.Cmap.find con (fst (pi2 (List.hd !sectab))) | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - KNmap.find kn (snd (pi2 (List.hd !sectab))) + Names.KNmap.find kn (snd (pi2 (List.hd !sectab))) let is_in_section ref = try ignore (section_instance ref); true with Not_found -> false @@ -566,11 +575,11 @@ let close_section id = | oname,OpenedSection (_,fs) -> let id' = basename (fst oname) in if id <> id' then - errorlabstrm "close_section" (str "last opened section is " ++ pr_id id'); + errorlabstrm "close_section" (str "Last opened section is " ++ pr_id id' ++ str "."); (oname,fs) | _ -> assert false with Not_found -> - error "no opened section" + error "No opened section." in let (secdecls,secopening,before) = split_lib oname in lib_stk := before; @@ -730,7 +739,7 @@ let back n = reset_to (back_stk n !lib_stk) (* State and initialization. *) -type frozen = dir_path option * library_segment +type frozen = Names.dir_path option * library_segment let freeze () = (!comp_name, !lib_stk) @@ -774,16 +783,37 @@ let reset_initial () = let mp_of_global ref = match ref with | VarRef id -> fst (current_prefix ()) - | ConstRef cst -> con_modpath cst - | IndRef ind -> ind_modpath ind - | ConstructRef constr -> constr_modpath constr + | ConstRef cst -> Names.con_modpath cst + | IndRef ind -> Names.ind_modpath ind + | ConstructRef constr -> Names.constr_modpath constr let rec dp_of_mp modp = match modp with - | MPfile dp -> dp - | MPbound _ | MPself _ -> library_dp () - | MPdot (mp,_) -> dp_of_mp mp - + | Names.MPfile dp -> dp + | Names.MPbound _ | Names.MPself _ -> library_dp () + | Names.MPdot (mp,_) -> dp_of_mp mp + +let rec split_mp mp = + match mp with + | Names.MPfile dp -> dp, Names.empty_dirpath + | Names.MPdot (prfx, lbl) -> + let mprec, dprec = split_mp prfx in + mprec, Names.make_dirpath (Names.id_of_string (Names.string_of_label lbl) :: (Names.repr_dirpath dprec)) + | Names.MPself msid -> let (_, id, dp) = Names.repr_msid msid in library_dp(), Names.make_dirpath [Names.id_of_string id] + | Names.MPbound mbid -> let (_, id, dp) = Names.repr_mbid mbid in library_dp(), Names.make_dirpath [Names.id_of_string id] + +let split_modpath mp = + let rec aux = function + | Names.MPfile dp -> dp, [] + | Names.MPbound mbid -> + library_dp (), [Names.id_of_mbid mbid] + | Names.MPself msid -> library_dp (), [Names.id_of_msid msid] + | Names.MPdot (mp,l) -> let (mp', lab) = aux mp in + (mp', Names.id_of_label l :: lab) + in + let (mp, l) = aux mp in + mp, l + let library_part ref = match ref with | VarRef id -> library_dp () @@ -815,12 +845,12 @@ let pop_con con = Names.make_con mp (dirpath_prefix dir) l let con_defined_in_sec kn = - let _,dir,_ = repr_con kn in - dir <> empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ()) + let _,dir,_ = Names.repr_con kn in + dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ()) let defined_in_sec kn = - let _,dir,_ = repr_kn kn in - dir <> empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ()) + let _,dir,_ = Names.repr_kn kn in + dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ()) let discharge_global = function | ConstRef kn when con_defined_in_sec kn -> diff --git a/library/lib.mli b/library/lib.mli index d35fcc09..23af7c17 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -6,41 +6,34 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: lib.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: lib.mli 11671 2008-12-12 12:43:03Z herbelin $ i*) -(*i*) -open Util -open Names -open Libnames -open Libobject -open Summary -open Mod_subst -(*i*) (*s This module provides a general mechanism to keep a trace of all operations and to backtrack (undo) those operations. It provides also the section mechanism (at a low level; discharge is not known at this step). *) type node = - | Leaf of obj - | CompilingLibrary of object_prefix - | OpenedModule of bool option * object_prefix * Summary.frozen + | Leaf of Libobject.obj + | CompilingLibrary of Libnames.object_prefix + | OpenedModule of bool option * Libnames.object_prefix * Summary.frozen | ClosedModule of library_segment - | OpenedModtype of object_prefix * Summary.frozen + | OpenedModtype of Libnames.object_prefix * Summary.frozen | ClosedModtype of library_segment - | OpenedSection of object_prefix * Summary.frozen + | OpenedSection of Libnames.object_prefix * Summary.frozen | ClosedSection of library_segment | FrozenState of Summary.frozen -and library_segment = (object_name * node) list +and library_segment = (Libnames.object_name * node) list -type lib_objects = (identifier * obj) list +type lib_objects = (Names.identifier * Libobject.obj) list (*s Object iteratation functions. *) -val open_objects : int -> object_prefix -> lib_objects -> unit -val load_objects : int -> object_prefix -> lib_objects -> unit -val subst_objects : object_prefix -> substitution -> lib_objects -> lib_objects +val open_objects : int -> Libnames.object_prefix -> lib_objects -> unit +val load_objects : int -> Libnames.object_prefix -> lib_objects -> unit +val subst_objects : Libnames.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects +val load_and_subst_objects : int -> Libnames.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects (* [classify_segment seg] verifies that there are no OpenedThings, clears ClosedSections and FrozenStates and divides Leafs according @@ -48,23 +41,23 @@ val subst_objects : object_prefix -> substitution -> lib_objects -> lib_objects [Substitute], [Keep], [Anticipate] respectively. The order of each returned list is the same as in the input list. *) val classify_segment : - library_segment -> lib_objects * lib_objects * obj list + library_segment -> lib_objects * lib_objects * Libobject.obj list (* [segment_of_objects prefix objs] forms a list of Leafs *) val segment_of_objects : - object_prefix -> lib_objects -> library_segment + Libnames.object_prefix -> lib_objects -> library_segment (*s Adding operations (which call the [cache] method, and getting the current list of operations (most recent ones coming first). *) -val add_leaf : identifier -> obj -> object_name -val add_absolutely_named_leaf : object_name -> obj -> unit -val add_anonymous_leaf : obj -> unit +val add_leaf : Names.identifier -> Libobject.obj -> Libnames.object_name +val add_absolutely_named_leaf : Libnames.object_name -> Libobject.obj -> unit +val add_anonymous_leaf : Libobject.obj -> unit (* this operation adds all objects with the same name and calls [load_object] for each of them *) -val add_leaves : identifier -> obj list -> object_name +val add_leaves : Names.identifier -> Libobject.obj list -> Libnames.object_name val add_frozen_state : unit -> unit @@ -81,19 +74,20 @@ val reset_label : int -> unit starting from a given section path. If not given, the entire segment is returned. *) -val contents_after : object_name option -> library_segment +val contents_after : Libnames.object_name option -> library_segment (*s Functions relative to current path *) (* User-side names *) -val cwd : unit -> dir_path -val make_path : identifier -> section_path -val path_of_include : unit -> section_path +val cwd : unit -> Names.dir_path +val current_dirpath : bool -> Names.dir_path +val make_path : Names.identifier -> Libnames.section_path +val path_of_include : unit -> Libnames.section_path (* Kernel-side names *) -val current_prefix : unit -> module_path * dir_path -val make_kn : identifier -> kernel_name -val make_con : identifier -> constant +val current_prefix : unit -> Names.module_path * Names.dir_path +val make_kn : Names.identifier -> Names.kernel_name +val make_con : Names.identifier -> Names.constant (* Are we inside an opened section *) val sections_are_opened : unit -> bool @@ -102,53 +96,55 @@ val sections_depth : unit -> int (* Are we inside an opened module type *) val is_modtype : unit -> bool val is_module : unit -> bool -val current_mod_id : unit -> module_ident +val current_mod_id : unit -> Names.module_ident (* Returns the most recent OpenedThing node *) -val what_is_opened : unit -> object_name * node +val what_is_opened : unit -> Libnames.object_name * node (*s Modules and module types *) val start_module : - bool option -> module_ident -> module_path -> Summary.frozen -> object_prefix -val end_module : module_ident - -> object_name * object_prefix * Summary.frozen * library_segment + bool option -> Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix +val end_module : Names.module_ident + -> Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment val start_modtype : - module_ident -> module_path -> Summary.frozen -> object_prefix -val end_modtype : module_ident - -> object_name * object_prefix * Summary.frozen * library_segment + Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix +val end_modtype : Names.module_ident + -> Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment (* [Lib.add_frozen_state] must be called after each of the above functions *) (*s Compilation units *) -val start_compilation : dir_path -> module_path -> unit -val end_compilation : dir_path -> object_prefix * library_segment +val start_compilation : Names.dir_path -> Names.module_path -> unit +val end_compilation : Names.dir_path -> Libnames.object_prefix * library_segment (* The function [library_dp] returns the [dir_path] of the current compiling library (or [default_library]) *) -val library_dp : unit -> dir_path +val library_dp : unit -> Names.dir_path (* Extract the library part of a name even if in a section *) -val dp_of_mp : module_path -> dir_path -val library_part : global_reference -> dir_path -val remove_section_part : global_reference -> dir_path +val dp_of_mp : Names.module_path -> Names.dir_path +val split_mp : Names.module_path -> Names.dir_path * Names.dir_path +val split_modpath : Names.module_path -> Names.dir_path * Names.identifier list +val library_part : Libnames.global_reference -> Names.dir_path +val remove_section_part : Libnames.global_reference -> Names.dir_path (*s Sections *) -val open_section : identifier -> unit -val close_section : identifier -> unit +val open_section : Names.identifier -> unit +val close_section : Names.identifier -> unit (*s Backtracking (undo). *) -val reset_to : object_name -> unit -val reset_name : identifier located -> unit -val remove_name : identifier located -> unit -val reset_mod : identifier located -> unit -val reset_to_state : object_name -> unit +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 +val reset_to_state : Libnames.object_name -> unit -val has_top_frozen_state : unit -> object_name option +val has_top_frozen_state : unit -> Libnames.object_name option (* [back n] resets to the place corresponding to the $n$-th call of [mark_end_of_command] (counting backwards) *) @@ -168,8 +164,8 @@ val reset_initial : unit -> unit (* XML output hooks *) -val set_xml_open_section : (identifier -> unit) -> unit -val set_xml_close_section : (identifier -> unit) -> unit +val set_xml_open_section : (Names.identifier -> unit) -> unit +val set_xml_close_section : (Names.identifier -> unit) -> unit type binding_kind = Explicit | Implicit @@ -190,13 +186,13 @@ val add_section_variable : Names.identifier -> binding_kind -> Term.types option val add_section_constant : Names.constant -> Sign.named_context -> unit val add_section_kn : Names.kernel_name -> Sign.named_context -> unit val replacement_context : unit -> - (identifier array Cmap.t * identifier array KNmap.t) + (Names.identifier array Names.Cmap.t * Names.identifier array Names.KNmap.t) (*s Discharge: decrease the section level if in the current section *) -val discharge_kn : kernel_name -> kernel_name -val discharge_con : constant -> constant -val discharge_global : global_reference -> global_reference -val discharge_inductive : inductive -> inductive +val discharge_kn : Names.kernel_name -> Names.kernel_name +val discharge_con : Names.constant -> Names.constant +val discharge_global : Libnames.global_reference -> Libnames.global_reference +val discharge_inductive : Names.inductive -> Names.inductive diff --git a/library/libnames.ml b/library/libnames.ml index d0c6e8b9..3f226179 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: libnames.ml 11209 2008-07-05 10:17:49Z herbelin $ i*) +(*i $Id: libnames.ml 11750 2009-01-05 20:47:34Z herbelin $ i*) open Pp open Util @@ -24,6 +24,11 @@ type global_reference = let isVarRef = function VarRef _ -> true | _ -> false +let subst_constructor subst ((kn,i),j as ref) = + let kn' = subst_kn subst kn in + if kn==kn' then ref, mkConstruct ref + else ((kn',i),j), mkConstruct ((kn',i),j) + let subst_global subst ref = match ref with | VarRef var -> ref, mkVar var | ConstRef kn -> @@ -32,10 +37,9 @@ let subst_global subst ref = match ref with | IndRef (kn,i) -> let kn' = subst_kn subst kn in if kn==kn' then ref, mkInd (kn,i) else IndRef(kn',i), mkInd (kn',i) - | ConstructRef ((kn,i),j) -> - let kn' = subst_kn subst kn in - if kn==kn' then ref, mkConstruct ((kn,i),j) - else ConstructRef ((kn',i),j), mkConstruct ((kn',i),j) + | ConstructRef ((kn,i),j as c) -> + let c',t = subst_constructor subst c in + if c'==c then ref,t else ConstructRef c', t let global_of_constr c = match kind_of_term c with | Const sp -> ConstRef sp @@ -119,21 +123,21 @@ let path_of_inductive env (sp,tyi) = let parse_dir s = let len = String.length s in let rec decoupe_dirs dirs n = - if n>=len then dirs else + if n = len && n > 0 then error (s ^ " is an invalid path."); + if n >= len then dirs else let pos = try String.index_from s n '.' with Not_found -> len in + if pos = n then error (s ^ " is an invalid path."); let dir = String.sub s n (pos-n) in - decoupe_dirs ((id_of_string dir)::dirs) (pos+1) + decoupe_dirs ((id_of_string dir)::dirs) (pos+1) in decoupe_dirs [] 0 -let dirpath_of_string s = - match parse_dir s with - [] -> invalid_arg "dirpath_of_string" - | dir -> make_dirpath dir +let dirpath_of_string s = + make_dirpath (if s = "" then [] else parse_dir s) module Dirset = Set.Make(struct type t = dir_path let compare = compare end) module Dirmap = Map.Make(struct type t = dir_path let compare = compare end) diff --git a/library/libnames.mli b/library/libnames.mli index 76c406db..cc664a08 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: libnames.mli 11209 2008-07-05 10:17:49Z herbelin $ i*) +(*i $Id: libnames.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Pp @@ -25,6 +25,7 @@ type global_reference = val isVarRef : global_reference -> bool +val subst_constructor : substitution -> constructor -> constructor * constr val subst_global : substitution -> global_reference -> global_reference * constr (* Turn a global reference into a construction *) diff --git a/library/libobject.ml b/library/libobject.ml index 6b302447..b455e2b3 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: libobject.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: libobject.ml 11739 2009-01-02 19:33:19Z herbelin $ *) open Util open Names @@ -148,8 +148,9 @@ let apply_dyn_fun deflt f lobj = if !relax_flag then failwith "local to_apply_dyn_fun" else - anomaly - ("Cannot find library functions for an object with tag "^tag) in + error + ("Cannot find library functions for an object with tag "^tag^ + " (maybe a plugin is missing)") in f dodecl with Failure "local to_apply_dyn_fun" -> deflt;; diff --git a/library/library.ml b/library/library.ml index 73928a9b..9f3478f0 100644 --- a/library/library.ml +++ b/library/library.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: library.ml 11313 2008-08-07 11:15:03Z barras $ *) +(* $Id: library.ml 11801 2009-01-18 20:11:41Z herbelin $ *) open Pp open Util @@ -18,7 +18,6 @@ open Safe_typing open Libobject open Lib open Nametab -open Declaremods (*************************************************************************) (*s Load path. Mapping from physical to logical paths etc.*) @@ -29,43 +28,15 @@ let load_paths = ref ([] : (System.physical_path * logical_path * bool) list) let get_load_paths () = List.map pi1 !load_paths -(* Hints to partially detects if two paths refer to the same repertory *) -let rec remove_path_dot p = - let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) - let n = String.length curdir in - if String.length p > n && String.sub p 0 n = curdir then - remove_path_dot (String.sub p n (String.length p - n)) - else - p - -let strip_path p = - let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *) - let n = String.length cwd in - if String.length p > n && String.sub p 0 n = cwd then - remove_path_dot (String.sub p n (String.length p - n)) - else - remove_path_dot p - -let canonical_path_name p = - let current = Sys.getcwd () in - try - Sys.chdir p; - let p' = Sys.getcwd () in - Sys.chdir current; - p' - with Sys_error _ -> - (* We give up to find a canonical name and just simplify it... *) - strip_path p - let find_logical_path phys_dir = - let phys_dir = canonical_path_name phys_dir in + let phys_dir = System.canonical_path_name phys_dir in match List.filter (fun (p,d,_) -> p = phys_dir) !load_paths with | [_,dir,_] -> dir | [] -> Nameops.default_root_prefix | l -> anomaly ("Two logical paths are associated to "^phys_dir) let is_in_load_paths phys_dir = - let dir = canonical_path_name phys_dir in + let dir = System.canonical_path_name phys_dir in let lp = get_load_paths () in let check_p = fun p -> (String.compare dir p) == 0 in List.exists check_p lp @@ -74,13 +45,13 @@ let remove_load_path dir = load_paths := List.filter (fun (p,d,_) -> p <> dir) !load_paths let add_load_path isroot (phys_path,coq_path) = - let phys_path = canonical_path_name phys_path in + let phys_path = System.canonical_path_name phys_path in match List.filter (fun (p,d,_) -> p = phys_path) !load_paths with | [_,dir,_] -> if coq_path <> dir (* If this is not the default -I . to coqtop *) && not - (phys_path = canonical_path_name Filename.current_dir_name + (phys_path = System.canonical_path_name Filename.current_dir_name && coq_path = Nameops.default_root_prefix) then begin @@ -149,7 +120,7 @@ type compilation_unit_name = dir_path type library_disk = { md_name : compilation_unit_name; md_compiled : compiled_library; - md_objects : library_objects; + md_objects : Declaremods.library_objects; md_deps : (compilation_unit_name * Digest.t) list; md_imports : compilation_unit_name list } @@ -159,7 +130,7 @@ type library_disk = { type library_t = { library_name : compilation_unit_name; library_compiled : compiled_library; - library_objects : library_objects; + library_objects : Declaremods.library_objects; library_deps : (compilation_unit_name * Digest.t) list; library_imports : compilation_unit_name list; library_digest : Digest.t } @@ -324,14 +295,14 @@ let open_libraries export modl = (**********************************************************************) (* import and export - synchronous operations*) -let cache_import (_,(dir,export)) = - open_libraries export [try_find_library dir] - -let open_import i (_,(dir,_) as obj) = +let open_import i (_,(dir,export)) = if i=1 then (* even if the library is already imported, we re-import it *) (* if not (library_is_opened dir) then *) - cache_import obj + open_libraries export [try_find_library dir] + +let cache_import obj = + open_import 1 obj let subst_import (_,_,o) = o @@ -379,7 +350,7 @@ let locate_absolute_library dir = if loadpath = [] then raise LibUnmappedDir; try let name = (string_of_id base)^".vo" in - let _, file = System.where_in_path false loadpath name in + let _, file = System.where_in_path ~warn:false loadpath name in (dir, file) with Not_found -> (* Last chance, removed from the file system but still in memory *) @@ -395,7 +366,7 @@ let locate_qualified_library warn qid = let loadpath = loadpaths_matching_dir_path dir in if loadpath = [] then raise LibUnmappedDir; let name = string_of_id base ^ ".vo" in - let lpath, file = System.where_in_path warn (List.map fst loadpath) name in + let lpath, file = System.where_in_path ~warn (List.map fst loadpath) name in let dir = extend_dirpath (List.assoc lpath loadpath) base in (* Look if loaded *) if library_is_loaded dir then (LibLoaded, dir, library_full_filename dir) @@ -506,12 +477,14 @@ let rec_intern_by_filename_only id f = let rec_intern_library_from_file idopt f = (* A name is specified, we have to check it contains library id *) - let _, f = System.find_file_in_path (get_load_paths ()) (f^".vo") in + let paths = get_load_paths () in + let _, f = + System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".vo") in rec_intern_by_filename_only idopt f (**********************************************************************) -(*s [require_library] loads and opens a library. This is a synchronized - operation. It is performed as follows: +(*s [require_library] loads and possibly opens a library. This is a + synchronized operation. It is performed as follows: preparation phase: (functions require_library* ) the library and its dependencies are read from to disk (using intern_* ) @@ -524,10 +497,6 @@ let rec_intern_library_from_file idopt f = the library is loaded in the environment and Nametab, the objects are registered etc, using functions from Declaremods (via load_library, which recursively loads its dependencies) - - - The [read_library] operation is very similar, but does not "open" - the library *) type library_reference = dir_path list * bool option @@ -540,14 +509,21 @@ let register_library (dir,m) = m.library_digest; register_loaded_library m - (* [needed] is the ordered list of libraries not already loaded *) -let cache_require (_,(needed,modl,export)) = - List.iter register_library needed; +(* Follow the semantics of Anticipate object: + - called at module or module type closing when a Require occurs in + the module or module type + - not called from a library (i.e. a module identified with a file) *) +let load_require _ (_,(needed,modl,_)) = + List.iter register_library needed + +let open_require i (_,(_,modl,export)) = Option.iter (fun exp -> open_libraries exp (List.map find_library modl)) export -let load_require _ (_,(needed,modl,_)) = - List.iter register_library needed + (* [needed] is the ordered list of libraries not already loaded *) +let cache_require o = + load_require 1 o; + open_require 1 o (* keeps the require marker for closed section replay but removes OS dependent fields from .vo files for cross-platform compatibility *) @@ -555,10 +531,13 @@ let export_require (_,l,e) = Some ([],l,e) let discharge_require (_,o) = Some o +(* open_function is never called from here because an Anticipate object *) + let (in_require, out_require) = declare_object {(default_object "REQUIRE") with cache_function = cache_require; load_function = load_require; + open_function = (fun _ _ -> assert false); export_function = export_require; discharge_function = discharge_require; classify_function = (fun (_,o) -> Anticipate o) } @@ -566,8 +545,6 @@ let (in_require, out_require) = (* Require libraries, import them if [export <> None], mark them for export if [export = Some true] *) -(* read = require without opening *) - let xml_require = ref (fun d -> ()) let set_xml_require f = xml_require := f @@ -575,19 +552,16 @@ let require_library qidl export = let modrefl = List.map try_locate_qualified_library qidl in let needed = List.rev (List.fold_left rec_intern_library [] modrefl) in let modrefl = List.map fst modrefl in - if Lib.is_modtype () || Lib.is_module () then begin - add_anonymous_leaf (in_require (needed,modrefl,None)); - Option.iter (fun exp -> - List.iter (fun dir -> add_anonymous_leaf (in_import(dir,exp))) modrefl) - export - end + if Lib.is_modtype () || Lib.is_module () then + begin + add_anonymous_leaf (in_require (needed,modrefl,None)); + Option.iter (fun exp -> + List.iter (fun dir -> add_anonymous_leaf (in_import(dir,exp))) modrefl) + export + end else add_anonymous_leaf (in_require (needed,modrefl,export)); - if !Flags.dump then List.iter2 (fun (loc, _) dp -> - Flags.dump_string (Printf.sprintf "R%d %s <> <> %s\n" - (fst (unloc loc)) (string_of_dirpath dp) "lib")) - qidl modrefl; - if !Flags.xml_export then List.iter !xml_require modrefl; + if !Flags.xml_export then List.iter !xml_require modrefl; add_frozen_state () let require_library_from_file idopt file export = @@ -608,25 +582,33 @@ let require_library_from_file idopt file export = let import_module export (loc,qid) = try match Nametab.locate_module qid with - MPfile dir -> + | MPfile dir -> if Lib.is_modtype () || Lib.is_module () || not export then add_anonymous_leaf (in_import (dir, export)) else - add_anonymous_leaf (in_require ([],[dir], Some export)) + add_anonymous_leaf (in_import (dir, export)) | mp -> - import_module export mp + Declaremods.import_module export mp with Not_found -> user_err_loc - (loc,"import_library", - str ((string_of_qualid qid)^" is not a module")) + (loc,"import_library", + str ((string_of_qualid qid)^" is not a module")) (************************************************************************) (*s Initializing the compilation of a library. *) +let check_coq_overwriting p = + let l = repr_dirpath p in + if not !Flags.boot && l <> [] && string_of_id (list_last l) = "Coq" then + errorlabstrm "" (strbrk ("Name "^string_of_dirpath p^" starts with prefix \"Coq\" which is reserved for the Coq library.")) + let start_library f = - let _,longf = System.find_file_in_path (get_load_paths ()) (f^".v") in + let paths = get_load_paths () in + let _,longf = + System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in let ldir0 = find_logical_path (Filename.dirname longf) in + check_coq_overwriting ldir0; let id = id_of_string (Filename.basename f) in let ldir = extend_dirpath ldir0 id in Declaremods.start_library ldir; diff --git a/library/library.mli b/library/library.mli index a66a77bc..d61dc4b9 100644 --- a/library/library.mli +++ b/library/library.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: library.mli 11209 2008-07-05 10:17:49Z herbelin $ i*) +(*i $Id: library.mli 11750 2009-01-05 20:47:34Z herbelin $ i*) (*i*) open Util @@ -76,6 +76,10 @@ type library_location = LibLoaded | LibInPath val locate_qualified_library : bool -> qualid -> library_location * dir_path * System.physical_path +val try_locate_qualified_library : qualid located -> dir_path * string + +(* Reserve Coq prefix for the standard library *) +val check_coq_overwriting : dir_path -> unit (*s Statistics: display the memory use of a library. *) val mem : dir_path -> Pp.std_ppcmds diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 index 57e88133..bd6be424 100644 --- a/parsing/argextend.ml4 +++ b/parsing/argextend.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) -(* $Id: argextend.ml4 10122 2007-09-15 10:35:59Z letouzey $ *) +(* $Id: argextend.ml4 11622 2008-11-23 08:45:56Z herbelin $ *) open Genarg open Q_util @@ -25,7 +25,7 @@ let rec make_rawwit loc = function | StringArgType -> <:expr< Genarg.rawwit_string >> | PreIdentArgType -> <:expr< Genarg.rawwit_pre_ident >> | IntroPatternArgType -> <:expr< Genarg.rawwit_intro_pattern >> - | IdentArgType -> <:expr< Genarg.rawwit_ident >> + | IdentArgType b -> <:expr< Genarg.rawwit_ident_gen $mlexpr_of_bool b$ >> | VarArgType -> <:expr< Genarg.rawwit_var >> | RefArgType -> <:expr< Genarg.rawwit_ref >> | SortArgType -> <:expr< Genarg.rawwit_sort >> @@ -50,7 +50,7 @@ let rec make_globwit loc = function | StringArgType -> <:expr< Genarg.globwit_string >> | PreIdentArgType -> <:expr< Genarg.globwit_pre_ident >> | IntroPatternArgType -> <:expr< Genarg.globwit_intro_pattern >> - | IdentArgType -> <:expr< Genarg.globwit_ident >> + | IdentArgType b -> <:expr< Genarg.globwit_ident_gen $mlexpr_of_bool b$ >> | VarArgType -> <:expr< Genarg.globwit_var >> | RefArgType -> <:expr< Genarg.globwit_ref >> | QuantHypArgType -> <:expr< Genarg.globwit_quant_hyp >> @@ -75,7 +75,7 @@ let rec make_wit loc = function | StringArgType -> <:expr< Genarg.wit_string >> | PreIdentArgType -> <:expr< Genarg.wit_pre_ident >> | IntroPatternArgType -> <:expr< Genarg.wit_intro_pattern >> - | IdentArgType -> <:expr< Genarg.wit_ident >> + | IdentArgType b -> <:expr< Genarg.wit_ident_gen $mlexpr_of_bool b$ >> | VarArgType -> <:expr< Genarg.wit_var >> | RefArgType -> <:expr< Genarg.wit_ref >> | QuantHypArgType -> <:expr< Genarg.wit_quant_hyp >> @@ -163,16 +163,27 @@ let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl = end >> -let declare_vernac_argument loc s cl = +let declare_vernac_argument loc s pr cl = let se = mlexpr_of_string s in + let wit = <:expr< $lid:"wit_"^s$ >> in 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 pr_rules = match pr with + | None -> <:expr< fun _ _ _ _ -> str $str:"[No printer for "^s^"]"$ >> + | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in <:str_item< declare - value $lid:"rawwit_"^s$ = let (_,_,x) = Genarg.create_arg $se$ in x; + 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$; value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$; Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None [(None, None, $rules$)]; + Pptactic.declare_extra_genarg_pprule + ($rawwit$, $pr_rules$) + ($globwit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not globwit printer") + ($wit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not wit printer"); end >> @@ -202,11 +213,12 @@ EXTEND failwith "Argument entry names must be lowercase"; declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr l | "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; + pr = OPT ["PRINTED"; "BY"; pr = LIDENT -> pr]; OPT "|"; l = LIST1 argrule SEP "|"; "END" -> if String.capitalize s = s then failwith "Argument entry names must be lowercase"; - declare_vernac_argument loc s l ] ] + declare_vernac_argument loc s pr l ] ] ; argtype: [ "2" diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index 825d1af0..43836dbb 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: egrammar.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: egrammar.ml 11512 2008-10-27 12:28:36Z herbelin $ *) open Pp open Util @@ -52,58 +52,56 @@ type prod_item = | NonTerm of constr_production_entry * (Names.identifier * constr_production_entry) option -type 'a action_env = (identifier * 'a) list +type 'a action_env = 'a list * 'a list list let make_constr_action (f : loc -> constr_expr action_env -> constr_expr) pil = - let rec make (env : constr_expr action_env) = function + let rec make (env,envlist as fullenv : constr_expr action_env) = function | [] -> - Gramext.action (fun loc -> f loc env) + Gramext.action (fun loc -> f loc fullenv) | None :: tl -> (* parse a non-binding item *) - Gramext.action (fun _ -> make env tl) + Gramext.action (fun _ -> make fullenv tl) | Some (p, (ETConstr _| ETOther _)) :: tl -> (* constr non-terminal *) - Gramext.action (fun (v:constr_expr) -> make ((p,v) :: env) tl) + Gramext.action (fun (v:constr_expr) -> make (v :: env, envlist) tl) | Some (p, ETReference) :: tl -> (* non-terminal *) - Gramext.action (fun (v:reference) -> make ((p,CRef v) :: env) tl) + Gramext.action (fun (v:reference) -> make (CRef v :: env, envlist) tl) | Some (p, ETIdent) :: tl -> (* non-terminal *) Gramext.action (fun (v:identifier) -> - make ((p,CRef (Ident (dummy_loc,v))) :: env) tl) + make (CRef (Ident (dummy_loc,v)) :: env, envlist) tl) | Some (p, ETBigint) :: tl -> (* non-terminal *) Gramext.action (fun (v:Bigint.bigint) -> - make ((p,CPrim (dummy_loc,Numeral v)) :: env) tl) + make (CPrim (dummy_loc,Numeral v) :: env, envlist) tl) | Some (p, ETConstrList _) :: tl -> - Gramext.action (fun (v:constr_expr list) -> - let dummyid = Ident (dummy_loc,id_of_string "_") in - make ((p,CAppExpl (dummy_loc,(None,dummyid),v)) :: env) tl) + Gramext.action (fun (v:constr_expr list) -> make (env, v::envlist) tl) | Some (p, ETPattern) :: tl -> failwith "Unexpected entry of type cases pattern" in - make [] (List.rev pil) + make ([],[]) (List.rev pil) let make_cases_pattern_action (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil = - let rec make (env : cases_pattern_expr action_env) = function + let rec make (env,envlist as fullenv : cases_pattern_expr action_env) = function | [] -> - Gramext.action (fun loc -> f loc env) + Gramext.action (fun loc -> f loc fullenv) | None :: tl -> (* parse a non-binding item *) - Gramext.action (fun _ -> make env tl) + Gramext.action (fun _ -> make fullenv tl) | Some (p, ETConstr _) :: tl -> (* pattern non-terminal *) - Gramext.action (fun (v:cases_pattern_expr) -> make ((p,v) :: env) tl) + Gramext.action (fun (v:cases_pattern_expr) -> make (v::env,envlist) tl) | Some (p, ETReference) :: tl -> (* non-terminal *) Gramext.action (fun (v:reference) -> - make ((p,CPatAtom (dummy_loc,Some v)) :: env) tl) + make (CPatAtom (dummy_loc,Some v) :: env, envlist) tl) | Some (p, ETIdent) :: tl -> (* non-terminal *) Gramext.action (fun (v:identifier) -> - make ((p,CPatAtom (dummy_loc,Some (Ident (dummy_loc,v)))) :: env) tl) + make + (CPatAtom (dummy_loc,Some (Ident (dummy_loc,v)))::env, envlist) tl) | Some (p, ETBigint) :: tl -> (* non-terminal *) Gramext.action (fun (v:Bigint.bigint) -> - make ((p,CPatPrim (dummy_loc,Numeral v)) :: env) tl) + make (CPatPrim (dummy_loc,Numeral v) :: env, envlist) tl) | Some (p, ETConstrList _) :: tl -> Gramext.action (fun (v:cases_pattern_expr list) -> - let dummyid = Ident (dummy_loc,id_of_string "_") in - make ((p,CPatCstr (dummy_loc,dummyid,v)) :: env) tl) + make (env, v :: envlist) tl) | Some (p, (ETPattern | ETOther _)) :: tl -> failwith "Unexpected entry of type cases pattern or other" in - make [] (List.rev pil) + make ([],[]) (List.rev pil) let make_constr_prod_item univ assoc from forpat = function | Term tok -> (Gramext.Stoken tok, None) @@ -133,11 +131,11 @@ let extend_constr (entry,level) (n,assoc) mkact forpat pt = let extend_constr_notation (n,assoc,ntn,rule) = (* Add the notation in constr *) - let mkact loc env = CNotation (loc,ntn,List.map snd env) in + let mkact loc env = CNotation (loc,ntn,env) in let e = get_constr_entry false (ETConstr (n,())) in extend_constr e (ETConstr(n,()),assoc) (make_constr_action mkact) false rule; (* Add the notation in cases_pattern *) - let mkact loc env = CPatNotation (loc,ntn,List.map snd env) in + let mkact loc env = CPatNotation (loc,ntn,env) in let e = get_constr_entry true (ETConstr (n,())) in extend_constr e (ETConstr (n,()),assoc) (make_cases_pattern_action mkact) true rule diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index b93fdadd..cdce13e6 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo" i*) -(* $Id: g_constr.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: g_constr.ml4 11709 2008-12-20 11:42:15Z msozeau $ *) open Pcoq open Constr @@ -24,7 +24,8 @@ open Util let constr_kw = [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; "end"; "as"; "let"; "if"; "then"; "else"; "return"; - "Prop"; "Set"; "Type"; ".("; "_"; ".." ] + "Prop"; "Set"; "Type"; ".("; "_"; ".."; + "`{"; "`("; "{|"; "|}" ] let _ = List.iter (fun s -> Lexer.add_token("",s)) constr_kw @@ -41,6 +42,11 @@ let loc_of_binder_let = function | LocalRawDef ((loc,_),_)::_ -> loc | _ -> dummy_loc +let binders_of_lidents l = + List.map (fun (loc, id) -> + LocalRawAssum ([loc, Name id], Default Rawterm.Explicit, + CHole (loc, Some (Evd.BinderType (Name id))))) l + let rec index_and_rec_order_of_annot loc bl ann = match names_of_local_assums bl,ann with | [loc,Name id], (None, r) -> Some (loc, id), r @@ -124,12 +130,24 @@ let ident_colon = | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) +let ident_with = + Gram.Entry.of_parser "ident_with" + (fun strm -> + match Stream.npeek 1 strm with + | [("IDENT",s)] -> + (match Stream.npeek 2 strm with + | [_; ("", "with")] -> + Stream.junk strm; Stream.junk strm; + Names.id_of_string s + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + let aliasvar = function CPatAlias (_, _, id) -> Some (Name id) | _ -> None GEXTEND Gram GLOBAL: binder_constr lconstr constr operconstr sort global constr_pattern lconstr_pattern Constr.ident - binder binder_let binders_let + binder binder_let binders_let record_declaration binders_let_fixannot typeclass_constraint pattern appl_arg; Constr.ident: [ [ id = Prim.ident -> id @@ -202,8 +220,14 @@ GEXTEND Gram | "("; c = operconstr LEVEL "200"; ")" -> (match c with CPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> - CNotation(loc,"( _ )",[c]) - | _ -> c) ] ] + CNotation(loc,"( _ )",([c],[])) + | _ -> c) + | "{|"; c = record_declaration; "|}" -> c + | "`{"; c = operconstr LEVEL "200"; "}" -> + CGeneralization (loc, Implicit, None, c) + | "`("; c = operconstr LEVEL "200"; ")" -> + CGeneralization (loc, Explicit, None, c) + ] ] ; forall: [ [ "forall" -> () @@ -215,6 +239,16 @@ GEXTEND Gram | IDENT "λ" -> () ] ] ; + record_declaration: + [ [ fs = LIST1 record_field_declaration SEP ";" -> CRecord (loc, None, fs) +(* | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *) +(* CRecord (loc, Some c, fs) *) + ] ] + ; + record_field_declaration: + [ [ id = identref; params = LIST0 identref; ":="; c = lconstr -> + (id, Topconstr.abstract_constr_expr c (binders_of_lidents params)) ] ] + ; binder_constr: [ [ forall; bl = binder_list; ","; c = operconstr LEVEL "200" -> mkCProdN loc bl c @@ -337,7 +371,7 @@ GEXTEND Gram | "("; p = pattern LEVEL "200"; ")" -> (match p with CPatPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> - CPatNotation(loc,"( _ )",[p]) + CPatNotation(loc,"( _ )",([p],[])) | _ -> p) | n = INT -> CPatPrim (loc, Numeral (Bigint.of_string n)) | s = string -> CPatPrim (loc, String s) ] ] @@ -398,12 +432,10 @@ GEXTEND Gram [LocalRawAssum ([id],Default Implicit,c)] | "{"; id=name; idl=LIST1 name; "}" -> List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (loc, None))) (id::idl) - | "("; "("; tc = LIST1 typeclass_constraint SEP "," ; ")"; ")" -> - List.map (fun (n, b, t) -> LocalRawAssum ([n], TypeClass (Explicit, b), t)) tc - | "{"; "{"; tc = LIST1 typeclass_constraint SEP "," ; "}"; "}" -> - List.map (fun (n, b, t) -> LocalRawAssum ([n], TypeClass (Implicit, b), t)) tc - | "["; tc = LIST1 typeclass_constraint SEP ","; "]" -> - List.map (fun (n, b, t) -> LocalRawAssum ([n], TypeClass (Implicit, b), t)) tc + | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" -> + List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Explicit, b), t)) tc + | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" -> + List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Implicit, b), t)) tc ] ] ; binder: @@ -413,13 +445,13 @@ GEXTEND Gram ] ] ; typeclass_constraint: - [ [ "!" ; c = operconstr LEVEL "200" -> (loc, Anonymous), Explicit, c - | "{"; id = name; "}"; ":" ; expl = [ "!" -> Explicit | -> Implicit ] ; c = operconstr LEVEL "200" -> + [ [ "!" ; c = operconstr LEVEL "200" -> (loc, Anonymous), true, c + | "{"; id = name; "}"; ":" ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" -> id, expl, c - | iid=ident_colon ; expl = [ "!" -> Explicit | -> Implicit ] ; c = operconstr LEVEL "200" -> + | iid=ident_colon ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" -> (loc, Name iid), expl, c | c = operconstr LEVEL "200" -> - (loc, Anonymous), Implicit, c + (loc, Anonymous), false, c ] ] ; diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index dbd81e7f..316bf8e1 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo" i*) -(* $Id: g_ltac.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: g_ltac.ml4 11576 2008-11-10 19:13:15Z msozeau $ *) open Pp open Util @@ -165,11 +165,24 @@ GEXTEND Gram match_pattern: [ [ IDENT "context"; oid = OPT Constr.ident; "["; pc = Constr.lconstr_pattern; "]" -> - Subterm (oid, pc) + Subterm (false,oid, pc) + | IDENT "appcontext"; oid = OPT Constr.ident; + "["; pc = Constr.lconstr_pattern; "]" -> + Subterm (true,oid, pc) | pc = Constr.lconstr_pattern -> Term pc ] ] ; match_hyps: - [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) ] ] + [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) + | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) + | na = name; ":="; mpv = match_pattern -> + let t, ty = + match mpv with + | Term t -> (match t with + | CCast (loc, t, CastConv (_, ty)) -> Term t, Some (Term ty) + | _ -> mpv, None) + | _ -> mpv, None + in Def (na, t, Option.default (Term (CHole (dummy_loc, None))) ty) + ] ] ; match_context_rule: [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 1e738384..76225d77 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo" i*) -(*i $Id: g_prim.ml4 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: g_prim.ml4 11525 2008-10-30 22:18:54Z amahboub $ i*) open Pcoq open Names @@ -45,7 +45,7 @@ GEXTEND Gram [ [ s = IDENT -> id_of_string s ] ] ; pattern_ident: - [ [ s = PATTERNIDENT -> id_of_string s ] ] + [ [ LEFTQMARK; id = ident -> id ] ] ; pattern_identref: [ [ id = pattern_ident -> (loc, id) ] ] diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 05878e97..655bb267 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo" i*) -(* $Id: g_proofs.ml4 10628 2008-03-06 14:56:08Z msozeau $ *) +(* $Id: g_proofs.ml4 11784 2009-01-14 11:36:32Z herbelin $ *) open Pcoq @@ -90,9 +90,12 @@ GEXTEND Gram | IDENT "Go"; IDENT "next" -> VernacGo GoNext | IDENT "Guarded" -> VernacCheckGuard (* Hints for Auto and EAuto *) - | IDENT "Hint"; local = locality; h = hint; + | IDENT "Create"; IDENT "HintDb" ; + id = IDENT ; b = [ "discriminated" -> true | -> false ] -> + VernacCreateHintDb (use_locality (), id, b) + | IDENT "Hint"; local = obsolete_locality; h = hint; dbnames = opt_hintbases -> - VernacHints (local,dbnames, h) + VernacHints (enforce_locality_of local,dbnames, h) (*This entry is not commented, only for debug*) @@ -101,16 +104,18 @@ GEXTEND Gram [Genarg.in_gen Genarg.rawwit_constr c]) ] ]; - locality: + obsolete_locality: [ [ IDENT "Local" -> true | -> false ] ] ; hint: [ [ IDENT "Resolve"; lc = LIST1 constr; n = OPT [ n = natural -> n ] -> - HintsResolve (List.map (fun x -> (n, x)) lc) + HintsResolve (List.map (fun x -> (n, true, x)) lc) | IDENT "Immediate"; lc = LIST1 constr -> HintsImmediate lc + | IDENT "Transparent"; lc = LIST1 global -> HintsTransparency (lc, true) + | IDENT "Opaque"; lc = LIST1 global -> HintsTransparency (lc, false) | IDENT "Unfold"; lqid = LIST1 global -> HintsUnfold lqid | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc - | IDENT "Extern"; n = natural; c = constr_pattern ; "=>"; + | IDENT "Extern"; n = natural; c = OPT constr_pattern ; "=>"; tac = tactic -> HintsExtern (n,c,tac) | IDENT "Destruct"; diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 49f00d40..7bebf6db 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo" i*) -(* $Id: g_tactic.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: g_tactic.ml4 11741 2009-01-03 14:34:39Z herbelin $ *) open Pp open Pcoq @@ -18,6 +18,7 @@ open Rawterm open Genarg open Topconstr open Libnames +open Termops let all_with delta = make_red_flag [FBeta;FIota;FZeta;delta] @@ -215,7 +216,8 @@ GEXTEND Gram ; smart_global: [ [ c = global -> AN c - | s = ne_string -> ByNotation (loc,s) ] ] + | s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> + ByNotation (loc,s,sc) ] ] ; occs_nums: [ [ nl = LIST1 nat_or_var -> no_occurrences_expr_but nl @@ -255,6 +257,11 @@ GEXTEND Gram | "?" -> loc, IntroAnonymous | id = ident -> loc, IntroIdentifier id ] ] ; + intropattern_modifier: + [ [ IDENT "_eqn"; + id = [ ":"; id = naming_intropattern -> id | -> loc, IntroAnonymous ] + -> id ] ] + ; simple_intropattern: [ [ pat = disjunctive_intropattern -> pat | pat = naming_intropattern -> pat @@ -362,10 +369,14 @@ GEXTEND Gram [ [ "*"; occs = occs -> occs | -> no_occurrences_expr ] ] ; - simple_clause: + in_hyp_list: [ [ "in"; idl = LIST1 id_or_meta -> idl | -> [] ] ] ; + in_hyp_as: + [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) + | -> None ] ] + ; orient: [ [ "->" -> true | "<-" -> false @@ -404,18 +415,17 @@ GEXTEND Gram eliminator: [ [ "using"; el = constr_with_bindings -> el ] ] ; - with_names: - [ [ "as"; ipat = simple_intropattern -> ipat - | -> dummy_loc,IntroAnonymous ] ] + as_ipat: + [ [ "as"; ipat = simple_intropattern -> Some ipat + | -> None ] ] ; with_inversion_names: - [ [ "as"; ipat = disjunctive_intropattern -> Some ipat + [ [ "as"; ipat = simple_intropattern -> Some ipat | -> None ] ] ; with_induction_names: - [ [ "as"; eq = OPT naming_intropattern; ipat = disjunctive_intropattern + [ [ "as"; ipat = simple_intropattern; eq = OPT intropattern_modifier -> (eq,Some ipat) - | "as"; eq = naming_intropattern -> (Some eq,None) | -> (None,None) ] ] ; as_name: @@ -433,19 +443,10 @@ GEXTEND Gram [ [ id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> (id1,id2) ] ] ; rewriter : - [ [ - (* hack for allowing "rewrite ?t" and "rewrite NN?t" that normally - produce a pattern_ident *) - c = pattern_ident -> - let c = (CRef (Ident (loc,c)), NoBindings) in - (RepeatStar, c) - | n = natural; c = pattern_ident -> - let c = (CRef (Ident (loc,c)), NoBindings) in - (UpTo n, c) - | "!"; c = constr_with_bindings -> (RepeatPlus,c) - | "?"; c = constr_with_bindings -> (RepeatStar,c) + [ [ "!"; c = constr_with_bindings -> (RepeatPlus,c) + | ["?"| LEFTQMARK]; c = constr_with_bindings -> (RepeatStar,c) | n = natural; "!"; c = constr_with_bindings -> (Precisely n,c) - | n = natural; "?"; c = constr_with_bindings -> (UpTo n,c) + | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings -> (UpTo n,c) | n = natural; c = constr_with_bindings -> (Precisely n,c) | c = constr_with_bindings -> (Precisely 1, c) ] ] @@ -480,13 +481,14 @@ GEXTEND Gram | IDENT "exact_no_check"; c = constr -> TacExactNoCheck c | IDENT "vm_cast_no_check"; c = constr -> TacVmCastNoCheck c - | IDENT "apply"; cl = LIST1 constr_with_bindings SEP "," -> - TacApply (true,false,cl) - | IDENT "eapply"; cl = LIST1 constr_with_bindings SEP "," -> - TacApply (true,true,cl) - | IDENT "simple"; IDENT "apply"; cl = LIST1 constr_with_bindings SEP "," - -> TacApply (false,false,cl) - | IDENT "simple"; IDENT "eapply"; cl = LIST1 constr_with_bindings SEP "," -> TacApply (false,true,cl) + | IDENT "apply"; cl = LIST1 constr_with_bindings SEP ","; + inhyp = in_hyp_as -> TacApply (true,false,cl,inhyp) + | IDENT "eapply"; cl = LIST1 constr_with_bindings SEP ","; + inhyp = in_hyp_as -> TacApply (true,true,cl,inhyp) + | IDENT "simple"; IDENT "apply"; cl = LIST1 constr_with_bindings SEP ","; + inhyp = in_hyp_as -> TacApply (false,false,cl,inhyp) + | IDENT "simple"; IDENT "eapply"; cl = LIST1 constr_with_bindings SEP","; + inhyp = in_hyp_as -> TacApply (false,true,cl,inhyp) | IDENT "elim"; cl = constr_with_bindings; el = OPT eliminator -> TacElim (false,cl,el) | IDENT "eelim"; cl = constr_with_bindings; el = OPT eliminator -> @@ -518,15 +520,15 @@ GEXTEND Gram (* Begin compatibility *) | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; c = lconstr; ")" -> - TacAssert (None,(loc,IntroIdentifier id),c) + TacAssert (None,Some (loc,IntroIdentifier id),c) | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; c = lconstr; ")"; tac=by_tactic -> - TacAssert (Some tac,(loc,IntroIdentifier id),c) + TacAssert (Some tac,Some (loc,IntroIdentifier id),c) (* End compatibility *) - | IDENT "assert"; c = constr; ipat = with_names; tac = by_tactic -> + | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> TacAssert (Some tac,ipat,c) - | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = with_names -> + | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> TacAssert (None,ipat,c) | IDENT "cut"; c = constr -> TacCut c @@ -587,8 +589,8 @@ GEXTEND Gram | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacClear (true, l) | IDENT "clear"; l = LIST0 id_or_meta -> TacClear (l=[], l) | IDENT "clearbody"; l = LIST1 id_or_meta -> TacClearBody l - | IDENT "move"; dep = [IDENT "dependent" -> true | -> false]; - hfrom = id_or_meta; hto = move_location -> TacMove (dep,hfrom,hto) + | IDENT "move"; hfrom = id_or_meta; hto = move_location -> + TacMove (true,hfrom,hto) | IDENT "rename"; l = LIST1 rename SEP "," -> TacRename l | IDENT "revert"; l = LIST1 id_or_meta -> TacRevert l @@ -627,18 +629,18 @@ GEXTEND Gram TacInversion (DepInversion (k,co,ids),hyp) | IDENT "simple"; IDENT "inversion"; hyp = quantified_hypothesis; ids = with_inversion_names; - cl = simple_clause -> + cl = in_hyp_list -> TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp) | IDENT "inversion"; hyp = quantified_hypothesis; ids = with_inversion_names; - cl = simple_clause -> + cl = in_hyp_list -> TacInversion (NonDepInversion (FullInversion, cl, ids), hyp) | IDENT "inversion_clear"; hyp = quantified_hypothesis; ids = with_inversion_names; - cl = simple_clause -> + cl = in_hyp_list -> TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp) | IDENT "inversion"; hyp = quantified_hypothesis; - "using"; c = constr; cl = simple_clause -> + "using"; c = constr; cl = in_hyp_list -> TacInversion (InversionUsing (c,cl), hyp) (* Conversion *) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 87c11164..f960492e 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -9,7 +9,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) (*i camlp4use: "pa_extend.cmo" i*) -(* $Id: g_vernac.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: g_vernac.ml4 11809 2009-01-20 11:39:55Z aspiwack $ *) open Pp @@ -46,7 +46,9 @@ let noedit_mode = Gram.Entry.create "vernac:noedit_command" let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr" let thm_token = Gram.Entry.create "vernac:thm_token" let def_body = Gram.Entry.create "vernac:def_body" +let decl_notation = Gram.Entry.create "vernac:decl_notation" let typeclass_context = Gram.Entry.create "vernac:typeclass_context" +let record_field = Gram.Entry.create "vernac:record_field" let of_type_with_opt_coercion = Gram.Entry.create "vernac:of_type_with_opt_coercion" let get_command_entry () = @@ -62,7 +64,13 @@ let default_command_entry = let no_hook _ _ = () GEXTEND Gram GLOBAL: vernac gallina_ext tactic_mode proof_mode noedit_mode; - vernac: + vernac: FIRST + [ [ IDENT "Time"; locality; v = vernac_aux -> + check_locality (); VernacTime v + | locality; v = vernac_aux -> + check_locality (); v ] ] + ; + vernac_aux: (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *) (* "." is still in the stream and discard_to_dot works correctly *) [ [ g = gallina; "." -> g @@ -72,12 +80,14 @@ GEXTEND Gram | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l ] ] ; - vernac: FIRST - [ [ IDENT "Time"; v = vernac -> VernacTime v ] ] - ; - vernac: LAST + vernac_aux: LAST [ [ prfcom = default_command_entry -> prfcom ] ] ; + locality: + [ [ IDENT "Local" -> locality_flag := Some true + | IDENT "Global" -> locality_flag := Some false + | -> locality_flag := None ] ] + ; noedit_mode: [ [ c = subgoal_command -> c None] ] ; @@ -104,7 +114,6 @@ GEXTEND Gram ; END - let test_plurial_form = function | [(_,([_],_))] -> Flags.if_verbose warning @@ -119,7 +128,7 @@ let no_coercion loc (c,x) = (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - typeclass_context typeclass_constraint; + typeclass_context typeclass_constraint record_field decl_notation; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -142,6 +151,8 @@ GEXTEND Gram (* Gallina inductive declarations *) | f = finite_token; indl = LIST1 inductive_definition SEP "with" -> + let (k,f) = f in + let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in VernacInductive (f,indl) | IDENT "Boxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" -> VernacFixpoint (recs,true) @@ -158,16 +169,12 @@ GEXTEND Gram gallina_ext: [ [ b = record_token; oc = opt_coercion; name = identref; ps = binders_let; - s = [ ":"; s = lconstr -> s | -> CSort (loc,Rawterm.RType None) ]; - ":="; cstr = OPT identref; "{"; - fs = LIST0 record_field SEP ";"; "}" -> - VernacRecord (b,(oc,name),ps,s,cstr,fs) -(* Non porté ? - | f = finite_token; s = csort; id = identref; - indpar = LIST0 simple_binder; ":="; lc = constructor_list -> - VernacInductive (f,[id,None,indpar,s,lc]) -*) - ] ] + s = OPT [ ":"; s = lconstr -> s ]; + cfs = [ ":="; l = constructor_list_or_record_decl -> l + | -> RecordDecl (None, []) ] -> + let (recf,indf) = b in + VernacInductive (indf,[((oc,name),ps,s,recf,cfs),None]) + ] ] ; typeclass_context: [ [ "["; l=LIST1 typeclass_constraint SEP ","; "]" -> l @@ -189,9 +196,8 @@ GEXTEND Gram no_hook, (Local, Flags.boxed_definitions(), Definition) | IDENT "Example" -> no_hook, (Global, Flags.boxed_definitions(), Example) - | IDENT "SubClass" -> Class.add_subclass_hook, (Global, false, SubClass) - | IDENT "Local"; IDENT "SubClass" -> - Class.add_subclass_hook, (Local, false, SubClass) ] ] + | IDENT "SubClass" -> + Class.add_subclass_hook, (use_locality_exp (), false, SubClass) ] ] ; assumption_token: [ [ "Hypothesis" -> (Local, Logical) @@ -210,11 +216,13 @@ GEXTEND Gram [ ["Inline" -> true | -> false] ] ; finite_token: - [ [ "Inductive" -> true - | "CoInductive" -> false ] ] + [ [ "Inductive" -> (Inductive_kw,Finite) + | "CoInductive" -> (CoInductive,CoFinite) ] ] ; record_token: - [ [ IDENT "Record" -> true | IDENT "Structure" -> false ] ] + [ [ IDENT "Record" -> (Record,BiFinite) + | IDENT "Structure" -> (Structure,BiFinite) + | IDENT "Class" -> (Class true,BiFinite) ] ] ; (* Simple definitions *) def_body: @@ -237,15 +245,20 @@ GEXTEND Gram ; (* Inductives and records *) inductive_definition: - [ [ id = identref; indpar = binders_let; - c = [ ":"; c = lconstr -> c | -> CSort (loc,Rawterm.RType None) ]; - ":="; lc = constructor_list; ntn = decl_notation -> - ((id,indpar,c,lc),ntn) ] ] - ; - constructor_list: - [ [ "|"; l = LIST1 constructor SEP "|" -> l - | l = LIST1 constructor SEP "|" -> l - | -> [] ] ] + [ [ id = identref; oc = opt_coercion; indpar = binders_let; + c = OPT [ ":"; c = lconstr -> c ]; + ":="; lc = constructor_list_or_record_decl; ntn = decl_notation -> + (((oc,id),indpar,c,lc),ntn) ] ] + ; + constructor_list_or_record_decl: + [ [ "|"; l = LIST1 constructor SEP "|" -> Constructors l + | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" -> + Constructors ((c id)::l) + | id = identref ; c = constructor_type -> Constructors [ c id ] + | cstr = identref; "{"; fs = LIST0 record_field SEP ";"; "}" -> + RecordDecl (Some cstr,fs) + | "{";fs = LIST0 record_field SEP ";"; "}" -> RecordDecl (None,fs) + | -> Constructors [] ] ] ; (* csort: @@ -316,6 +329,9 @@ GEXTEND Gram *) (* ... with coercions *) record_field: + [ [ bd = record_binder; ntn = decl_notation -> bd,ntn ] ] + ; + record_binder: [ [ id = name -> (false,AssumExpr(id,CHole (loc, None))) | id = name; oc = of_type_with_opt_coercion; t = lconstr -> (oc,AssumExpr (id,t)) @@ -336,12 +352,19 @@ GEXTEND Gram [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> (oc,(idl,c)) ] ] ; + + constructor_type: + [[ l = binders_let; + t= [ coe = of_type_with_opt_coercion; c = lconstr -> + fun l id -> (coe,(id,mkCProdN loc l c)) + | -> + fun l id -> (false,(id,mkCProdN loc l (CHole (loc, None)))) ] + -> t l + ]] +; + constructor: - [ [ id = identref; l = binders_let; - coe = of_type_with_opt_coercion; c = lconstr -> - (coe,(id,mkCProdN loc l c)) - | id = identref; l = binders_let -> - (false,(id,mkCProdN loc l (CHole (loc, None)))) ] ] + [ [ id = identref; c=constructor_type -> c id ] ] ; of_type_with_opt_coercion: [ [ ":>" -> true @@ -440,15 +463,12 @@ GEXTEND Gram gallina_ext: [ [ (* Transparent and Opaque *) IDENT "Transparent"; l = LIST1 global -> - VernacSetOpacity (true,[Conv_oracle.transparent,l]) + VernacSetOpacity (use_non_locality (),[Conv_oracle.transparent,l]) | IDENT "Opaque"; l = LIST1 global -> - VernacSetOpacity (true,[Conv_oracle.Opaque, l]) + VernacSetOpacity (use_non_locality (),[Conv_oracle.Opaque, l]) | IDENT "Strategy"; l = LIST1 [ lev=strategy_level; "["; q=LIST1 global; "]" -> (lev,q)] -> - VernacSetOpacity (false,l) - | IDENT "Local"; IDENT "Strategy"; l = - LIST1 [ lev=strategy_level; "["; q=LIST1 global; "]" -> (lev,q)] -> - VernacSetOpacity (true,l) + VernacSetOpacity (use_locality (),l) (* Canonical structure *) | IDENT "Canonical"; IDENT "Structure"; qid = global -> VernacCanonical qid @@ -461,43 +481,31 @@ GEXTEND Gram (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> let s = coerce_global_to_id qid in - VernacDefinition ((Global,false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + VernacDefinition ((use_locality_exp (),false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> let s = coerce_global_to_id qid in - VernacDefinition ((Local,false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) + VernacDefinition ((enforce_locality_exp (),false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (Local, f, s, t) + VernacIdentityCoercion (enforce_locality_exp (), f, s, t) | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (Global, f, s, t) + VernacIdentityCoercion (use_locality_exp (), f, s, t) | IDENT "Coercion"; IDENT "Local"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (Local, qid, s, t) + VernacCoercion (enforce_locality_exp (), qid, s, t) | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (Global, qid, s, t) - - (* Type classes, new syntax without artificial sup. *) - | IDENT "Class"; qid = identref; pars = binders_let; - s = [ ":"; c = sort -> Some (loc, c) | -> None ]; - props = typeclass_field_types -> - VernacClass (qid, pars, s, [], props) - - (* Type classes *) - | IDENT "Class"; sup = OPT [ l = binders_let; "=>" -> l ]; - qid = identref; pars = binders_let; - s = [ ":"; c = sort -> Some (loc, c) | -> None ]; - props = typeclass_field_types -> - VernacClass (qid, pars, s, (match sup with None -> [] | Some l -> l), props) + VernacCoercion (use_locality_exp (), qid, s, t) | IDENT "Context"; c = binders_let -> VernacContext c - | global = [ IDENT "Global" -> true | -> false ]; - IDENT "Instance"; name = identref; sup = OPT binders_let; ":"; + | IDENT "Instance"; name = identref; sup = OPT binders_let; ":"; expl = [ "!" -> Rawterm.Implicit | -> Rawterm.Explicit ] ; t = operconstr LEVEL "200"; - pri = OPT [ "|"; i = natural -> i ] ; props = typeclass_field_defs -> + pri = OPT [ "|"; i = natural -> i ] ; + props = [ ":="; "{"; r = record_declaration; "}" -> r | + ":="; c = lconstr -> c | -> CRecord (loc, None, []) ] -> let sup = match sup with None -> [] @@ -507,17 +515,15 @@ GEXTEND Gram let (loc, id) = name in (loc, Name id) in - VernacInstance (global, sup, (n, expl, t), props, pri) + VernacInstance (not (use_non_locality ()), sup, (n, expl, t), props, pri) | IDENT "Existing"; IDENT "Instance"; is = identref -> VernacDeclareInstance is (* Implicit *) - | IDENT "Implicit"; IDENT "Arguments"; - local = [ IDENT "Global" -> false | IDENT "Local" -> true | -> Lib.sections_are_opened () ]; - qid = global; + | IDENT "Implicit"; IDENT "Arguments"; qid = global; pos = OPT [ "["; l = LIST0 implicit_name; "]" -> List.map (fun (id,b,f) -> (ExplByName id,b,f)) l ] -> - VernacDeclareImplicits (local,qid,pos) + VernacDeclareImplicits (use_section_locality (),qid,pos) | IDENT "Implicit"; ["Type" | IDENT "Types"]; idl = LIST1 identref; ":"; c = lconstr -> VernacReserve (idl,c) ] ] @@ -528,20 +534,6 @@ GEXTEND Gram | "["; "!"; id = ident; "]" -> (id,true,true) | "["; id = ident; "]" -> (id,true, false) ] ] ; - typeclass_field_type: - [ [ id = identref; oc = of_type_with_opt_coercion; t = lconstr -> id, oc, t ] ] - ; - typeclass_field_def: - [ [ id = identref; params = LIST0 identref; ":="; t = lconstr -> id, params, t ] ] - ; - typeclass_field_types: - [ [ ":="; l = LIST1 typeclass_field_type SEP ";" -> l - | -> [] ] ] - ; - typeclass_field_defs: - [ [ ":="; l = LIST1 typeclass_field_def SEP ";" -> l - | -> [] ] ] - ; strategy_level: [ [ IDENT "expand" -> Conv_oracle.Expand | IDENT "opaque" -> Conv_oracle.Opaque @@ -615,9 +607,15 @@ GEXTEND Gram | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules -> VernacSearch (SearchRewrite c, l) | IDENT "SearchAbout"; - sl = [ "["; l = LIST1 [ r = global -> SearchRef r - | s = ne_string -> SearchString s ]; "]" -> l - | qid = global -> [SearchRef qid] ]; + sl = [ "["; + l = LIST1 [ + b = positive_search_mark; s = ne_string; sc = OPT scope + -> b, SearchString (s,sc) + | b = positive_search_mark; p = constr_pattern + -> b, SearchSubPattern p + ]; "]" -> l + | p = constr_pattern -> [true,SearchSubPattern p] + | s = ne_string; sc = OPT scope -> [true,SearchString (s,sc)] ]; l = in_or_out_modules -> VernacSearch (SearchAbout sl, l) @@ -672,7 +670,7 @@ GEXTEND Gram | IDENT "Grammar"; ent = IDENT -> (* This should be in "syntax" section but is here for factorization*) PrintGrammar ent - | IDENT "LoadPath" -> PrintLoadPath + | IDENT "LoadPath"; dir = OPT dirpath -> PrintLoadPath dir | IDENT "Modules" -> error "Print Modules is obsolete; use Print Libraries instead" | IDENT "Libraries" -> PrintModules @@ -697,7 +695,6 @@ GEXTEND Gram | IDENT "Hint"; "*" -> PrintHintDb | IDENT "HintDb"; s = IDENT -> PrintHintDbName s | "Rewrite"; IDENT "HintDb"; s = IDENT -> PrintRewriteHintDbName s - | IDENT "Setoids" -> PrintSetoids | IDENT "Scopes" -> PrintScopes | IDENT "Scope"; s = IDENT -> PrintScope s | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s @@ -743,6 +740,12 @@ GEXTEND Gram | s = STRING -> CommentString s | n = natural -> CommentInt n ] ] ; + positive_search_mark: + [ [ "-" -> false | -> true ] ] + ; + scope: + [ [ "%"; key = IDENT -> key ] ] + ; END; GEXTEND Gram @@ -776,16 +779,16 @@ GEXTEND Gram ;; (* Grammar extensions *) - + GEXTEND Gram GLOBAL: syntax; syntax: - [ [ IDENT "Open"; local = locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (local,true,sc) + [ [ IDENT "Open"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> + VernacOpenCloseScope (enforce_locality_of local,true,sc) - | IDENT "Close"; local = locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (local,false,sc) + | IDENT "Close"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> + VernacOpenCloseScope (enforce_locality_of local,false,sc) | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> VernacDelimiters (sc,key) @@ -793,44 +796,44 @@ GEXTEND Gram | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) - | IDENT "Arguments"; IDENT "Scope"; local = non_globality; qid = global; - "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (local,qid,scl) + | IDENT "Arguments"; IDENT "Scope"; qid = global; + "["; scl = LIST0 opt_scope; "]" -> + VernacArgumentsScope (use_non_locality (),qid,scl) - | IDENT "Infix"; local = locality; + | IDENT "Infix"; local = obsolete_locality; op = ne_string; ":="; p = global; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacInfix (local,(op,modl),p,sc) - | IDENT "Notation"; local = locality; id = identref; idl = LIST0 ident; - ":="; c = constr; + VernacInfix (enforce_locality_of local,(op,modl),p,sc) + | IDENT "Notation"; local = obsolete_locality; id = identref; + idl = LIST0 ident; ":="; c = constr; b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] -> - VernacSyntacticDefinition (id,(idl,c),local,b) - | IDENT "Notation"; local = locality; s = ne_string; ":="; c = constr; + VernacSyntacticDefinition (id,(idl,c),enforce_locality_of local,b) + | IDENT "Notation"; local = obsolete_locality; s = ne_string; ":="; + c = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacNotation (local,c,(s,modl),sc) + VernacNotation (enforce_locality_of local,c,(s,modl),sc) | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; pil = LIST1 production_item; ":="; t = Tactic.tactic -> VernacTacticNotation (n,pil,t) - | IDENT "Reserved"; IDENT "Notation"; local = locality; s = ne_string; + | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality; + s = ne_string; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] - -> VernacSyntaxExtension (local,(s,l)) + -> VernacSyntaxExtension (enforce_locality_of local,(s,l)) (* "Print" "Grammar" should be here but is in "command" entry in order to factorize with other "Print"-based vernac entries *) ] ] ; + obsolete_locality: + [ [ IDENT "Local" -> true | -> false ] ] + ; tactic_level: [ [ "("; "at"; IDENT "level"; n = natural; ")" -> n | -> 0 ] ] ; - locality: - [ [ IDENT "Global" -> false | IDENT "Local" -> true | -> false ] ] - ; - non_globality: - [ [ IDENT "Global" -> false | IDENT "Local" -> true | -> true ] ] - ; level: [ [ IDENT "level"; n = natural -> NumLevel n | IDENT "next"; IDENT "level" -> NextLevel ] ] diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 1b0c24da..2633386f 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: lexer.ml4 11238 2008-07-19 09:34:03Z herbelin $ i*) +(*i $Id: lexer.ml4 11786 2009-01-14 13:07:34Z herbelin $ i*) (*i camlp4use: "pr_o.cmo" i*) @@ -175,7 +175,7 @@ let add_keyword str = (* Adding a new token (keyword or special token). *) let add_token (con, str) = match con with | "" -> add_keyword str - | "METAIDENT" | "PATTERNIDENT" | "IDENT" | "FIELD" | "INT" | "STRING" | "EOI" + | "METAIDENT" | "LEFTQMARK" | "IDENT" | "FIELD" | "INT" | "STRING" | "EOI" -> () | _ -> raise (Token.Error ("\ @@ -237,7 +237,7 @@ let rec string bp len = parser let xml_output_comment = ref (fun _ -> ()) let set_xml_output_comment f = xml_output_comment := f -(* Utilities for comment translation *) +(* Utilities for comments in beautify *) let comment_begin = ref None let comm_loc bp = if !comment_begin=None then comment_begin := Some bp @@ -280,7 +280,7 @@ let comment_stop ep = if !Flags.xml_export && Buffer.length current > 0 && (!between_com || not(null_comment current_s)) then !xml_output_comment current_s; - (if Flags.do_translate() && Buffer.length current > 0 && + (if Flags.do_beautify() && Buffer.length current > 0 && (!between_com || not(null_comment current_s)) then let bp = match !comment_begin with Some bp -> bp @@ -315,7 +315,7 @@ let rec comment bp = parser bp2 | [< '')' >] -> push_string "*)"; | [< s >] -> real_push_char '*'; comment bp s >] -> () | [< ''"'; s >] -> - if Flags.do_translate() then (push_string"\"";comm_string bp2 s) + if Flags.do_beautify() then (push_string"\"";comm_string bp2 s) else ignore (string bp2 0 s); comment bp s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_comment @@ -372,31 +372,50 @@ let process_chars bp c cs = | Some t -> (("", t), (bp, ep)) | None -> err (bp, ep) Undefined_token -(* Parse what follows a dot/question mark *) +let parse_after_dollar bp = + parser + | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] -> + ("METAIDENT", get_buff len) + | [< s >] -> + match lookup_utf8 s with + | Utf8Token (UnicodeLetter, n) -> + ("METAIDENT", get_buff (ident_tail (nstore n 0 s) s)) + | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp '$' s) + +(* Parse what follows a dot *) let parse_after_dot bp c = - let constructor = if c = '?' then "PATTERNIDENT" else "FIELD" in parser | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] -> - (constructor, get_buff len) + ("FIELD", get_buff len) | [< s >] -> match lookup_utf8 s with | Utf8Token (UnicodeLetter, n) -> - (constructor, get_buff (ident_tail (nstore n 0 s) s)) + ("FIELD", get_buff (ident_tail (nstore n 0 s) s)) | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp c s) +(* Parse what follows a question mark *) +let parse_after_qmark bp s = + match Stream.peek s with + |Some ('a'..'z' | 'A'..'Z' | '_') -> ("LEFTQMARK", "") + |None -> ("","?") + | _ -> + match lookup_utf8 s with + | Utf8Token (UnicodeLetter, _) -> ("LEFTQMARK", "") + | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp '?' s) + (* Parse a token in a char stream *) let rec next_token = parser bp | [< '' ' | '\t' | '\n' |'\r' as c; s >] -> comm_loc bp; push_char c; next_token s - | [< ''$'; ' ('a'..'z' | 'A'..'Z' | '_' as c); - len = ident_tail (store 0 c) >] ep -> - comment_stop bp; - (("METAIDENT", get_buff len), (bp,ep)) - | [< ' ('.' | '?') as c; t = parse_after_dot bp c >] ep -> + | [< ''$'; t = parse_after_dollar bp >] ep -> + comment_stop bp; (t, (ep, bp)) + | [< ''.' as c; t = parse_after_dot bp c >] ep -> comment_stop bp; - if Flags.do_translate() & t=("",".") then between_com := true; + if Flags.do_beautify() & t=("",".") then between_com := true; (t, (bp,ep)) + | [< ''?'; s >] ep -> + let t = parse_after_qmark bp s in comment_stop bp; (t, (ep, bp)) | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] ep -> let id = get_buff len in diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 2e55b656..d0a9c3d8 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo pa_macro.cmo" i*) -(*i $Id: pcoq.ml4 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: pcoq.ml4 11784 2009-01-14 11:36:32Z herbelin $ i*) open Pp open Util @@ -407,7 +407,7 @@ module Prim = let name = Gram.Entry.create "Prim.name" let identref = Gram.Entry.create "Prim.identref" - let pattern_ident = Gram.Entry.create "pattern_ident" + let pattern_ident = gec_gen rawwit_pattern_ident "pattern_ident" let pattern_identref = Gram.Entry.create "pattern_identref" (* A synonym of ident - maybe ident will be located one day *) @@ -445,6 +445,7 @@ module Constr = let binders_let = Gram.Entry.create "constr:binders_let" let binders_let_fixannot = Gram.Entry.create "constr:binders_let_fixannot" let typeclass_constraint = Gram.Entry.create "constr:typeclass_constraint" + let record_declaration = Gram.Entry.create "constr:record_declaration" let appl_arg = Gram.Entry.create "constr:appl_arg" end diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 525727ce..0a4b349f 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: pcoq.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: pcoq.mli 11784 2009-01-14 11:36:32Z herbelin $ i*) open Util open Names @@ -166,7 +166,8 @@ module Constr : val binder_let : local_binder list Gram.Entry.e val binders_let : local_binder list Gram.Entry.e val binders_let_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e - val typeclass_constraint : (name located * binding_kind * constr_expr) Gram.Entry.e + val typeclass_constraint : (name located * bool * constr_expr) Gram.Entry.e + val record_declaration : constr_expr Gram.Entry.e val appl_arg : (constr_expr * explicitation located option) Gram.Entry.e end diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index 5f6ffe87..d5357d86 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ppconstr.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: ppconstr.ml 11739 2009-01-02 19:33:19Z herbelin $ *) (*i*) open Util @@ -62,42 +62,46 @@ let prec_of_prim_token = function | Numeral p -> if Bigint.is_pos_or_zero p then lposint else lnegint | String _ -> latom -let env_assoc_value v env = - try List.nth env (v-1) - with Not_found -> anomaly ("Inconsistent environment for pretty-print rule") - -let decode_constrlist_value = function - | CAppExpl (_,_,l) -> l - | CApp (_,_,l) -> List.map fst l - | _ -> anomaly "Ill-formed list argument of notation" - -let decode_patlist_value = function - | CPatCstr (_,_,l) -> l - | _ -> anomaly "Ill-formed list argument of notation" - open Notation -let rec print_hunk n decode pr env = function - | UnpMetaVar (e,prec) -> pr (n,prec) (env_assoc_value e env) - | UnpListMetaVar (e,prec,sl) -> - prlist_with_sep (fun () -> prlist (print_hunk n decode pr env) sl) - (pr (n,prec)) (decode (env_assoc_value e env)) - | UnpTerminal s -> str s - | UnpBox (b,sub) -> ppcmd_of_box b (prlist (print_hunk n decode pr env) sub) - | UnpCut cut -> ppcmd_of_cut cut - -let pr_notation_gen decode pr s env = +let print_hunks n pr (env,envlist) unp = + let env = ref env and envlist = ref envlist in + let pop r = let a = List.hd !r in r := List.tl !r; a in + let rec aux = function + | [] -> mt () + | UnpMetaVar (_,prec) :: l -> + let c = pop env in pr (n,prec) c ++ aux l + | UnpListMetaVar (_,prec,sl) :: l -> + let cl = pop envlist in + let pp1 = prlist_with_sep (fun () -> aux sl) (pr (n,prec)) cl in + let pp2 = aux l in + pp1 ++ pp2 + | UnpTerminal s :: l -> str s ++ aux l + | UnpBox (b,sub) :: l -> + (* Keep order: side-effects *) + let pp1 = ppcmd_of_box b (aux sub) in + let pp2 = aux l in + pp1 ++ pp2 + | UnpCut cut :: l -> ppcmd_of_cut cut ++ aux l in + aux unp + +let pr_notation pr s env = let unpl, level = find_notation_printing_rule s in - prlist (print_hunk level decode pr env) unpl, level - -let pr_notation = pr_notation_gen decode_constrlist_value -let pr_patnotation = pr_notation_gen decode_patlist_value + print_hunks level pr env unpl, level let pr_delimiters key strm = strm ++ str ("%"^key) +let pr_generalization bk ak c = + let hd, tl = + match bk with + | Implicit -> "{", "}" + | Explicit -> "(", ")" + in (* TODO: syntax Abstraction Kind *) + str "`" ++ str hd ++ c ++ str tl + let pr_com_at n = - if Flags.do_translate() && n <> 0 then comment n + if Flags.do_beautify() && n <> 0 then comment n else mt() let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp) @@ -179,9 +183,9 @@ let rec pr_patt sep inh p = | CPatAtom (_,Some r) -> pr_reference r, latom | CPatOr (_,pl) -> hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator - | CPatNotation (_,"( _ )",[p]) -> + | CPatNotation (_,"( _ )",([p],[])) -> pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom - | CPatNotation (_,s,env) -> pr_patnotation (pr_patt mt) s env + | CPatNotation (_,s,env) -> pr_notation (pr_patt mt) s env | CPatPrim (_,p) -> pr_prim_token p, latom | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimple p), 1 in @@ -209,17 +213,23 @@ let begin_of_binders = function | b::_ -> begin_of_binder b | _ -> 0 -let surround_binder k p = +let surround_impl k p = match k with - Default Explicit -> hov 1 (str"(" ++ p ++ str")") - | Default Implicit -> hov 1 (str"{" ++ p ++ str"}") - | TypeClass _ -> hov 1 (str"[" ++ p ++ str"]") + | 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"}") - | TypeClass _ -> (str"[" ++ p ++ str"]") + | Default Explicit -> p + | Default Implicit -> (str"{" ++ p ++ str"}") + | Generalized (b, b', t) -> + surround_impl b' (surround_impl b p) let pr_binder many pr (nal,k,t) = match t with @@ -542,6 +552,17 @@ let rec pr sep inherited a = else p, lproj | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp + | CRecord (_,w,l) -> + let beg = + match w with + | None -> spc () + | Some t -> spc () ++ pr spc ltop t ++ spc () ++ str"with" ++ spc () + in + hv 0 (str"{" ++ beg ++ + prlist_with_sep (fun () -> spc () ++ str";" ++ spc ()) + (fun ((_,id), c) -> pr_id id ++ spc () ++ str":=" ++ spc () ++ pr spc ltop c) + l), latom + | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) -> hv 0 ( str "let '" ++ @@ -592,9 +613,10 @@ let rec pr sep inherited a = | CCast (_,a,CastCoerce) -> hv 0 (pr mt (lcast,L) a ++ cut () ++ str ":>"), lcast - | CNotation (_,"( _ )",[t]) -> + | CNotation (_,"( _ )",([t],[])) -> pr (fun()->str"(") (max_int,L) t ++ str")", latom | CNotation (_,s,env) -> pr_notation (pr mt) s env + | CGeneralization (_,bk,ak,c) -> pr_generalization bk ak (pr mt lsimple c), latom | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt lsimple a), 1 | CDynamic _ -> str "", latom @@ -644,15 +666,15 @@ let rec strip_context n iscast t = type term_pr = { pr_constr_expr : constr_expr -> std_ppcmds; pr_lconstr_expr : constr_expr -> std_ppcmds; - pr_pattern_expr : Tacexpr.pattern_expr -> std_ppcmds; - pr_lpattern_expr : Tacexpr.pattern_expr -> std_ppcmds + pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; + pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds } let default_term_pr = { pr_constr_expr = pr lsimple; pr_lconstr_expr = pr ltop; - pr_pattern_expr = pr lsimple; - pr_lpattern_expr = pr ltop + pr_constr_pattern_expr = pr lsimple; + pr_lconstr_pattern_expr = pr ltop } let term_pr = ref default_term_pr @@ -661,8 +683,8 @@ let set_term_pr = (:=) term_pr let pr_constr_expr c = !term_pr.pr_constr_expr c let pr_lconstr_expr c = !term_pr.pr_lconstr_expr c -let pr_pattern_expr c = !term_pr.pr_pattern_expr c -let pr_lpattern_expr c = !term_pr.pr_lpattern_expr c +let pr_constr_pattern_expr c = !term_pr.pr_constr_pattern_expr c +let pr_lconstr_pattern_expr c = !term_pr.pr_lconstr_pattern_expr c let pr_cases_pattern_expr = pr_patt ltop diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli index 8047e968..0d0c8f56 100644 --- a/parsing/ppconstr.mli +++ b/parsing/ppconstr.mli @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ppconstr.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: ppconstr.mli 11739 2009-01-02 19:33:19Z herbelin $ i*) open Pp open Environ @@ -66,8 +66,8 @@ val pr_may_eval : val pr_rawsort : rawsort -> std_ppcmds val pr_binders : local_binder list -> std_ppcmds -val pr_pattern_expr : Tacexpr.pattern_expr -> std_ppcmds -val pr_lpattern_expr : Tacexpr.pattern_expr -> std_ppcmds +val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds +val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds val pr_constr_expr : constr_expr -> std_ppcmds val pr_lconstr_expr : constr_expr -> std_ppcmds val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds @@ -75,8 +75,8 @@ val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds type term_pr = { pr_constr_expr : constr_expr -> std_ppcmds; pr_lconstr_expr : constr_expr -> std_ppcmds; - pr_pattern_expr : Tacexpr.pattern_expr -> std_ppcmds; - pr_lpattern_expr : Tacexpr.pattern_expr -> std_ppcmds + pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; + pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds } val set_term_pr : term_pr -> unit diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index 6a7ae9bc..3b433498 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: pptactic.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: pptactic.ml 11784 2009-01-14 11:36:32Z herbelin $ *) open Pp open Names @@ -21,6 +21,7 @@ open Pattern open Ppextend open Ppconstr open Printer +open Termops let pr_global x = Nametab.pr_global_env Idset.empty x @@ -79,7 +80,7 @@ let pr_and_short_name pr (c,_) = pr c let pr_or_by_notation f = function | AN v -> f v - | ByNotation (_,s) -> str s + | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc let pr_located pr (loc,x) = pr x @@ -122,10 +123,6 @@ let pr_with_constr prc = function | None -> mt () | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c) -let pr_with_names = function - | None -> mt () - | Some ipat -> spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat) - let rec pr_message_token prid = function | MsgString s -> qs s | MsgInt n -> int n @@ -140,6 +137,8 @@ let out_bindings = function | ExplicitBindings l -> ExplicitBindings (List.map (fun (loc,id,c) -> (loc,id,snd c)) l) | NoBindings -> NoBindings +let if_pattern_ident b pr c = (if b then str "?" else mt()) ++ pr c + let rec pr_raw_generic prc prlc prtac prref (x:Genarg.rlevel Genarg.generic_argument) = match Genarg.genarg_tag x with | BoolArgType -> str (if out_gen rawwit_bool x then "true" else "false") @@ -148,7 +147,7 @@ let rec pr_raw_generic prc prlc prtac prref (x:Genarg.rlevel Genarg.generic_argu | StringArgType -> str "\"" ++ str (out_gen rawwit_string x) ++ str "\"" | PreIdentArgType -> str (out_gen rawwit_pre_ident x) | IntroPatternArgType -> pr_intro_pattern (out_gen rawwit_intro_pattern x) - | IdentArgType -> pr_id (out_gen rawwit_ident x) + | IdentArgType b -> if_pattern_ident b pr_id (out_gen rawwit_ident x) | VarArgType -> pr_located pr_id (out_gen rawwit_var x) | RefArgType -> prref (out_gen rawwit_ref x) | SortArgType -> pr_rawsort (out_gen rawwit_sort x) @@ -179,7 +178,7 @@ let rec pr_raw_generic prc prlc prtac prref (x:Genarg.rlevel Genarg.generic_argu x) | ExtraArgType s -> try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x - with Not_found -> str " [no printer for " ++ str s ++ str "] " + with Not_found -> str "[no printer for " ++ str s ++ str "]" let rec pr_glob_generic prc prlc prtac x = @@ -190,7 +189,7 @@ let rec pr_glob_generic prc prlc prtac x = | StringArgType -> str "\"" ++ str (out_gen globwit_string x) ++ str "\"" | PreIdentArgType -> str (out_gen globwit_pre_ident x) | IntroPatternArgType -> pr_intro_pattern (out_gen globwit_intro_pattern x) - | IdentArgType -> pr_id (out_gen globwit_ident x) + | IdentArgType b -> if_pattern_ident b pr_id (out_gen globwit_ident x) | VarArgType -> pr_located pr_id (out_gen globwit_var x) | RefArgType -> pr_or_var (pr_located pr_global) (out_gen globwit_ref x) | SortArgType -> pr_rawsort (out_gen globwit_sort x) @@ -224,7 +223,7 @@ let rec pr_glob_generic prc prlc prtac x = x) | ExtraArgType s -> try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x - with Not_found -> str "[no printer for " ++ str s ++ str "] " + with Not_found -> str "[no printer for " ++ str s ++ str "]" open Closure @@ -236,7 +235,7 @@ let rec pr_generic prc prlc prtac x = | StringArgType -> str "\"" ++ str (out_gen wit_string x) ++ str "\"" | PreIdentArgType -> str (out_gen wit_pre_ident x) | IntroPatternArgType -> pr_intro_pattern (out_gen wit_intro_pattern x) - | IdentArgType -> pr_id (out_gen wit_ident x) + | IdentArgType b -> if_pattern_ident b pr_id (out_gen wit_ident x) | VarArgType -> pr_id (out_gen wit_var x) | RefArgType -> pr_global (out_gen wit_ref x) | SortArgType -> pr_sort (out_gen wit_sort x) @@ -326,9 +325,6 @@ let pr_evaluable_reference_env env = function | EvalConstRef sp -> Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.ConstRef sp) -let pr_inductive env ind = - Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.IndRef ind) - let pr_quantified_hypothesis = function | AnonHyp n -> int n | NamedHyp id -> pr_id id @@ -376,9 +372,9 @@ let pr_with_inversion_names = function | None -> mt () | Some ipat -> pr_as_intro_pattern ipat -let pr_with_names = function - | _,IntroAnonymous -> mt () - | ipat -> pr_as_intro_pattern ipat +let pr_as_ipat = function + | None -> mt () + | Some ipat -> pr_as_intro_pattern ipat let pr_as_name = function | Anonymous -> mt () @@ -397,7 +393,7 @@ let pr_assertion _prlc prc ipat c = match ipat with spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c) *) | ipat -> - spc() ++ prc c ++ pr_with_names ipat + spc() ++ prc c ++ pr_as_ipat ipat let pr_assumption prlc prc ipat c = match ipat with (* Use this "optimisation" or use only the general case ? @@ -405,7 +401,7 @@ let pr_assumption prlc prc ipat c = match ipat with spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c) *) | ipat -> - spc() ++ prc c ++ pr_with_names ipat + spc() ++ prc c ++ pr_as_ipat ipat let pr_by_tactic prt = function | TacId [] -> mt () @@ -426,6 +422,10 @@ let pr_simple_clause pr_id = function | [] -> mt () | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l) +let pr_in_hyp_as pr_id = function + | None -> mt () + | Some (id,ipat) -> pr_simple_clause pr_id [id] ++ pr_as_ipat ipat + let pr_clauses pr_id = function | { onhyps=None; concl_occs=occs } -> if occs = no_occurrences_expr then pr_in (str " * |-") @@ -468,12 +468,16 @@ let pr_lazy lz = if lz then str "lazy" else mt () let pr_match_pattern pr_pat = function | Term a -> pr_pat a - | Subterm (None,a) -> str "context [" ++ pr_pat a ++ str "]" - | Subterm (Some id,a) -> - str "context " ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]" + | Subterm (b,None,a) -> (if b then str"appcontext [" else str "context [") ++ pr_pat a ++ str "]" + | Subterm (b,Some id,a) -> + (if b then str"appcontext " else str "context ") ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]" -let pr_match_hyps pr_pat (Hyp (nal,mp)) = - pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp +let pr_match_hyps pr_pat = function + | Hyp (nal,mp) -> + pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp + | Def (nal,mv,mp) -> + pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv + ++ str ":" ++ pr_match_pattern pr_pat mp let pr_match_rule m pr pr_pat = function | Pat ([],mp,t) when m -> @@ -695,10 +699,11 @@ and pr_atom1 = function | TacExact c -> hov 1 (str "exact" ++ pr_constrarg c) | TacExactNoCheck c -> hov 1 (str "exact_no_check" ++ pr_constrarg c) | TacVmCastNoCheck c -> hov 1 (str "vm_cast_no_check" ++ pr_constrarg c) - | TacApply (a,ev,cb) -> + | TacApply (a,ev,cb,inhyp) -> hov 1 ((if a then mt() else str "simple ") ++ str (with_evars ev "apply") ++ spc () ++ - prlist_with_sep pr_coma pr_with_bindings cb) + prlist_with_sep pr_coma pr_with_bindings cb ++ + pr_in_hyp_as pr_ident inhyp) | TacElim (ev,cb,cbo) -> hov 1 (str (with_evars ev "elim") ++ pr_arg pr_with_bindings cb ++ pr_opt pr_eliminator cbo) @@ -1019,7 +1024,7 @@ let rec raw_printers = (pr_raw_tactic_level, drop_env pr_constr_expr, drop_env pr_lconstr_expr, - pr_lpattern_expr, + pr_lconstr_pattern_expr, drop_env (pr_or_by_notation pr_reference), drop_env (pr_or_by_notation pr_reference), pr_reference, diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml index 67cd6f72..78c63ca2 100644 --- a/parsing/ppvernac.ml +++ b/parsing/ppvernac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ppvernac.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: ppvernac.ml 11809 2009-01-20 11:39:55Z aspiwack $ *) open Pp open Names @@ -133,9 +133,11 @@ let pr_in_out_modules = function | SearchOutside [] -> mt() | SearchOutside l -> spc() ++ str"outside" ++ spc() ++ prlist_with_sep sep pr_module l -let pr_search_about = function - | SearchRef r -> pr_reference r - | SearchString s -> qs s +let pr_search_about (b,c) = + (if b then str "-" else mt()) ++ + match c with + | SearchSubPattern p -> pr_constr_pattern_expr p + | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc let pr_search a b pr_p = match a with | SearchHead qid -> str"Search" ++ spc() ++ pr_reference qid ++ pr_in_out_modules b @@ -144,7 +146,7 @@ let pr_search a b pr_p = match a with | SearchAbout sl -> str"SearchAbout" ++ spc() ++ str "[" ++ prlist_with_sep spc pr_search_about sl ++ str "]" ++ pr_in_out_modules b let pr_locality local = if local then str "Local " else str "" -let pr_non_globality local = if local then str "" else str "Global " +let pr_non_locality local = if local then str "" else str "Global " let pr_explanation (e,b,f) = let a = match e with @@ -192,18 +194,22 @@ let pr_hints local db h pr_c pr_pat = match h with | HintsResolve l -> str "Resolve " ++ prlist_with_sep sep - (fun (pri, c) -> pr_c c ++ + (fun (pri, _, c) -> pr_c c ++ match pri with Some x -> spc () ++ str"(" ++ int x ++ str")" | None -> mt ()) l | HintsImmediate l -> str"Immediate" ++ spc() ++ prlist_with_sep sep pr_c l | HintsUnfold l -> str "Unfold " ++ prlist_with_sep sep pr_reference l + | HintsTransparency (l, b) -> + str (if b then "Transparent " else "Opaque ") ++ prlist_with_sep sep + pr_reference l | HintsConstructors c -> str"Constructors" ++ spc() ++ prlist_with_sep spc pr_reference c - | HintsExtern (n,c,tac) -> - str "Extern" ++ spc() ++ int n ++ spc() ++ pr_pat c ++ str" =>" ++ - spc() ++ pr_raw_tactic tac + | HintsExtern (n,c,tac) -> + 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() ++ @@ -325,7 +331,7 @@ let pr_assumption_token many = function str (if many then "Parameters" else "Parameter") | (Global,Conjectural) -> str"Conjecture" | (Local,Conjectural) -> - anomaly "Don't know how to translate a local conjecture" + anomaly "Don't know how to beautify a local conjecture" let pr_params pr_c (xl,(c,t)) = hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++ @@ -402,9 +408,27 @@ let make_pr_vernac pr_constr pr_lconstr = let pr_constrarg c = spc () ++ pr_constr c in let pr_lconstrarg c = spc () ++ pr_lconstr c in let pr_intarg n = spc () ++ int n in -let pr_lident_constr sep (i,c) = pr_lident i ++ sep ++ pr_constrarg c in -let pr_instance_def sep (i,l,c) = pr_lident i ++ prlist_with_sep spc pr_lident l - ++ sep ++ pr_constrarg c in +(* let pr_lident_constr sep (i,c) = pr_lident i ++ sep ++ pr_constrarg c in *) +let pr_record_field (x, ntn) = + let prx = match x with + | (oc,AssumExpr (id,t)) -> + hov 1 (pr_lname id ++ + (if oc then str" :>" else str" :") ++ spc() ++ + pr_lconstr_expr t) + | (oc,DefExpr(id,b,opt)) -> (match opt with + | Some t -> + hov 1 (pr_lname id ++ + (if oc then str" :>" else str" :") ++ spc() ++ + pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b) + | None -> + hov 1 (pr_lname id ++ str" :=" ++ spc() ++ + pr_lconstr b)) in + prx ++ pr_decl_notation pr_constr ntn +in +let pr_record_decl b c fs = + pr_opt pr_lident c ++ str"{" ++ + hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}") +in let rec pr_vernac = function @@ -480,7 +504,7 @@ let rec pr_vernac = function | VernacArgumentsScope (local,q,scl) -> let pr_opt_scope = function | None -> str"_" | Some sc -> str sc in - str"Arguments Scope" ++ spc() ++ pr_non_globality local ++ pr_reference q + str"Arguments Scope" ++ spc() ++ pr_non_locality local ++ pr_reference q ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]" | VernacInfix (local,(s,mv),q,sn) -> (* A Verifier *) hov 0 (hov 0 (str"Infix " ++ pr_locality local @@ -533,11 +557,11 @@ let rec pr_vernac = function | VernacStartTheoremProof (ki,l,_,_) -> let pr_statement head (id,(bl,c)) = hov 0 - (head ++ spc () ++ pr_opt pr_lident id ++ spc() ++ + (head ++ pr_opt pr_lident id ++ spc() ++ (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++ str":" ++ pr_spc_lconstr c) in hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++ - prlist (pr_statement (str "with ")) (List.tl l)) + prlist (pr_statement (spc () ++ str "with")) (List.tl l)) | VernacEndProof Admitted -> str"Admitted" | VernacEndProof (Proved (opac,o)) -> (match o with @@ -558,22 +582,31 @@ let rec pr_vernac = function hov 2 (pr_lident id ++ str" " ++ (if coe then str":>" else str":") ++ pr_spc_lconstr c) in - let pr_constructor_list l = match l with - | [] -> mt() - | _ -> + let pr_constructor_list b l = match l with + | Constructors [] -> mt() + | Constructors l -> pr_com_at (begin_of_inductive l) ++ fnl() ++ str (if List.length l = 1 then " " else " | ") ++ - prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l in - let pr_oneind key ((id,indpar,s,lc),ntn) = - hov 0 ( - str key ++ spc() ++ - pr_lident id ++ pr_and_type_binders_arg indpar ++ spc() ++ str":" ++ - spc() ++ pr_lconstr_expr s ++ - str" :=") ++ pr_constructor_list lc ++ - pr_decl_notation pr_constr ntn in - - hov 1 (pr_oneind (if f then "Inductive" else "CoInductive") (List.hd l)) + prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l + | RecordDecl (c,fs) -> + spc() ++ + pr_record_decl b c fs in + let pr_oneind key (((coe,id),indpar,s,k,lc),ntn) = + let kw = + str (match k with Record -> "Record" | Structure -> "Structure" + | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" + | Class b -> if b then "Definitional Class" else "Class") + in + hov 0 ( + kw ++ spc() ++ + (if coe then str" > " else str" ") ++ pr_lident id ++ + pr_and_type_binders_arg indpar ++ spc() ++ + Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++ + str" :=") ++ pr_constructor_list k lc ++ + pr_decl_notation pr_constr ntn + in + hov 1 (pr_oneind (if (Decl_kinds.recursivity_flag_of_kind f) then "Inductive" else "CoInductive") (List.hd l)) ++ (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) @@ -585,7 +618,7 @@ let rec pr_vernac = function let pr_onerec = function | ((loc,id),(n,ro),bl,type_,def),ntn -> let (bl',def,type_) = - if Flags.do_translate() then extract_def_binders def type_ + if Flags.do_beautify() then extract_def_binders def type_ else ([],def,type_) in let bl = bl @ bl' in let ids = List.flatten (List.map name_of_binder bl) in @@ -617,7 +650,7 @@ let rec pr_vernac = function | VernacCoFixpoint (corecs,b) -> let pr_onecorec (((loc,id),bl,c,def),ntn) = let (bl',def,c) = - if Flags.do_translate() then extract_def_binders def c + if Flags.do_beautify() then extract_def_binders def c else ([],def,c) in let bl = bl @ bl' in pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ @@ -638,30 +671,6 @@ let rec pr_vernac = function (* Gallina extensions *) - | VernacRecord (b,(oc,name),ps,s,c,fs) -> - let pr_record_field = function - | (oc,AssumExpr (id,t)) -> - hov 1 (pr_lname id ++ - (if oc then str" :>" else str" :") ++ spc() ++ - pr_lconstr_expr t) - | (oc,DefExpr(id,b,opt)) -> (match opt with - | Some t -> - hov 1 (pr_lname id ++ - (if oc then str" :>" else str" :") ++ spc() ++ - pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b) - | None -> - hov 1 (pr_lname id ++ str" :=" ++ spc() ++ - pr_lconstr b)) in - hov 2 - (str (if b then "Record" else "Structure") ++ - (if oc then str" > " else str" ") ++ pr_lident name ++ - pr_and_type_binders_arg ps ++ str" :" ++ spc() ++ - pr_lconstr_expr s ++ str" := " ++ - (match c with - | None -> mt() - | Some sc -> pr_lident sc) ++ - spc() ++ str"{" ++ - hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}")) | VernacBeginSection id -> hov 2 (str"Section" ++ spc () ++ pr_lident id) | VernacEndSegment id -> hov 2 (str"End" ++ spc() ++ pr_lident id) | VernacRequire (exp,spe,l) -> hov 2 @@ -688,28 +697,17 @@ let rec pr_vernac = function str"Local" ++ spc() | Global -> spc()) ++ pr_lident id ++ 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_rawsort (snd ar) | None -> mt()) ++ - spc () ++ str"where" ++ 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 (glob, sup, (instid, bk, cl), props, pri) -> hov 1 ( - pr_non_globality (not glob) ++ + pr_non_locality (not glob) ++ 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 () ++ - spc () ++ str"where" ++ spc () ++ - prlist_with_sep (fun () -> str";" ++ spc()) (pr_instance_def (spc () ++ str":=" ++ spc())) props) + spc () ++ str":=" ++ spc () ++ + pr_constr_expr props) | VernacContext l -> hov 1 ( @@ -806,8 +804,10 @@ let rec pr_vernac = function hov 1 ((str "Ltac ") ++ prlist_with_sep (fun () -> fnl() ++ str"with ") pr_tac_body l) + | VernacCreateHintDb (local,dbname,b) -> + hov 1 (str "Create " ++ pr_locality local ++ str "HintDb " ++ str dbname ++ (if b then str" discriminated" else mt ())) | VernacHints (local,dbnames,h) -> - pr_hints local dbnames h pr_constr pr_pattern_expr + pr_hints local dbnames h pr_constr pr_constr_pattern_expr | VernacSyntacticDefinition (id,(ids,c),local,onlyparsing) -> hov 2 (str"Notation " ++ pr_locality local ++ pr_lident id ++ @@ -816,7 +816,7 @@ let rec pr_vernac = function | VernacDeclareImplicits (local,q,None) -> hov 2 (str"Implicit Arguments" ++ spc() ++ pr_reference q) | VernacDeclareImplicits (local,q,Some imps) -> - hov 1 (str"Implicit Arguments " ++ pr_non_globality local ++ + hov 1 (str"Implicit Arguments " ++ pr_non_locality local ++ spc() ++ pr_reference q ++ spc() ++ str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]") | VernacReserve (idl,c) -> @@ -824,11 +824,11 @@ let rec pr_vernac = function str (if List.length idl > 1 then "s " else " ") ++ prlist_with_sep spc pr_lident idl ++ str " :" ++ spc () ++ pr_lconstr c) - | VernacSetOpacity(true,[k,l]) when k=Conv_oracle.transparent -> - hov 1 (str"Transparent" ++ + | VernacSetOpacity(b,[k,l]) when k=Conv_oracle.transparent -> + hov 1 (str"Transparent" ++ pr_non_locality b ++ spc() ++ prlist_with_sep sep pr_reference l) - | VernacSetOpacity(true,[Conv_oracle.Opaque,l]) -> - hov 1 (str"Opaque" ++ + | VernacSetOpacity(b,[Conv_oracle.Opaque,l]) -> + hov 1 (str"Opaque" ++ pr_non_locality b ++ spc() ++ prlist_with_sep sep pr_reference l) | VernacSetOpacity (local,l) -> let pr_lev = function @@ -866,7 +866,7 @@ let rec pr_vernac = function str"Print Section" ++ spc() ++ Libnames.pr_reference s | PrintGrammar ent -> str"Print Grammar" ++ spc() ++ str ent - | PrintLoadPath -> str"Print LoadPath" + | PrintLoadPath dir -> str"Print LoadPath" ++ pr_opt pr_dirpath dir | PrintModules -> str"Print Modules" | PrintMLLoadPath -> str"Print ML Path" | PrintMLModules -> str"Print ML Modules" @@ -890,7 +890,6 @@ let rec pr_vernac = function | PrintModuleType qid -> str"Print Module Type" ++ spc() ++ pr_reference qid | PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid | PrintInspect n -> str"Inspect" ++ spc() ++ int n - | PrintSetoids -> str"Print Setoids" | PrintScopes -> str"Print Scopes" | PrintScope s -> str"Print Scope" ++ spc() ++ str s | PrintVisibility s -> str"Print Visibility" ++ pr_opt str s @@ -900,7 +899,7 @@ let rec pr_vernac = function term *) | PrintAssumptions qid -> str"Print Assumptions"++spc()++pr_reference qid in pr_printable p - | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_pattern_expr + | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_constr_pattern_expr | VernacLocate loc -> let pr_locate =function | LocateTerm qid -> pr_reference qid @@ -931,19 +930,16 @@ and pr_extend s cl = let rl = match_vernac_rule (List.map Genarg.genarg_tag cl) rls in let start,rl,cl = match rl with - | Egrammar.TacTerm s :: rl -> str s, rl, cl - | Egrammar.TacNonTerm _ :: rl -> - (* Will put an unnecessary extra space in front *) - pr_gen (Global.env()) (List.hd cl), rl, List.tl cl - | [] -> anomaly "Empty entry" in + | Egrammar.TacTerm s :: rl -> str s, rl, cl + | Egrammar.TacNonTerm _ :: rl -> pr_arg (List.hd cl), rl, List.tl cl + | [] -> anomaly "Empty entry" in let (pp,_) = List.fold_left (fun (strm,args) pi -> - match pi with - Egrammar.TacNonTerm _ -> - (strm ++ pr_gen (Global.env()) (List.hd args), - List.tl args) - | Egrammar.TacTerm s -> (strm ++ spc() ++ str s, args)) + let pp,args = match pi with + | Egrammar.TacNonTerm _ -> (pr_arg (List.hd args), List.tl args) + | Egrammar.TacTerm s -> (str s, args) in + (strm ++ spc() ++ pp), args) (start,cl) rl in hov 1 pp with Not_found -> diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index 4811c443..5543a31c 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -10,7 +10,7 @@ * on May-June 2006 for implementation of abstraction of pretty-printing of objects. *) -(* $Id: prettyp.ml 11343 2008-09-01 20:55:13Z herbelin $ *) +(* $Id: prettyp.ml 11622 2008-11-23 08:45:56Z herbelin $ *) open Pp open Util @@ -349,10 +349,10 @@ let pr_record (sp,tyi) = str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++ str ":= " ++ pr_id cstrnames.(0)) ++ brk(1,2) ++ - hv 2 (str "{ " ++ - prlist_with_sep (fun () -> str "; " ++ brk(1,0)) + hv 2 (str "{" ++ + prlist_with_sep (fun () -> str ";" ++ brk(1,0)) (fun (id,b,c) -> - pr_id id ++ str (if b then " : " else " := ") ++ + str " " ++ pr_id id ++ str (if b then " : " else " := ") ++ pr_lconstr_env envpar c) fields) ++ str" }") let gallina_print_inductive sp = @@ -784,6 +784,11 @@ let pr_instance env i = (* lighter *) print_ref false (ConstRef (instance_impl i)) +let print_all_instances () = + let env = Global.env () in + let inst = all_instances () in + prlist_with_sep fnl (pr_instance env) inst + let print_instances r = let env = Global.env () in let inst = instances r in diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli index a487ef62..ec2228c7 100644 --- a/parsing/prettyp.mli +++ b/parsing/prettyp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: prettyp.mli 10697 2008-03-19 17:58:43Z msozeau $ i*) +(*i $Id: prettyp.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Pp @@ -61,7 +61,7 @@ val print_canonical_projections : unit -> std_ppcmds (* Pretty-printing functions for type classes and instances *) val print_typeclasses : unit -> std_ppcmds val print_instances : global_reference -> std_ppcmds - +val print_all_instances : unit -> std_ppcmds val inspect : int -> std_ppcmds diff --git a/parsing/printer.ml b/parsing/printer.ml index b126cc9c..10034dd9 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: printer.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: printer.ml 11739 2009-01-02 19:33:19Z herbelin $ *) open Pp open Util @@ -90,14 +90,14 @@ let pr_cases_pattern t = pr_cases_pattern_expr (extern_cases_pattern Idset.empty t) let pr_lconstr_pattern_env env c = - pr_lconstr_expr (extern_constr_pattern (names_of_rel_context env) c) + pr_lconstr_pattern_expr (extern_constr_pattern (names_of_rel_context env) c) let pr_constr_pattern_env env c = - pr_constr_expr (extern_constr_pattern (names_of_rel_context env) c) + pr_constr_pattern_expr (extern_constr_pattern (names_of_rel_context env) c) let pr_lconstr_pattern t = - pr_lconstr_expr (extern_constr_pattern empty_names_context t) + pr_lconstr_pattern_expr (extern_constr_pattern empty_names_context t) let pr_constr_pattern t = - pr_constr_expr (extern_constr_pattern empty_names_context t) + pr_constr_pattern_expr (extern_constr_pattern empty_names_context t) let pr_sort s = pr_rawsort (extern_sort s) @@ -162,9 +162,9 @@ let pr_rel_decl env (na,c,typ) = (* Prints a signature, all declarations on the same line if possible *) let pr_named_context_of env = - hv 0 (fold_named_context - (fun env d pps -> pps ++ ws 2 ++ pr_var_decl env d) - env ~init:(mt ())) + let make_decl_list env d pps = pr_var_decl env d :: pps in + let psl = List.rev (fold_named_context make_decl_list env ~init:[]) in + hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl) let pr_named_context env ne_context = hv 0 (Sign.fold_named_context @@ -475,6 +475,9 @@ let pr_prim_rule = function (str (if withdep then "dependent " else "") ++ str"move " ++ pr_id id1 ++ pr_move_location pr_id id2) + | Order ord -> + (str"order " ++ prlist_with_sep pr_spc pr_id ord) + | Rename (id1,id2) -> (str "rename " ++ pr_id id1 ++ str " into " ++ pr_id id2) diff --git a/parsing/printmod.ml b/parsing/printmod.ml index be73f573..596ce6b2 100644 --- a/parsing/printmod.ml +++ b/parsing/printmod.ml @@ -90,7 +90,7 @@ and print_modtype locals mty = let s = (String.concat "." (List.map string_of_id idl)) in hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ str "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) - | SEBwith(seb,With_module_body(idl,mp,_))-> + | SEBwith(seb,With_module_body(idl,mp,_,_))-> let s =(String.concat "." (List.map string_of_id idl)) in hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ str "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) @@ -102,7 +102,7 @@ and print_sig locals msid sign = | SFBconst {const_opaque=true} -> str "Parameter " | SFBmind _ -> str "Inductive " | SFBmodule _ -> str "Module " - | SFBalias (mp,_) -> str "Module " + | SFBalias (mp,_,_) -> str "Module " | SFBmodtype _ -> str "Module Type ") ++ str (string_of_label l) in prlist_with_sep spc print_spec sign @@ -114,7 +114,7 @@ and print_struct locals msid struc = | SFBconst {const_body=None} -> str "Parameter " | SFBmind _ -> str "Inductive " | SFBmodule _ -> str "Module " - | SFBalias (mp,_) -> str "Module " + | SFBalias (mp,_,_) -> str "Module " | SFBmodtype _ -> str "Module Type ") ++ str (string_of_label l) in prlist_with_sep spc print_body struc diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4 index 72d81051..37817389 100644 --- a/parsing/q_constr.ml4 +++ b/parsing/q_constr.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) -(* $Id: q_constr.ml4 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: q_constr.ml4 11576 2008-11-10 19:13:15Z msozeau $ *) open Rawterm open Term @@ -75,7 +75,7 @@ EXTEND | "0" [ s = sort -> <:expr< Rawterm.RSort ($dloc$,s) >> | id = ident -> <:expr< Rawterm.RVar ($dloc$,$id$) >> - | "_" -> <:expr< Rawterm.RHole ($dloc$, QuestionMark False) >> + | "_" -> <:expr< Rawterm.RHole ($dloc$, QuestionMark (Define False)) >> | "?"; id = ident -> <:expr< Rawterm.RPatVar($dloc$,(False,$id$)) >> | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" -> apply_ref <:expr< coq_sumbool_ref >> [c1;c2] diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index a4cfe27a..aeee632c 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "q_MLast.cmo pa_macro.cmo" i*) -(* $Id: q_coqast.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: q_coqast.ml4 11735 2009-01-02 17:22:31Z herbelin $ *) open Util open Names @@ -68,7 +68,8 @@ let mlexpr_of_loc loc = <:expr< $dloc$ >> let mlexpr_of_by_notation f = function | Genarg.AN x -> <:expr< Genarg.AN $f x$ >> - | Genarg.ByNotation (loc,s) -> <:expr< Genarg.ByNotation $dloc$ $str:s$ >> + | Genarg.ByNotation (loc,s,sco) -> + <:expr< Genarg.ByNotation $dloc$ $str:s$ $mlexpr_of_option mlexpr_of_string sco$ >> let mlexpr_of_intro_pattern = function | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >> @@ -102,12 +103,12 @@ let mlexpr_of_occs = let mlexpr_of_occurrences f = mlexpr_of_pair mlexpr_of_occs f let mlexpr_of_hyp_location = function - | occs, Tacexpr.InHyp -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Tacexpr.InHyp) >> - | occs, Tacexpr.InHypTypeOnly -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Tacexpr.InHypTypeOnly) >> - | occs, Tacexpr.InHypValueOnly -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Tacexpr.InHypValueOnly) >> + | occs, Termops.InHyp -> + <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHyp) >> + | occs, Termops.InHypTypeOnly -> + <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHypTypeOnly) >> + | occs, Termops.InHypValueOnly -> + <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHypValueOnly) >> let mlexpr_of_clause cl = <:expr< {Tacexpr.onhyps= @@ -139,7 +140,9 @@ let mlexpr_of_binding_kind = function let mlexpr_of_binder_kind = function | Topconstr.Default b -> <:expr< Topconstr.Default $mlexpr_of_binding_kind b$ >> - | Topconstr.TypeClass (b,b') -> <:expr< Topconstr.TypeClass $mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_binding_kind (b,b')$ >> + | Topconstr.Generalized (b,b',b'') -> + <:expr< Topconstr.TypeClass $mlexpr_of_binding_kind b$ + $mlexpr_of_binding_kind b'$ $mlexpr_of_bool b''$ >> let rec mlexpr_of_constr = function | Topconstr.CRef (Libnames.Ident (loc,id)) when is_meta (string_of_id id) -> @@ -158,9 +161,11 @@ let rec mlexpr_of_constr = function | Topconstr.CCases (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO" | Topconstr.CHole (loc, None) -> <:expr< Topconstr.CHole $dloc$ None >> | Topconstr.CHole (loc, Some _) -> failwith "mlexpr_of_constr: TODO CHole (Some _)" - | Topconstr.CNotation(_,ntn,l) -> + | Topconstr.CNotation(_,ntn,subst) -> <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$ - $mlexpr_of_list mlexpr_of_constr l$ >> + $mlexpr_of_pair + (mlexpr_of_list mlexpr_of_constr) + (mlexpr_of_list (mlexpr_of_list mlexpr_of_constr)) subst$ >> | Topconstr.CPatVar (loc,n) -> <:expr< Topconstr.CPatVar $dloc$ $mlexpr_of_pair mlexpr_of_bool mlexpr_of_ident n$ >> | _ -> failwith "mlexpr_of_constr: TODO" @@ -196,7 +201,7 @@ let rec mlexpr_of_argtype loc = function | Genarg.RefArgType -> <:expr< Genarg.RefArgType >> | Genarg.PreIdentArgType -> <:expr< Genarg.PreIdentArgType >> | Genarg.IntroPatternArgType -> <:expr< Genarg.IntroPatternArgType >> - | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >> + | Genarg.IdentArgType b -> <:expr< Genarg.IdentArgType $mlexpr_of_bool b$ >> | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> | Genarg.StringArgType -> <:expr< Genarg.StringArgType >> | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >> @@ -264,13 +269,16 @@ let mlexpr_of_entry_type = function let mlexpr_of_match_pattern = function | Tacexpr.Term t -> <:expr< Tacexpr.Term $mlexpr_of_pattern_ast t$ >> - | Tacexpr.Subterm (ido,t) -> - <:expr< Tacexpr.Subterm $mlexpr_of_option mlexpr_of_ident ido$ $mlexpr_of_pattern_ast t$ >> + | Tacexpr.Subterm (b,ido,t) -> + <:expr< Tacexpr.Subterm $mlexpr_of_bool b$ $mlexpr_of_option mlexpr_of_ident ido$ $mlexpr_of_pattern_ast t$ >> let mlexpr_of_match_context_hyps = function | Tacexpr.Hyp (id,l) -> let f = mlexpr_of_located mlexpr_of_name in <:expr< Tacexpr.Hyp $f id$ $mlexpr_of_match_pattern l$ >> + | Tacexpr.Def (id,v,l) -> + let f = mlexpr_of_located mlexpr_of_name in + <:expr< Tacexpr.Def $f id$ $mlexpr_of_match_pattern v$ $mlexpr_of_match_pattern l$ >> let mlexpr_of_match_rule f = function | Tacexpr.Pat (l,mp,t) -> <:expr< Tacexpr.Pat $mlexpr_of_list mlexpr_of_match_context_hyps l$ $mlexpr_of_match_pattern mp$ $f t$ >> @@ -300,8 +308,8 @@ let rec mlexpr_of_atomic_tactic = function <:expr< Tacexpr.TacExactNoCheck $mlexpr_of_constr c$ >> | Tacexpr.TacVmCastNoCheck c -> <:expr< Tacexpr.TacVmCastNoCheck $mlexpr_of_constr c$ >> - | Tacexpr.TacApply (b,false,cb) -> - <:expr< Tacexpr.TacApply $mlexpr_of_bool b$ False $mlexpr_of_list mlexpr_of_constr_with_binding cb$ >> + | Tacexpr.TacApply (b,false,cb,None) -> + <:expr< Tacexpr.TacApply $mlexpr_of_bool b$ False $mlexpr_of_list mlexpr_of_constr_with_binding cb$ None >> | Tacexpr.TacElim (false,cb,cbo) -> let cb = mlexpr_of_constr_with_binding cb in let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in @@ -337,7 +345,7 @@ let rec mlexpr_of_atomic_tactic = function | Tacexpr.TacCut c -> <:expr< Tacexpr.TacCut $mlexpr_of_constr c$ >> | Tacexpr.TacAssert (t,ipat,c) -> - let ipat = mlexpr_of_located mlexpr_of_intro_pattern ipat in + let ipat = mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) ipat in <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ $mlexpr_of_constr c$ >> | Tacexpr.TacGeneralize cl -> @@ -480,6 +488,8 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function | Tacexpr.TacArg (Tacexpr.MetaIdArg (_,true,id)) -> anti loc id | Tacexpr.TacArg t -> <:expr< Tacexpr.TacArg $mlexpr_of_tactic_arg t$ >> + | Tacexpr.TacComplete t -> + <:expr< Tacexpr.TacComplete $mlexpr_of_tactic t$ >> | _ -> failwith "Quotation of tactic expressions: TODO" and mlexpr_of_tactic_arg = function diff --git a/parsing/search.ml b/parsing/search.ml index c6ff4c04..8b1551b6 100644 --- a/parsing/search.ml +++ b/parsing/search.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: search.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: search.ml 11739 2009-01-02 19:33:19Z herbelin $ *) open Pp open Util @@ -165,15 +165,6 @@ let raw_search_rewrite extra_filter display_function pattern = (pattern_filter (mk_rewrite_pattern2 gref_eq pattern) s a c)) && extra_filter s a c) display_function gref_eq -(* - ; - filtered_search - (fun s a c -> - ((pattern_filter (mk_rewrite_pattern1 gref_eqT pattern) s a c) || - (pattern_filter (mk_rewrite_pattern2 gref_eqT pattern) s a c)) - && extra_filter s a c) - display_function gref_eqT -*) let text_pattern_search extra_filter = raw_pattern_search extra_filter plain_display @@ -204,17 +195,17 @@ let gen_filtered_search filter_function display_function = let name_of_reference ref = string_of_id (id_of_global ref) type glob_search_about_item = - | GlobSearchRef of global_reference + | GlobSearchSubPattern of constr_pattern | GlobSearchString of string let search_about_item (itemref,typ) = function - | GlobSearchRef ref -> Termops.occur_term (constr_of_global ref) typ + | GlobSearchSubPattern pat -> is_matching_appsubterm ~closed:false pat typ | GlobSearchString s -> string_string_contains (name_of_reference itemref) s let raw_search_about filter_modules display_function l = let filter ref' env typ = filter_modules ref' env typ && - List.for_all (search_about_item (ref',typ)) l && + List.for_all (fun (b,i) -> b = search_about_item (ref',typ) i) l && not (string_string_contains (name_of_reference ref') "_subproof") in gen_filtered_search filter display_function diff --git a/parsing/search.mli b/parsing/search.mli index 8ee708bc..7d12d26f 100644 --- a/parsing/search.mli +++ b/parsing/search.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: search.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id: search.mli 11739 2009-01-02 19:33:19Z herbelin $ i*) open Pp open Names @@ -19,13 +19,14 @@ open Nametab (*s Search facilities. *) type glob_search_about_item = - | GlobSearchRef of global_reference + | GlobSearchSubPattern of constr_pattern | GlobSearchString of string val search_by_head : global_reference -> dir_path list * bool -> unit val search_rewrite : constr_pattern -> dir_path list * bool -> unit val search_pattern : constr_pattern -> dir_path list * bool -> unit -val search_about : glob_search_about_item list -> dir_path list * bool -> unit +val search_about : + (bool * glob_search_about_item) list -> dir_path list * bool -> unit (* The filtering function that is by standard search facilities. It can be passed as argument to the raw search functions. @@ -46,4 +47,4 @@ val raw_search_rewrite : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> constr_pattern -> unit val raw_search_about : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> - glob_search_about_item list -> unit + (bool * glob_search_about_item) list -> unit diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 index 08feb17a..a7b27e21 100644 --- a/parsing/vernacextend.ml4 +++ b/parsing/vernacextend.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) -(* $Id: vernacextend.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: vernacextend.ml4 11622 2008-11-23 08:45:56Z herbelin $ *) open Util open Genarg @@ -118,6 +118,9 @@ EXTEND [ [ e = LIDENT; "("; s = LIDENT; ")" -> let t, g = Q_util.interp_entry_name loc e "" in VernacNonTerm (loc, t, g, Some s) + | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> + let t, g = Q_util.interp_entry_name loc e sep in + VernacNonTerm (loc, t, g, Some s) | s = STRING -> VernacTerm s ] ] diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 9482bf92..52b73535 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: cases.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: cases.ml 11708 2008-12-20 10:50:20Z msozeau $ *) open Util open Names @@ -150,8 +150,11 @@ let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) = then (* The body of pat is not needed to type j - see *) (* insert_aliases - and both deppat and nondeppat have the *) - (* same type, then one can freely substitute one by the other *) - subst1 nondeppat j.uj_val + (* same type, then one can freely substitute one by the other. *) + (* We use nondeppat only if it's a Rel to preserve sharing. *) + if isRel nondeppat then + subst1 nondeppat j.uj_val + else subst1 deppat j.uj_val else (* The body of pat is not needed to type j but its value *) (* is dependent in the type of j; our choice is to *) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 323cd06f..58369811 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: evarconv.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: evarconv.ml 11745 2009-01-04 18:43:08Z herbelin $ *) open Pp open Util @@ -164,10 +164,9 @@ let rec evar_conv_x env evd pbty term1 term2 = (* Maybe convertible but since reducing can erase evars which [evar_apprec] could have found, we do it only if the terms are free of evar. Note: incomplete heuristic... *) - if is_ground_term evd term1 && is_ground_term evd term2 & - is_fconv pbty env (evars_of evd) term1 term2 - then - (evd,true) + if is_ground_term evd term1 && is_ground_term evd term2 + && is_ground_env evd env + then (evd, is_fconv pbty env (evars_of evd) term1 term2) else let term1 = apprec_nohdbeta env evd term1 in let term2 = apprec_nohdbeta env evd term2 in @@ -211,7 +210,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = | Flexible ev1, MaybeFlexible flex2 -> let f1 i = if - is_unification_pattern_evar env ev1 l1 & + is_unification_pattern_evar env ev1 l1 (applist appr2) & not (occur_evar (fst ev1) (applist appr2)) then (* Miller-Pfenning's patterns unification *) @@ -243,7 +242,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = | MaybeFlexible flex1, Flexible ev2 -> let f1 i = if - is_unification_pattern_evar env ev2 l2 & + is_unification_pattern_evar env ev2 l2 (applist appr1) & not (occur_evar (fst ev2) (applist appr1)) then (* Miller-Pfenning's patterns unification *) @@ -311,7 +310,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = | Flexible ev1, Rigid _ -> if - is_unification_pattern_evar env ev1 l1 & + is_unification_pattern_evar env ev1 l1 (applist appr2) & not (occur_evar (fst ev1) (applist appr2)) then (* Miller-Pfenning's patterns unification *) @@ -326,7 +325,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = | Rigid _, Flexible ev2 -> if - is_unification_pattern_evar env ev2 l2 & + is_unification_pattern_evar env ev2 l2 (applist appr1) & not (occur_evar (fst ev2) (applist appr1)) then (* Miller-Pfenning's patterns unification *) @@ -514,15 +513,15 @@ let apply_conversion_problem_heuristic env evd pbty t1 t2 = let (term1,l1 as appr1) = decompose_app t1 in let (term2,l2 as appr2) = decompose_app t2 in match kind_of_term term1, kind_of_term term2 with - | Evar (evk1,args1), (Rel _|Var _) when l1 = [] & l2 = [] -> + | Evar (evk1,args1), (Rel _|Var _) when l1 = [] & l2 = [] + & array_for_all (fun a -> a = term2 or isEvar a) args1 -> (* The typical kind of constraint coming from pattern-matching return type inference *) - assert (array_for_all (fun a -> a = term2 or isEvar a) args1); choose_less_dependent_instance evk1 evd term2 args1, true - | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = [] -> + | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = [] + & array_for_all (fun a -> a = term1 or isEvar a) args2 -> (* The typical kind of constraint coming from pattern-matching return type inference *) - assert (array_for_all ((=) term1) args2); choose_less_dependent_instance evk2 evd term1 args2, true | Evar ev1,_ when List.length l1 <= List.length l2 -> (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *) diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 130e23b8..b418f996 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: evarutil.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: evarutil.ml 11819 2009-01-20 20:04:50Z herbelin $ *) open Util open Pp @@ -258,13 +258,19 @@ let e_new_evar evdref env ?(src=(dummy_loc,InternalHole)) ?filter ty = * operations on the evar constraints * *------------------------------------*) +let is_pattern inst = + array_for_all (fun a -> isRel a || isVar a) inst && + array_distinct inst + (* Pb: defined Rels and Vars should not be considered as a pattern... *) +(* let is_pattern inst = let rec is_hopat l = function [] -> true | t :: tl -> (isRel t or isVar t) && not (List.mem t l) && is_hopat (t::l) tl in is_hopat [] (Array.to_list inst) +*) let evar_well_typed_body evd ev evi body = try @@ -431,7 +437,7 @@ let rec check_and_clear_in_constr evdref err ids c = has dependencies in another hyp of the context of ev and transitively remember the dependency *) match List.filter (fun (id,_) -> occur_var_in_decl (Global.env()) id h) ri with - | rid' :: _ -> (hy,ar,(rid,List.assoc rid ri)::ri) + | (_,id') :: _ -> (hy,ar,(rid,id')::ri) | _ -> (* No dependency at all, we can keep this ev's context hyp *) (h::hy,a::ar,ri)) @@ -484,24 +490,42 @@ let clear_hyps_in_evi evdref hyps concl ids = dependencies in variables are canonically associated to the most ancient variable in its family of aliased variables *) -let rec expand_var env x = match kind_of_term x with +let expand_var_once env x = match kind_of_term x with | Rel n -> - begin try match pi2 (lookup_rel n env) with - | Some t when isRel t -> expand_var env (lift n t) - | _ -> x - with Not_found -> x + begin match pi2 (lookup_rel n env) with + | Some t when isRel t or isVar t -> lift n t + | _ -> raise Not_found end | Var id -> begin match pi2 (lookup_named id env) with - | Some t when isVar t -> expand_var env t - | _ -> x + | Some t when isVar t -> t + | _ -> raise Not_found end - | _ -> x + | _ -> + raise Not_found + +let rec expand_var_at_least_once env x = + let t = expand_var_once env x in + try expand_var_at_least_once env t + with Not_found -> t + +let expand_var env x = + try expand_var_at_least_once env x with Not_found -> x + +let expand_var_opt env x = + try Some (expand_var_at_least_once env x) with Not_found -> None let rec expand_vars_in_term env t = match kind_of_term t with | Rel _ | Var _ -> expand_var env t | _ -> map_constr_with_full_binders push_rel expand_vars_in_term env t +let rec expansions_of_var env x = + try + let t = expand_var_once env x in + t :: expansions_of_var env t + with Not_found -> + [x] + (* [find_projectable_vars env sigma y subst] finds all vars of [subst] * that project on [y]. It is able to find solutions to the following * two kinds of problems: @@ -540,16 +564,16 @@ type evar_projection = | ProjectVar | ProjectEvar of existential * evar_info * identifier * evar_projection -let rec find_projectable_vars env sigma y subst = +let rec find_projectable_vars with_evars env sigma y subst = let is_projectable (id,(idc,y')) = let y' = whd_evar sigma y' in if y = y' or expand_var env y = expand_var env y' then (idc,(y'=y,(id,ProjectVar))) - else if isEvar y' then + else if with_evars & isEvar y' then let (evk,argsv as t) = destEvar y' in let evi = Evd.find sigma evk in let subst = make_projectable_subst sigma evi argsv in - let l = find_projectable_vars env sigma y subst in + let l = find_projectable_vars with_evars env sigma y subst in match l with | [id',p] -> (idc,(true,(id,ProjectEvar (t,evi,id',p)))) | _ -> failwith "" @@ -568,7 +592,7 @@ let filter_solution = function | [id,p] -> (mkVar id, p) let project_with_effects env sigma effects t subst = - let c, p = filter_solution (find_projectable_vars env sigma t subst) in + let c, p = filter_solution (find_projectable_vars false env sigma t subst) in effects := p :: !effects; c @@ -690,8 +714,8 @@ let do_restrict_hyps_virtual evd evk filter = unsolvable. Computing whether y is erasable or not may be costly and the interest for this early detection in practice is not obvious. We let - it for future work. Anyway, thanks to the use of filters, the whole - context remains consistent. *) + it for future work. In any case, thanks to the use of filters, the whole + (unrestricted) context remains consistent. *) let evi = Evd.find (evars_of evd) evk in let env = evar_unfiltered_env evi in let oldfilter = evar_filter evi in @@ -822,7 +846,7 @@ let rec invert_definition env evd (evk,argsv as ev) rhs = let project_variable t = (* Evar/Var problem: unifiable iff variable projectable from ev subst *) try - let sols = find_projectable_vars env (evars_of !evdref) t subst in + let sols = find_projectable_vars true env (evars_of !evdref) t subst in let c, p = filter_solution sols in let ty = lazy (Retyping.get_type_of env (evars_of !evdref) t) in let evd = do_projection_effects evar_define env ty !evdref p in @@ -833,7 +857,9 @@ let rec invert_definition env evd (evk,argsv as ev) rhs = | NotUnique -> if not !progress then raise NotEnoughInformationToProgress; (* No unique projection but still restrict to where it is possible *) - let filter = array_map_to_list (fun c -> isEvar c or c = t) argsv in + let ts = expansions_of_var env t in + let test c = isEvar c or List.mem c ts in + let filter = array_map_to_list test argsv in let args' = filter_along (fun x -> x) filter argsv in let evd,evar = do_restrict_hyps_virtual !evdref evk filter in let evk',_ = destEvar evar in @@ -891,6 +917,12 @@ let rec invert_definition env evd (evk,argsv as ev) rhs = * context "hyps" and not referring to itself. *) +and occur_existential evm c = + let rec occrec c = match kind_of_term c with + | Evar (e, _) -> if not (is_defined evm e) then raise Occur + | _ -> iter_constr occrec c + in try occrec c; false with Occur -> true + and evar_define env (evk,_ as ev) rhs evd = try let (evd',body) = invert_definition env evd ev rhs in @@ -934,6 +966,13 @@ let has_undefined_evars evd t = let is_ground_term evd t = not (has_undefined_evars 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) + let head_evar = let rec hrec c = match kind_of_term c with | Evar (evk,_) -> evk @@ -948,16 +987,50 @@ let head_evar = that we don't care whether args itself contains Rel's or even Rel's distinct from the ones in l *) -let is_unification_pattern_evar env (_,args) l = - let l' = Array.to_list args @ l in - let l' = List.map (expand_var env) l' in - List.for_all (fun a -> isRel a or isVar a) l' & list_distinct l' - -let is_unification_pattern env f l = +let rec expand_and_check_vars env = function + | [] -> [] + | a::l -> + if isRel a or isVar a then + let l = expand_and_check_vars env l in + match expand_var_opt env a with + | None -> a :: l + | Some a' when isRel a' or isVar a' -> list_add_set a' l + | _ -> raise Exit + else + raise Exit + +let is_unification_pattern_evar env (_,args) l t = + List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) + && + let l' = Array.to_list args @ l in + let l'' = try Some (expand_and_check_vars env l') with Exit -> None in + match l'' with + | Some l -> + let deps = + 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 = free_rels t in + let fv_ids = global_vars env t in + List.filter (fun c -> + match kind_of_term c with + | Var id -> List.mem id fv_ids + | Rel n -> Intset.mem n fv_rels + | _ -> assert false) l in + list_distinct deps + | None -> false + +let is_unification_pattern (env,nb) f l t = match kind_of_term f with - | Meta _ -> array_for_all isRel l & array_distinct l - | Evar ev -> is_unification_pattern_evar env ev (Array.to_list l) - | _ -> false + | Meta _ -> + array_for_all (fun c -> isRel c && destRel c <= nb) l + && array_distinct l + | Evar ev -> + is_unification_pattern_evar env ev (Array.to_list l) t + | _ -> + false (* From a unification problem "?X l1 = term1 l2" such that l1 is made of distinct rel's, build "\x1...xn.(term1 l2)" (patterns unification) *) @@ -1045,16 +1118,47 @@ let solve_simple_eqn conv_algo env evd (pbty,(evk1,args1 as ev1),t2) = then solve_evar_evar evar_define env evd ev1 ev2 else add_conv_pb (pbty,env,mkEvar ev1,t2) evd | _ -> - evar_define env ev1 t2 evd in + let evd = evar_define env ev1 t2 evd in + let evm = evars_of evd in + let evi = Evd.find evm evk1 in + if occur_existential evm evi.evar_concl then + let evenv = evar_env evi in + let evc = nf_isevar evd evi.evar_concl in + let body = match evi.evar_body with Evar_defined b -> b | Evar_empty -> assert false in + let ty = nf_isevar evd (Retyping.get_type_of_with_meta evenv evm (metas_of evd) body) in + add_conv_pb (Reduction.CUMUL,evenv,ty,evc) evd + else evd + in let (evd,pbs) = extract_changed_conv_pbs evd status_changed in - List.fold_left - (fun (evd,b as p) (pbty,env,t1,t2) -> - if b then conv_algo env evd pbty t1 t2 else p) (evd,true) - pbs + List.fold_left + (fun (evd,b as p) (pbty,env,t1,t2) -> + if b then conv_algo env evd pbty t1 t2 else p) (evd,true) + pbs with e when precatchable_exception e -> (evd,false) - +let evars_of_term c = + let rec evrec acc c = + match kind_of_term c with + | Evar (n, _) -> Intset.add n acc + | _ -> fold_constr evrec acc c + in + evrec Intset.empty c + +let evars_of_named_context nc = + List.fold_right (fun (_, b, t) s -> + Option.fold_left (fun s t -> + Intset.union s (evars_of_term t)) + s b) nc Intset.empty + +let evars_of_evar_info evi = + Intset.union (evars_of_term evi.evar_concl) + (Intset.union + (match evi.evar_body with + | Evar_empty -> Intset.empty + | Evar_defined b -> evars_of_term b) + (evars_of_named_context (named_context_of_val evi.evar_hyps))) + (* [check_evars] fails if some unresolved evar remains *) (* it assumes that the defined existentials have already been substituted *) diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index ca446c01..a687fdf0 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: evarutil.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: evarutil.mli 11745 2009-01-04 18:43:08Z herbelin $ i*) (*i*) open Util @@ -73,6 +73,7 @@ val non_instantiated : evar_map -> (evar * evar_info) list (* Unification utils *) val is_ground_term : evar_defs -> constr -> bool +val is_ground_env : evar_defs -> env -> bool val solve_refl : (env -> evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool) -> env -> evar_defs -> existential_key -> constr array -> constr array -> @@ -90,10 +91,16 @@ val define_evar_as_product : evar_defs -> existential -> evar_defs * types val define_evar_as_lambda : evar_defs -> existential -> evar_defs * types val define_evar_as_sort : evar_defs -> existential -> evar_defs * sorts -val is_unification_pattern_evar : env -> existential -> constr list -> bool -val is_unification_pattern : env -> constr -> constr array -> bool +val is_unification_pattern_evar : env -> existential -> constr list -> + constr -> bool +val is_unification_pattern : env * int -> constr -> constr array -> + constr -> bool val solve_pattern_eqn : env -> constr list -> constr -> constr +val evars_of_term : constr -> Intset.t +val evars_of_named_context : named_context -> Intset.t +val evars_of_evar_info : evar_info -> Intset.t + (***********************************************************) (* Value/Type constraints *) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index bf3cd623..af070d7e 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: evd.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: evd.ml 11865 2009-01-28 17:34:30Z herbelin $ *) open Pp open Util @@ -300,6 +300,9 @@ let is_defined (sigma,_) = is_defined sigma let existential_value (sigma,_) = existential_value sigma let existential_type (sigma,_) = existential_type sigma let existential_opt_value (sigma,_) = existential_opt_value sigma +let eq_evar_map x y = x == y || + (Evarmap.equal eq_evar_info (fst x) (fst y) && + UniverseMap.equal (=) (snd x) (snd y)) let merge e e' = fold (fun n v sigma -> add sigma n v) e' e @@ -400,10 +403,12 @@ let metamap_to_list m = (*************************) (* Unification state *) +type obligation_definition_status = Define of bool | Expand + type hole_kind = | ImplicitArg of global_reference * (int * identifier option) | BinderType of name - | QuestionMark of bool + | QuestionMark of obligation_definition_status | CasesType | InternalHole | TomatchTypeParameter of inductive * int diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 5810f93d..b9cb2142 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: evd.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: evd.mli 11865 2009-01-28 17:34:30Z herbelin $ i*) (*i*) open Util @@ -52,6 +52,7 @@ val evar_unfiltered_env : evar_info -> env val evar_env : evar_info -> env type evar_map +val eq_evar_map : evar_map -> evar_map -> bool val empty : evar_map @@ -166,11 +167,16 @@ val empty_evar_defs : evar_defs val evars_of : evar_defs -> evar_map val evars_reset_evd : evar_map -> evar_defs -> evar_defs +(* Should the obligation be defined (opaque or transparent (default)) or + defined transparent and expanded in the term? *) + +type obligation_definition_status = Define of bool | Expand + (* Evars *) type hole_kind = | ImplicitArg of global_reference * (int * identifier option) | BinderType of name - | QuestionMark of bool (* Can it be turned into an obligation ? *) + | QuestionMark of obligation_definition_status | CasesType | InternalHole | TomatchTypeParameter of inductive * int diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index b4b8f0b8..d3123eb6 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: indrec.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: indrec.ml 11735 2009-01-02 17:22:31Z herbelin $ *) open Pp open Util @@ -29,8 +29,7 @@ open Sign (* Errors related to recursors building *) type recursion_scheme_error = - | NotAllowedCaseAnalysis of bool * sorts * inductive - | BadInduction of bool * identifier * sorts + | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive | NotMutualInScheme of inductive * inductive exception RecursionSchemeError of recursion_scheme_error @@ -57,8 +56,7 @@ let mis_make_case_com depopt env sigma ind (mib,mip as specif) kind = if not (List.mem kind (elim_sorts specif)) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis - (dep,(new_sort_in_family kind),ind))); + (NotAllowedCaseAnalysis (false,new_sort_in_family kind,ind))); let ndepar = mip.mind_nrealargs + 1 in @@ -502,10 +500,10 @@ let instantiate_type_indrec_scheme sort npars term = let check_arities listdepkind = let _ = List.fold_left (fun ln ((_,ni as mind),mibi,mipi,dep,kind) -> - let id = mipi.mind_typename in let kelim = elim_sorts (mibi,mipi) in if not (List.exists ((=) kind) kelim) then raise - (RecursionSchemeError (BadInduction (dep,id,new_sort_in_family kind))) + (RecursionSchemeError + (NotAllowedCaseAnalysis (true,new_sort_in_family kind,mind))) else if List.mem ni ln then raise (RecursionSchemeError (NotMutualInScheme (mind,mind))) else ni::ln) @@ -593,7 +591,8 @@ let lookup_eliminator ind_sp s = errorlabstrm "default_elim" (strbrk "Cannot find the elimination combinator " ++ pr_id id ++ strbrk ", the elimination of the inductive definition " ++ - pr_id id ++ strbrk " on sort " ++ pr_sort_family s ++ + pr_global_env Idset.empty (IndRef ind_sp) ++ + strbrk " on sort " ++ pr_sort_family s ++ strbrk " is probably not allowed.") diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index 6f177474..102c7c7f 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: indrec.mli 9831 2007-05-17 18:55:42Z herbelin $ i*) +(*i $Id: indrec.mli 11562 2008-11-09 11:30:10Z herbelin $ i*) (*i*) open Names @@ -20,8 +20,7 @@ open Evd (* Errors related to recursors building *) type recursion_scheme_error = - | NotAllowedCaseAnalysis of bool * sorts * inductive - | BadInduction of bool * identifier * sorts + | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive | NotMutualInScheme of inductive * inductive exception RecursionSchemeError of recursion_scheme_error diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 127cd0f2..9f8c06da 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: inductiveops.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: inductiveops.ml 11436 2008-10-07 13:56:55Z barras $ *) open Util open Names @@ -392,6 +392,58 @@ let arity_of_case_predicate env (ind,params) dep k = let concl = if dep then mkArrow mind (mkSort k) else mkSort k in it_mkProd_or_LetIn concl arsign +(***********************************************) +(* 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 Constraint.empty)) + 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. *) +let rec instantiate_universes env scl is = function + | (_,Some _,_ as d)::sign, exp -> + d :: instantiate_universes env scl is (sign, exp) + | d::sign, None::exp -> + d :: instantiate_universes env scl is (sign, exp) + | (na,None,ty)::sign, Some u::exp -> + let ctx,_ = Reduction.dest_arity env ty in + let s = + if is_constrained is u then + scl (* constrained sort: replace by scl *) + else + (* unconstriained sort: replace by fresh universe *) + new_Type_sort() in + (na,None,mkArity(ctx,s)):: instantiate_universes env scl is (sign, exp) + | sign, [] -> sign (* Uniform parameters are exhausted *) + | [], _ -> assert false + +(* Does not deal with universes, but only with Set/Type distinction *) +let type_of_inductive_knowing_conclusion env mip conclty = + match mip.mind_arity with + | Monomorphic s -> + s.mind_user_arity + | Polymorphic ar -> + let _,scl = Reduction.dest_arity env conclty in + let ctx = List.rev mip.mind_arity_ctxt in + let ctx = + instantiate_universes + env scl ar.poly_level (ctx,ar.poly_param_levels) in + mkArity (List.rev ctx,scl) + (***********************************************) (* Guard condition *) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 1d24659c..1cf940cb 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: inductiveops.mli 11301 2008-08-04 19:41:18Z herbelin $ i*) +(*i $Id: inductiveops.mli 11436 2008-10-07 13:56:55Z barras $ i*) open Names open Term @@ -112,6 +112,11 @@ val make_case_info : env -> inductive -> case_style -> case_info val make_default_case_info : env -> case_style -> inductive -> case_info i*) +(********************) + +val type_of_inductive_knowing_conclusion : + env -> one_inductive_body -> types -> types + (********************) val control_only_guard : env -> types -> unit diff --git a/pretyping/matching.ml b/pretyping/matching.ml index d066a58d..93bac98e 100644 --- a/pretyping/matching.ml +++ b/pretyping/matching.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: matching.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: matching.ml 11735 2009-01-02 17:22:31Z herbelin $ *) (*i*) open Util @@ -44,15 +44,37 @@ open Pattern *) +type bound_ident_map = (identifier * identifier) list + exception PatternMatchingFailure -let constrain (n,m) sigma = - if List.mem_assoc n sigma then - if eq_constr m (List.assoc n sigma) then sigma +let constrain (n,m) (names,terms as subst) = + try + if eq_constr m (List.assoc n terms) then subst else raise PatternMatchingFailure - else - (n,m)::sigma - + with + Not_found -> + if List.mem_assoc n names then + Flags.if_verbose Pp.warning + ("Collision between bound variable "^string_of_id n^ + " and a metavariable of same name."); + (names,(n,m)::terms) + +let add_binders na1 na2 (names,terms as subst) = + match na1, na2 with + | Name id1, Name id2 -> + if List.mem_assoc id1 names then + (Flags.if_verbose Pp.warning + ("Collision between bound variables of name"^string_of_id id1); + (names,terms)) + else + (if List.mem_assoc id1 terms then + Flags.if_verbose Pp.warning + ("Collision between bound variable "^string_of_id id1^ + " and another bound variable of same name."); + ((id1,id2)::names,terms)); + | _ -> subst + let build_lambda toabstract stk (m : constr) = let rec buildrec m p_0 p_1 = match p_0,p_1 with | (_, []) -> m @@ -77,7 +99,10 @@ let same_case_structure (_,cs1,ind,_) ci2 br1 br2 = | None -> cs1 = ci2.ci_cstr_nargs let matches_core convert allow_partial_app pat c = - let rec sorec stk sigma p t = + let conv = match convert with + | None -> eq_constr + | Some (env,sigma) -> is_conv env sigma in + let rec sorec stk subst p t = let cT = strip_outer_cast t in match p,kind_of_term cT with | PSoApp (n,args),m -> @@ -89,7 +114,7 @@ let matches_core convert allow_partial_app pat c = args in let frels = Intset.elements (free_rels cT) in if list_subset frels relargs then - constrain (n,build_lambda relargs stk cT) sigma + constrain (n,build_lambda relargs stk cT) subst else raise PatternMatchingFailure @@ -97,66 +122,63 @@ let matches_core convert allow_partial_app pat c = let depth = List.length stk in if depth = 0 then (* Optimisation *) - constrain (n,cT) sigma + constrain (n,cT) subst else let frels = Intset.elements (free_rels cT) in if List.for_all (fun i -> i > depth) frels then - constrain (n,lift (-depth) cT) sigma + constrain (n,lift (-depth) cT) subst else raise PatternMatchingFailure - | PMeta None, m -> sigma + | PMeta None, m -> subst - | PRef (VarRef v1), Var v2 when v1 = v2 -> sigma + | PRef (VarRef v1), Var v2 when v1 = v2 -> subst - | PVar v1, Var v2 when v1 = v2 -> sigma + | PVar v1, Var v2 when v1 = v2 -> subst - | PRef ref, _ when constr_of_global ref = cT -> sigma + | PRef ref, _ when conv (constr_of_global ref) cT -> subst - | PRel n1, Rel n2 when n1 = n2 -> sigma + | PRel n1, Rel n2 when n1 = n2 -> subst - | PSort (RProp c1), Sort (Prop c2) when c1 = c2 -> sigma + | PSort (RProp c1), Sort (Prop c2) when c1 = c2 -> subst - | PSort (RType _), Sort (Type _) -> sigma + | PSort (RType _), Sort (Type _) -> subst - | PApp (p, [||]), _ -> sorec stk sigma p t + | PApp (p, [||]), _ -> sorec stk subst p t | PApp (PApp (h, a1), a2), _ -> - sorec stk sigma (PApp(h,Array.append a1 a2)) t + sorec stk subst (PApp(h,Array.append a1 a2)) t | PApp (PMeta (Some n),args1), App (c2,args2) when allow_partial_app -> let p = Array.length args2 - Array.length args1 in if p>=0 then let args21, args22 = array_chop p args2 in - let sigma = + let subst = let depth = List.length stk in let c = mkApp(c2,args21) in let frels = Intset.elements (free_rels c) in if List.for_all (fun i -> i > depth) frels then - constrain (n,lift (-depth) c) sigma + constrain (n,lift (-depth) c) subst else raise PatternMatchingFailure in - array_fold_left2 (sorec stk) sigma args1 args22 + array_fold_left2 (sorec stk) subst args1 args22 else raise PatternMatchingFailure | PApp (c1,arg1), App (c2,arg2) -> - (try array_fold_left2 (sorec stk) (sorec stk sigma c1 c2) arg1 arg2 + (try array_fold_left2 (sorec stk) (sorec stk subst c1 c2) arg1 arg2 with Invalid_argument _ -> raise PatternMatchingFailure) | PProd (na1,c1,d1), Prod(na2,c2,d2) -> - sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2 + sorec ((na2,c2)::stk) + (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> - sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2 + sorec ((na2,c2)::stk) + (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2 | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) -> - sorec ((na2,t2)::stk) (sorec stk sigma c1 c2) d1 d2 - - | PRef (ConstRef _ as ref), _ when convert <> None -> - let (env,evars) = Option.get convert in - let c = constr_of_global ref in - if is_conv env evars c cT then sigma - else raise PatternMatchingFailure + sorec ((na2,t2)::stk) + (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> let ctx,b2 = decompose_lam_n_assum ci.ci_cstr_nargs.(0) b2 in @@ -167,118 +189,128 @@ let matches_core convert allow_partial_app pat c = let s = List.fold_left (fun l (na,_,t) -> (na,t)::l) stk ctx in let s' = List.fold_left (fun l (na,_,t) -> (na,t)::l) stk ctx' in let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in - sorec s' (sorec s (sorec stk sigma a1 a2) b1 b2) b1' b2' + sorec s' (sorec s (sorec stk subst a1 a2) b1 b2) b1' b2' else raise PatternMatchingFailure | PCase (ci1,p1,a1,br1), Case (ci2,p2,a2,br2) -> if same_case_structure ci1 ci2 br1 br2 then array_fold_left2 (sorec stk) - (sorec stk (sorec stk sigma a1 a2) p1 p2) br1 br2 + (sorec stk (sorec stk subst a1 a2) p1 p2) br1 br2 else raise PatternMatchingFailure - | PFix c1, Fix _ when eq_constr (mkFix c1) cT -> sigma - | PCoFix c1, CoFix _ when eq_constr (mkCoFix c1) cT -> sigma + | PFix c1, Fix _ when eq_constr (mkFix c1) cT -> subst + | PCoFix c1, CoFix _ when eq_constr (mkCoFix c1) cT -> subst | _ -> raise PatternMatchingFailure - in - Sort.list (fun (a,_) (b,_) -> a a closed0 c) (fst mres)) then - raise PatternMatchingFailure; - if nocc = 0 then mres - else raise (NextOccurrence nocc) - -let special_meta = (-1) +let authorized_occ partial_app closed pat c mk_ctx next = + try + let sigma = matches_core None partial_app pat c in + if closed && not (List.for_all (fun (_,c) -> closed0 c) (snd sigma)) + then next () + else sigma, mk_ctx (mkMeta special_meta), next + with + PatternMatchingFailure -> next () (* Tries to match a subterm of [c] with [pat] *) -let rec sub_match nocc pat c = +let sub_match ?(partial_app=false) ?(closed=true) pat c = + let rec aux c mk_ctx next = match kind_of_term c with | Cast (c1,k,c2) -> - (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with - | PatternMatchingFailure -> - let (lm,lc) = try_sub_match nocc pat [c1] in - (lm,mkCast (List.hd lc, k,c2)) - | NextOccurrence nocc -> - let (lm,lc) = try_sub_match (nocc - 1) pat [c1] in - (lm,mkCast (List.hd lc, k,c2))) - | Lambda (x,c1,c2) -> - (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with - | PatternMatchingFailure -> - let (lm,lc) = try_sub_match nocc pat [c1;c2] in - (lm,mkLambda (x,List.hd lc,List.nth lc 1)) - | NextOccurrence nocc -> - let (lm,lc) = try_sub_match (nocc - 1) pat [c1;c2] in - (lm,mkLambda (x,List.hd lc,List.nth lc 1))) + authorized_occ partial_app closed pat c mk_ctx (fun () -> + let mk_ctx lc = mk_ctx (mkCast (List.hd lc, k,c2)) in + try_aux [c1] mk_ctx next) + | Lambda (x,c1,c2) -> + authorized_occ partial_app closed pat c mk_ctx (fun () -> + let mk_ctx lc = mk_ctx (mkLambda (x,List.hd lc,List.nth lc 1)) in + try_aux [c1;c2] mk_ctx next) | Prod (x,c1,c2) -> - (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with - | PatternMatchingFailure -> - let (lm,lc) = try_sub_match nocc pat [c1;c2] in - (lm,mkProd (x,List.hd lc,List.nth lc 1)) - | NextOccurrence nocc -> - let (lm,lc) = try_sub_match (nocc - 1) pat [c1;c2] in - (lm,mkProd (x,List.hd lc,List.nth lc 1))) - | LetIn (x,c1,t2,c2) -> - (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with - | PatternMatchingFailure -> - let (lm,lc) = try_sub_match nocc pat [c1;t2;c2] in - (lm,mkLetIn (x,List.hd lc,List.nth lc 1,List.nth lc 2)) - | NextOccurrence nocc -> - let (lm,lc) = try_sub_match (nocc - 1) pat [c1;t2;c2] in - (lm,mkLetIn (x,List.hd lc,List.nth lc 1,List.nth lc 2))) + authorized_occ partial_app closed pat c mk_ctx (fun () -> + let mk_ctx lc = mk_ctx (mkProd (x,List.hd lc,List.nth lc 1)) in + try_aux [c1;c2] mk_ctx next) + | LetIn (x,c1,t,c2) -> + authorized_occ partial_app closed pat c mk_ctx (fun () -> + let mk_ctx = function [c1;c2] -> mkLetIn (x,c1,t,c2) | _ -> assert false + in try_aux [c1;c2] mk_ctx next) | App (c1,lc) -> - (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with - | PatternMatchingFailure -> - let (lm,le) = try_sub_match nocc pat (c1::(Array.to_list lc)) in - (lm,mkApp (List.hd le, Array.of_list (List.tl le))) - | NextOccurrence nocc -> - let (lm,le) = try_sub_match (nocc - 1) pat (c1::(Array.to_list lc)) in - (lm,mkApp (List.hd le, Array.of_list (List.tl le)))) + authorized_occ partial_app closed pat c mk_ctx (fun () -> + let topdown = true in + if partial_app then + if topdown then + let lc1 = Array.sub lc 0 (Array.length lc - 1) in + let app = mkApp (c1,lc1) in + let mk_ctx = function + | [app';c] -> mk_ctx (mkApp (app',[|c|])) + | _ -> assert false in + try_aux [app;array_last lc] mk_ctx next + else + let rec aux2 app args next = + match args with + | [] -> + let mk_ctx le = + mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in + try_aux (c1::Array.to_list lc) mk_ctx next + | arg :: args -> + let app = mkApp (app,[|arg|]) in + let next () = aux2 app args next in + let mk_ctx ce = mk_ctx (mkApp (ce, Array.of_list args)) in + aux app mk_ctx next in + aux2 c1 (Array.to_list lc) next + else + let mk_ctx le = + mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in + try_aux (c1::Array.to_list lc) mk_ctx next) | Case (ci,hd,c1,lc) -> - (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with - | PatternMatchingFailure -> - let (lm,le) = try_sub_match nocc pat (c1::Array.to_list lc) in - (lm,mkCase (ci,hd,List.hd le,Array.of_list (List.tl le))) - | NextOccurrence nocc -> - let (lm,le) = try_sub_match (nocc - 1) pat (c1::Array.to_list lc) in - (lm,mkCase (ci,hd,List.hd le,Array.of_list (List.tl le)))) + authorized_occ partial_app closed pat c mk_ctx (fun () -> + let mk_ctx le = + mk_ctx (mkCase (ci,hd,List.hd le,Array.of_list (List.tl le))) in + try_aux (c1::Array.to_list lc) mk_ctx next) | Construct _ | Fix _ | Ind _|CoFix _ |Evar _|Const _ | Rel _|Meta _|Var _|Sort _ -> - (try authorized_occ nocc ((matches pat c),mkMeta special_meta) with - | PatternMatchingFailure -> raise (NextOccurrence nocc) - | NextOccurrence nocc -> raise (NextOccurrence (nocc - 1))) - -(* Tries [sub_match] for all terms in the list *) -and try_sub_match nocc pat lc = - let rec try_sub_match_rec nocc pat lacc = function - | [] -> raise (NextOccurrence nocc) - | c::tl -> - (try - let (lm,ce) = sub_match nocc pat c in - (lm,lacc@(ce::tl)) - with - | NextOccurrence nocc -> try_sub_match_rec nocc pat (lacc@[c]) tl) in - try_sub_match_rec nocc pat [] lc - -let match_subterm nocc pat c = - try sub_match nocc pat c - with NextOccurrence _ -> raise PatternMatchingFailure - -let is_matching pat n = - try let _ = matches pat n in true + authorized_occ partial_app closed pat c mk_ctx next + + (* Tries [sub_match] for all terms in the list *) + and try_aux lc mk_ctx next = + let rec try_sub_match_rec lacc = function + | [] -> next () + | c::tl -> + let mk_ctx ce = mk_ctx (List.rev_append lacc (ce::tl)) in + let next () = try_sub_match_rec (c::lacc) tl in + aux c mk_ctx next in + try_sub_match_rec [] lc in + aux c (fun x -> x) (fun () -> raise PatternMatchingFailure) + +type subterm_matching_result = + (bound_ident_map * patvar_map) * constr * (unit -> subterm_matching_result) + +let match_subterm pat c = sub_match pat c + +let match_appsubterm pat c = sub_match ~partial_app:true pat c + +let match_subterm_gen app pat c = sub_match ~partial_app:app pat c + +let is_matching pat c = + try let _ = matches pat c in true + with PatternMatchingFailure -> false + +let is_matching_appsubterm ?(closed=true) pat c = + try let _ = sub_match ~partial_app:true ~closed pat c in true with PatternMatchingFailure -> false -let matches_conv env sigma = matches_core (Some (env,sigma)) false +let matches_conv env sigma c p = + snd (matches_core (Some (env,sigma)) false c p) let is_matching_conv env sigma pat n = try let _ = matches_conv env sigma pat n in true diff --git a/pretyping/matching.mli b/pretyping/matching.mli index e6065c68..b54a17b7 100644 --- a/pretyping/matching.mli +++ b/pretyping/matching.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: matching.mli 6616 2005-01-21 17:18:23Z herbelin $ i*) +(*i $Id: matching.mli 11739 2009-01-02 19:33:19Z herbelin $ i*) (*i*) open Names @@ -22,30 +22,58 @@ exception PatternMatchingFailure val special_meta : metavariable +type bound_ident_map = (identifier * identifier) list + (* [matches pat c] matches [c] against [pat] and returns the resulting assignment of metavariables; it raises [PatternMatchingFailure] if not matchable; bindings are given in increasing order based on the numbers given in the pattern *) val matches : constr_pattern -> constr -> patvar_map -(* [is_matching pat c] just tells if [c] matches against [pat] *) +(* [extended_matches pat c] also returns the names of bound variables + in [c] that matches the bound variables in [pat]; if several bound + variables or metavariables have the same name, the metavariable, + or else the rightmost bound variable, takes precedence *) +val extended_matches : + constr_pattern -> constr -> bound_ident_map * patvar_map +(* [is_matching pat c] just tells if [c] matches against [pat] *) val is_matching : constr_pattern -> constr -> bool (* [matches_conv env sigma] matches up to conversion in environment [(env,sigma)] when constants in pattern are concerned; it raises [PatternMatchingFailure] if not matchable; bindings are given in increasing order based on the numbers given in the pattern *) - val matches_conv :env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map +(* The type of subterm matching results: a substitution + a context + (whose hole is denoted with [special_meta]) + a continuation that + either returns the next matching subterm or raise PatternMatchingFailure *) +type subterm_matching_result = + (bound_ident_map * patvar_map) * constr * (unit -> subterm_matching_result) + (* [match_subterm n pat c] returns the substitution and the context - corresponding to the [n+1]th **closed** subterm of [c] matching [pat]; - It raises PatternMatchingFailure if no such matching exists *) -val match_subterm : int -> constr_pattern -> constr -> patvar_map * constr + corresponding to the first **closed** subterm of [c] matching [pat], and + a continuation that looks for the next matching subterm. + It raises PatternMatchingFailure if no subterm matches the pattern *) +val match_subterm : constr_pattern -> constr -> subterm_matching_result + +(* [match_appsubterm pat c] returns the substitution and the context + corresponding to the first **closed** subterm of [c] matching [pat], + considering application contexts as well. It also returns a + continuation that looks for the next matching subterm. + It raises PatternMatchingFailure if no subterm matches the pattern *) +val match_appsubterm : constr_pattern -> constr -> subterm_matching_result + +(* [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *) +val match_subterm_gen : bool (* true = with app context *) -> + constr_pattern -> constr -> subterm_matching_result + +(* [is_matching_appsubterm pat c] tells if a subterm of [c] matches + against [pat] taking partial subterms into consideration *) +val is_matching_appsubterm : ?closed:bool -> constr_pattern -> constr -> bool (* [is_matching_conv env sigma pat c] tells if [c] matches against [pat] up to conversion for constants in patterns *) - val is_matching_conv : env -> Evd.evar_map -> constr_pattern -> constr -> bool diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index a3246bc8..1cac9011 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: pretyping.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: pretyping.ml 11576 2008-11-10 19:13:15Z msozeau $ *) open Pp open Util @@ -586,7 +586,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in { uj_val = v; uj_type = p } - + | RCases (loc,sty,po,tml,eqns) -> Cases.compile_cases loc sty ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) @@ -605,8 +605,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct (* ... except for Correctness *) let v = mkCast (cj.uj_val, k, tj.utj_val) in { uj_val = v; uj_type = tj.utj_val } - in - inh_conv_coerce_to_tycon loc env evdref cj tycon + in inh_conv_coerce_to_tycon loc env evdref cj tycon | RDynamic (loc,d) -> if (tag d) = "constr" then @@ -657,12 +656,13 @@ module Pretyping_F (Coercion : Coercion.S) = struct | IsType -> (pretype_type empty_valcon env evdref lvar c).utj_val in let evd,_ = consider_remaining_unif_problems env !evdref in - evdref := evd; c' + evdref := evd; + nf_isevar !evdref c' let pretype_gen evdref env lvar kind c = let c = pretype_gen_aux evdref env lvar kind c in evdref := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env !evdref; - nf_evar (evars_of !evdref) c + nf_isevar !evdref c (* TODO: comment faire remonter l'information si le typage a resolu des variables du sigma original. il faudrait que la fonction de typage @@ -691,14 +691,13 @@ module Pretyping_F (Coercion : Coercion.S) = struct let ise_pretype_gen fail_evar sigma env lvar kind c = let evdref = ref (Evd.create_evar_defs sigma) in - let c = pretype_gen evdref env lvar kind c in - let evd,_ = consider_remaining_unif_problems env !evdref in + let c = pretype_gen_aux evdref env lvar kind c in if fail_evar then - let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env evd in + let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env !evdref in let c = Evarutil.nf_isevar evd c in check_evars env Evd.empty evd c; evd, c - else evd, c + else !evdref, c (** Entry points of the high-level type synthesis algorithm *) @@ -716,17 +715,17 @@ module Pretyping_F (Coercion : Coercion.S) = struct let understand_tcc_evars evdref env kind c = pretype_gen evdref env ([],[]) kind c - + let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c = let evd, t = - if resolve_classes then - ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c - else - let evdref = ref (Evd.create_evar_defs sigma) in - let c = pretype_gen_aux evdref env ([],[]) (OfType exptyp) c in - !evdref, nf_isevar !evdref c - in - Evd.evars_of evd, t + let evdref = ref (Evd.create_evar_defs sigma) in + let c = + if resolve_classes then + pretype_gen evdref env ([],[]) (OfType exptyp) c + else + pretype_gen_aux evdref env ([],[]) (OfType exptyp) c + in !evdref, c + in Evd.evars_of evd, t end - + module Default : S = Pretyping_F(Coercion.Default) diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml index 3726b8df..30b62ea8 100644 --- a/pretyping/rawterm.ml +++ b/pretyping/rawterm.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: rawterm.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: rawterm.ml 11576 2008-11-10 19:13:15Z msozeau $ *) (*i*) open Util @@ -219,7 +219,7 @@ let free_rawvars = | RLambda (loc,na,_,ty,c) | RProd (loc,na,_,ty,c) | RLetIn (loc,na,ty,c) -> let vs' = vars bounded vs ty in let bounded' = add_name_to_ids bounded na in - vars bounded' vs' c + vars bounded' vs' c | RCases (loc,sty,rtntypopt,tml,pl) -> let vs1 = vars_option bounded vs rtntypopt in let vs2 = List.fold_left (fun vs (tm,_) -> vars bounded vs tm) vs1 tml in diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 06289434..7c4023b9 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: recordops.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: recordops.ml 11576 2008-11-10 19:13:15Z msozeau $ *) open Util open Pp @@ -32,9 +32,9 @@ open Reductionops projection ou bien une fonction constante (associée à un LetIn) *) type struc_typ = { - s_CONST : identifier; + s_CONST : constructor; s_EXPECTEDPARAM : int; - s_PROJKIND : bool list; + s_PROJKIND : (name * bool) list; s_PROJ : constant option list } let structure_table = ref (Indmap.empty : struc_typ Indmap.t) @@ -61,8 +61,9 @@ let subst_structure (_,subst,((kn,i),id,kl,projs as obj)) = (Option.smartmap (fun kn -> fst (subst_con subst kn))) projs in - if projs' == projs && kn' == kn then obj else - ((kn',i),id,kl,projs') + let id' = fst (subst_constructor subst id) in + if projs' == projs && kn' == kn && id' == id then obj else + ((kn',i),id',kl,projs') let discharge_structure (_,(ind,id,kl,projs)) = Some (Lib.discharge_inductive ind, id, kl, @@ -88,6 +89,10 @@ let find_projection_nparams = function | ConstRef cst -> (Cmap.find cst !projection_table).s_EXPECTEDPARAM | _ -> raise Not_found +let find_projection = function + | ConstRef cst -> Cmap.find cst !projection_table + | _ -> raise Not_found + (************************************************************************) (*s A canonical structure declares "canonical" conversion hints between *) @@ -135,7 +140,7 @@ let canonical_projections () = !object_table [] let keep_true_projections projs kinds = - map_succeed (function (p,true) -> p | _ -> failwith "") + map_succeed (function (p,(_,true)) -> p | _ -> failwith "") (List.combine projs kinds) let cs_pattern_of_constr t = @@ -237,7 +242,7 @@ let check_and_decompose_canonical_structure ref = | Construct (indsp,1) -> indsp | _ -> error_not_structure ref in let s = try lookup_structure indsp with Not_found -> error_not_structure ref in - let ntrue_projs = List.length (List.filter (fun x -> x) s.s_PROJKIND) in + let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref; (sp,indsp) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 74f6a9ce..ea960aa9 100755 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: recordops.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: recordops.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Names @@ -21,8 +21,14 @@ open Library (*s A structure S is a non recursive inductive type with a single constructor (the name of which defaults to Build_S) *) +type struc_typ = { + s_CONST : constructor; + s_EXPECTEDPARAM : int; + s_PROJKIND : (name * bool) list; + s_PROJ : constant option list } + val declare_structure : - inductive * identifier * bool list * constant option list -> unit + inductive * constructor * (name * bool) list * constant option list -> unit (* [lookup_projections isp] returns the projections associated to the inductive path [isp] if it corresponds to a structure, otherwise @@ -32,6 +38,9 @@ val lookup_projections : inductive -> constant option list (* raise [Not_found] if not a projection *) val find_projection_nparams : global_reference -> int +(* raise [Not_found] if not a projection *) +val find_projection : global_reference -> struc_typ + (*s A canonical structure declares "canonical" conversion hints between *) (* the effective components of a structure and the projections of the *) (* structure *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 21e881b9..a1603d69 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: reductionops.ml 11343 2008-09-01 20:55:13Z herbelin $ *) +(* $Id: reductionops.ml 11796 2009-01-18 13:41:39Z herbelin $ *) open Pp open Util @@ -537,6 +537,8 @@ let nf_evar sigma = local_strong (whd_evar sigma) (* lazy reduction functions. The infos must be created for each term *) +(* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add + a [nf_evar] here *) let clos_norm_flags flgs env sigma t = norm_val (create_clos_infos flgs env) (inject (nf_evar sigma t)) @@ -625,8 +627,23 @@ let pb_equal = function let sort_cmp = sort_cmp + +let nf_red_env sigma env = + let nf_decl = function + (x,Some t,ty) -> (x,Some (nf_evar sigma t),ty) + | d -> d in + let sign = named_context env in + let ctxt = rel_context env in + let env = reset_context env in + let env = Sign.fold_named_context + (fun d env -> push_named (nf_decl d) env) ~init:env sign in + Sign.fold_rel_context + (fun d env -> push_rel (nf_decl d) env) ~init:env ctxt + + let test_conversion f env sigma x y = - try let _ = f env (nf_evar sigma x) (nf_evar sigma y) in true + try let _ = + f (nf_red_env sigma env) (nf_evar sigma x) (nf_evar sigma y) in true with NotConvertible -> false let is_conv env sigma = test_conversion Reduction.conv env sigma @@ -652,11 +669,11 @@ let whd_meta metamap c = match kind_of_term c with (* Try to replace all metas. Does not replace metas in the metas' values * Differs from (strong whd_meta). *) let plain_instance s c = - let rec irec u = match kind_of_term u with - | Meta p -> (try List.assoc p s with Not_found -> u) + let rec irec n u = match kind_of_term u with + | Meta p -> (try lift n (List.assoc p s) with Not_found -> u) | App (f,l) when isCast f -> let (f,_,t) = destCast f in - let l' = Array.map irec l in + let l' = Array.map (irec n) l in (match kind_of_term f with | Meta p -> (* Don't flatten application nodes: this is used to extract a @@ -669,12 +686,13 @@ let plain_instance s c = mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l')) | _ -> mkApp (g,l') with Not_found -> mkApp (f,l')) - | _ -> mkApp (irec f,l')) + | _ -> mkApp (irec n f,l')) | Cast (m,_,_) when isMeta m -> - (try List.assoc (destMeta m) s with Not_found -> u) - | _ -> map_constr irec u + (try lift n (List.assoc (destMeta m) s) with Not_found -> u) + | _ -> + map_constr_with_binders succ irec n u in - if s = [] then c else irec c + if s = [] then c else irec 0 c (* [instance] is used for [res_pf]; the call to [local_strong whd_betaiota] has (unfortunately) different subtle side effects: @@ -706,8 +724,8 @@ let plain_instance s c = If a lemma has the type "(fun x => p) t" then rewriting t may fail if the type of the lemma is first beta-reduced (this typically happens when rewriting a single variable and the type of the lemma is obtained - by meta_instance (with empty map) which itself call instance with this - empty map. + by meta_instance (with empty map) which itself calls instance with this + empty map). *) let instance s c = diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 82c2668c..2465bd1e 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: retyping.ml 11077 2008-06-09 11:26:32Z herbelin $ *) +(* $Id: retyping.ml 11778 2009-01-13 13:17:39Z msozeau $ *) open Util open Term @@ -49,7 +49,7 @@ let retype sigma metamap = match kind_of_term cstr with | Meta n -> (try strip_outer_cast (List.assoc n metamap) - with Not_found -> anomaly "type_of: this is not a well-typed term") + with Not_found -> anomaly ("type_of: unknown meta " ^ string_of_int n)) | Rel n -> let (_,_,ty) = lookup_rel n env in lift n ty @@ -111,9 +111,15 @@ let retype sigma metamap = | Cast (c,_, s) when isSort s -> family_of_sort (destSort s) | Sort (Prop c) -> InType | Sort (Type u) -> InType - | Prod (name,t,c2) -> sort_family_of (push_rel (name,None,t) env) c2 + | Prod (name,t,c2) -> + let s2 = sort_family_of (push_rel (name,None,t) env) c2 in + if Environ.engagement env <> Some ImpredicativeSet && + s2 = InSet & sort_family_of env t = InType then InType else s2 + | App(f,args) when isGlobalRef f -> + let t = type_of_global_reference_knowing_parameters env f args in + family_of_sort (sort_of_atomic_type env sigma t args) | App(f,args) -> - family_of_sort (sort_of_atomic_type env sigma (type_of env f) args) + family_of_sort (sort_of_atomic_type env sigma (type_of env f) args) | Lambda _ | Fix _ | Construct _ -> anomaly "sort_of: Not a type (1)" | _ -> family_of_sort (decomp_sort env sigma (type_of env t)) @@ -139,6 +145,20 @@ let get_sort_family_of env sigma c = let _,_,f,_ = retype sigma [] in f env c let type_of_global_reference_knowing_parameters env sigma c args = let _,_,_,f = retype sigma [] in f env c args +let type_of_global_reference_knowing_conclusion env sigma c conclty = + let conclty = nf_evar sigma conclty in + match kind_of_term c with + | Ind ind -> + let (_,mip) = Inductive.lookup_mind_specif env ind in + type_of_inductive_knowing_conclusion env mip conclty + | Const cst -> + let t = constant_type env cst in + (* TODO *) + Typeops.type_of_constant_knowing_parameters env t [||] + | Var id -> type_of_var env id + | Construct cstr -> type_of_constructor env cstr + | _ -> assert false + (* We are outside the kernel: we take fresh universes *) (* to avoid tactics and co to refresh universes themselves *) let get_type_of env sigma c = diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 733cb4b1..ec1fc827 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: retyping.mli 9314 2006-10-29 20:11:08Z herbelin $ i*) +(*i $Id: retyping.mli 11436 2008-10-07 13:56:55Z barras $ i*) (*i*) open Names @@ -37,3 +37,5 @@ val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> constr array -> types +val type_of_global_reference_knowing_conclusion : + env -> evar_map -> constr -> types -> types diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 57fdbb09..88a6f499 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacred.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: tacred.ml 11654 2008-12-03 18:39:40Z barras $ *) open Pp open Util @@ -99,10 +99,11 @@ let reference_value sigma env c = (* One reuses the name of the function after reduction of the fixpoint *) type constant_evaluation = - | EliminationFix of int * (int * (int * constr) list * int) + | EliminationFix of int * int * (int * (int * constr) list * int) | EliminationMutualFix of int * evaluable_reference * - (evaluable_reference option array * (int * (int * constr) list * int)) + ((int*evaluable_reference) option array * + (int * (int * constr) list * int)) | EliminationCases of int | NotAnElimination @@ -171,24 +172,24 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) = | _ -> raise Elimconst) args in - if list_distinct (List.map fst li) then - let k = lv.(i) in - if k < nargs then + if not (list_distinct (List.map fst li)) then + raise Elimconst; + let k = lv.(i) in + if k < nargs then (* Such an optimisation would need eta-expansion let p = destRel (List.nth args k) in EliminationFix (n-p+1,(nbfix,li,n)) *) - EliminationFix (n,(nbfix,li,n)) - else - EliminationFix (n-nargs+lv.(i)+1,(nbfix,li,n)) - else - raise Elimconst + EliminationFix (n,nargs,(nbfix,li,n)) + else + EliminationFix (n-nargs+k+1,nargs,(nbfix,li,n)) (* Heuristic to look if global names are associated to other components of a mutual fixpoint *) let invert_name labs l na0 env sigma ref = function | Name id -> + let minfxargs = List.length l in if na0 <> Name id then let refi = match ref with | EvalRel _ | EvalEvar _ -> None @@ -205,9 +206,10 @@ let invert_name labs l na0 env sigma ref = function let labs',ccl = decompose_lam c in let _, l' = whd_betalet_stack ccl in let labs' = List.map snd labs' in - if labs' = labs & l = l' then Some ref else None + if labs' = labs & l = l' then Some (minfxargs,ref) + else None with Not_found (* Undefined ref *) -> None - else Some ref + else Some (minfxargs,ref) | Anonymous -> None (* Actually, should not occur *) (* [compute_consteval_direct] expand all constant in a whole, but @@ -242,7 +244,7 @@ let compute_consteval_mutual_fix sigma env ref = (match compute_consteval_direct sigma env ref with | NotAnElimination -> (*Above const was eliminable but this not!*) NotAnElimination - | EliminationFix (minarg',infos) -> + | EliminationFix (minarg',minfxargs,infos) -> let refs = Array.map (invert_name labs l names.(i) env sigma ref) names in @@ -263,7 +265,7 @@ let compute_consteval_mutual_fix sigma env ref = let compute_consteval sigma env ref = match compute_consteval_direct sigma env ref with - | EliminationFix (_,(nbfix,_,_)) when nbfix <> 1 -> + | EliminationFix (_,_,(nbfix,_,_)) when nbfix <> 1 -> compute_consteval_mutual_fix sigma env ref | elim -> elim @@ -323,28 +325,107 @@ let make_elim_fun (names,(nbfix,lv,n)) largs = fun i -> match names.(i) with | None -> None - | Some ref -> + | Some (minargs,ref) -> let body = applistc (mkEvalRef ref) la in let g = list_fold_left_i (fun q (* j from comment is n+1-q *) c (ij,tij) -> let subst = List.map (lift (-q)) (list_firstn (n-ij) la) in let tij' = substl (List.rev subst) tij in mkLambda (x,tij',c)) 1 body (List.rev lv) - in Some g + in Some (minargs,g) (* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: do so that the reduction uses this extra information *) -let contract_fix_use_function f +let dummy = mkProp +let vfx = id_of_string"_expanded_fix_" +let vfun = id_of_string"_elimminator_function_" + +(* Mark every occurrence of substituted vars (associated to a function) + as a problem variable: an evar that can be instantiated either by + vfx (expanded fixpoint) or vfun (named function). *) +let substl_with_function subst constr = + let cnt = ref 0 in + let evd = ref Evd.empty in + let minargs = ref Intmap.empty in + let v = Array.of_list subst in + let rec subst_total k c = + match kind_of_term c with + Rel i when k + if i <= k + Array.length v then + match v.(i-k-1) with + | (fx,Some(min,ref)) -> + decr cnt; + evd := Evd.add !evd !cnt + (Evd.make_evar + (val_of_named_context + [(vfx,None,dummy);(vfun,None,dummy)]) + dummy); + minargs := Intmap.add !cnt min !minargs; + lift k (mkEvar(!cnt,[|fx;ref|])) + | (fx,None) -> lift k fx + else mkRel (i - Array.length v) + | _ -> + map_constr_with_binders succ subst_total k c in + let c = subst_total 0 constr in + (c,!evd,!minargs) + +exception Partial + +(* each problem variable that cannot be made totally applied even by + reduction is solved by the expanded fix term. *) +let solve_arity_problem env sigma fxminargs c = + let evm = ref sigma in + let set_fix i = evm := Evd.define !evm i (mkVar vfx) in + let rec check strict c = + let c' = whd_betaiotazeta c in + let (h,rcargs) = decompose_app c' in + match kind_of_term h with + Evar(i,_) when Intmap.mem i fxminargs && not (Evd.is_defined !evm i) -> + let minargs = Intmap.find i fxminargs in + if List.length rcargs < minargs then + if strict then set_fix i + else raise Partial; + List.iter (check strict) rcargs + | (Var _|Const _) when isEvalRef env h -> + (match reference_opt_value sigma env (destEvalRef h) with + Some h' -> + let bak = !evm in + (try List.iter (check false) rcargs + with Partial -> + evm := bak; + check strict (applist(h',rcargs))) + | None -> List.iter (check strict) rcargs) + | _ -> iter_constr (check strict) c' in + check true c; + !evm + +let substl_checking_arity env subst c = + (* we initialize the problem: *) + let body,sigma,minargs = substl_with_function subst c in + (* we collect arity constraints *) + let sigma' = solve_arity_problem env sigma minargs body in + (* we propagate the constraints: solved problems are substituted; + the other ones are replaced by the function symbol *) + let rec nf_fix c = + match kind_of_term c with + Evar(i,[|fx;f|] as ev) when Intmap.mem i minargs -> + (match Evd.existential_opt_value sigma' ev with + Some c' -> c' + | None -> f) + | _ -> map_constr nf_fix c in + nf_fix body + + + +let contract_fix_use_function env f ((recindices,bodynum),(_names,_types,bodies as typedbodies)) = let nbodies = Array.length recindices in - let make_Fi j = match f j with - | None -> mkFix((recindices,j),typedbodies) - | Some c -> c in + let make_Fi j = (mkFix((recindices,j),typedbodies), f j) in let lbodies = list_tabulate make_Fi nbodies in - substl (List.rev lbodies) bodies.(bodynum) + substl_checking_arity env (List.rev lbodies) (nf_beta bodies.(bodynum)) -let reduce_fix_use_function f whfun fix stack = +let reduce_fix_use_function env f whfun fix stack = match fix_recarg fix stack with | None -> NotReducible | Some (recargnum,recarg) -> @@ -357,16 +438,15 @@ let reduce_fix_use_function f whfun fix stack = let stack' = stack_assign stack recargnum (app_stack recarg') in (match kind_of_term recarg'hd with | Construct _ -> - Reduced (contract_fix_use_function f fix,stack') + Reduced (contract_fix_use_function env f fix,stack') | _ -> NotReducible) -let contract_cofix_use_function f (bodynum,(_names,_,bodies as typedbodies)) = +let contract_cofix_use_function env f + (bodynum,(_names,_,bodies as typedbodies)) = let nbodies = Array.length bodies in - let make_Fi j = match f j with - | None -> mkCoFix(j,typedbodies) - | Some c -> c in + let make_Fi j = (mkCoFix(j,typedbodies), f j) in let subbodies = list_tabulate make_Fi nbodies in - substl (List.rev subbodies) bodies.(bodynum) + substl_checking_arity env (List.rev subbodies) (nf_beta bodies.(bodynum)) let reduce_mind_case_use_function func env mia = match kind_of_term mia.mconstr with @@ -377,8 +457,9 @@ let reduce_mind_case_use_function func env mia = let build_cofix_name = if isConst func then let (mp,dp,_) = repr_con (destConst func) in + let minargs = List.length mia.mcargs in fun i -> - if i = bodynum then Some func + if i = bodynum then Some (minargs,func) else match names.(i) with | Anonymous -> None | Name id -> @@ -389,11 +470,13 @@ let reduce_mind_case_use_function func env mia = let kn = make_con mp dp (label_of_id id) in try match constant_opt_value env kn with | None -> None - | Some _ -> Some (mkConst kn) + (* TODO: check kn is correct *) + | Some _ -> Some (minargs,mkConst kn) with Not_found -> None else fun _ -> None in - let cofix_def = contract_cofix_use_function build_cofix_name cofix in + let cofix_def = + contract_cofix_use_function env build_cofix_name cofix in mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false @@ -432,12 +515,12 @@ let rec red_elim_const env sigma ref largs = let c', lrest = whd_betadelta_state env sigma (c,largs) in let whfun = whd_simpl_state env sigma in (special_red_case sigma env whfun (destCase c'), lrest) - | EliminationFix (min,infos) when stack_args_size largs >=min -> + | EliminationFix (min,minfxargs,infos) when stack_args_size largs >=min -> let c = reference_value sigma env ref in let d, lrest = whd_betadelta_state env sigma (c,largs) in - let f = make_elim_fun ([|Some ref|],infos) largs in + let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) largs in let whfun = whd_construct_state env sigma in - (match reduce_fix_use_function f whfun (destFix d) lrest with + (match reduce_fix_use_function env f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta c, rest)) | EliminationMutualFix (min,refgoal,refinfos) @@ -453,7 +536,7 @@ let rec red_elim_const env sigma ref largs = let d, lrest = whd_betadelta_state env sigma s in let f = make_elim_fun refinfos midargs in let whfun = whd_construct_state env sigma in - (match reduce_fix_use_function f whfun (destFix d) lrest with + (match reduce_fix_use_function env f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta c, rest)) | _ -> raise Redelimination diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 1ce53e88..f93212f8 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: termops.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: termops.ml 11639 2008-11-27 17:48:32Z barras $ *) open Pp open Util @@ -425,11 +425,11 @@ let fold_constr_with_binders g f n acc c = match kind_of_term c with | Fix (_,(lna,tl,bl)) -> let n' = iterate g (Array.length tl) n in let fd = array_map2 (fun t b -> (t,b)) tl bl in - Array.fold_left (fun acc (t,b) -> f n (f n' acc t) b) acc fd + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd | CoFix (_,(lna,tl,bl)) -> let n' = iterate g (Array.length tl) n in let fd = array_map2 (fun t b -> (t,b)) tl bl in - Array.fold_left (fun acc (t,b) -> f n (f n' acc t) b) acc fd + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd (* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate subterms of [c]; it carries an extra data [acc] which is processed by [g] at @@ -473,6 +473,13 @@ let occur_existential c = | _ -> iter_constr occrec c in try occrec c; false with Occur -> true +let occur_meta_or_existential c = + let rec occrec c = match kind_of_term c with + | Evar _ -> raise Occur + | Meta _ -> raise Occur + | _ -> iter_constr occrec c + in try occrec c; false with Occur -> true + let occur_const s c = let rec occur_rec c = match kind_of_term c with | Const sp when sp=s -> raise Occur @@ -671,10 +678,18 @@ let subst_term_occ (nowhere_except_in,locs as plocs) c t = if rest <> [] then error_invalid_occurrence rest; t' -let subst_term_occ_decl (nowhere_except_in,locs as plocs) c (id,bodyopt,typ as d) = - match bodyopt with - | None -> (id,None,subst_term_occ plocs c typ) - | Some body -> +type hyp_location_flag = (* To distinguish body and type of local defs *) + | InHyp + | InHypTypeOnly + | InHypValueOnly + +let subst_term_occ_decl ((nowhere_except_in,locs as plocs),hloc) c (id,bodyopt,typ as d) = + match bodyopt,hloc with + | None, InHypValueOnly -> errorlabstrm "" (pr_id id ++ str " has no value") + | None, _ -> (id,None,subst_term_occ plocs c typ) + | Some body, InHypTypeOnly -> (id,Some body,subst_term_occ plocs c typ) + | Some body, InHypValueOnly -> (id,Some (subst_term_occ plocs c body),typ) + | Some body, InHyp -> if locs = [] then if nowhere_except_in then d else (id,Some (subst_term c body),subst_term c typ) @@ -685,7 +700,6 @@ let subst_term_occ_decl (nowhere_except_in,locs as plocs) c (id,bodyopt,typ as d if rest <> [] then error_invalid_occurrence rest; (id,Some body',t') - (* First character of a constr *) let lowercase_first_char id = @@ -1040,6 +1054,19 @@ let global_vars_set_of_decl env = function Idset.union (global_vars_set env t) (global_vars_set env c) +let dependency_closure env sign hyps = + if Idset.is_empty hyps then [] else + let (_,lh) = + Sign.fold_named_context_reverse + (fun (hs,hl) (x,_,_ as d) -> + if Idset.mem x hs then + (Idset.union (global_vars_set_of_decl env d) (Idset.remove x hs), + x::hl) + else (hs,hl)) + ~init:(hyps,[]) + sign in + List.rev lh + let default_x = id_of_string "x" let rec next_name_away_in_cases_pattern id avoid = diff --git a/pretyping/termops.mli b/pretyping/termops.mli index 645b7d72..d44c762e 100644 --- a/pretyping/termops.mli +++ b/pretyping/termops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: termops.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: termops.mli 11639 2008-11-27 17:48:32Z barras $ i*) open Util open Pp @@ -93,6 +93,7 @@ val strip_head_cast : constr -> constr exception Occur val occur_meta : types -> bool val occur_existential : types -> bool +val occur_meta_or_existential : types -> bool val occur_const : constant -> types -> bool val occur_evar : existential_key -> types -> bool val occur_in_global : env -> identifier -> constr -> unit @@ -147,8 +148,15 @@ val subst_term_occ : occurrences -> constr -> constr -> constr (* [subst_term_occ_decl occl c decl] replaces occurrences of [c] at positions [occl] by [Rel 1] in [decl] *) + +type hyp_location_flag = (* To distinguish body and type of local defs *) + | InHyp + | InHypTypeOnly + | InHypValueOnly + val subst_term_occ_decl : - occurrences -> constr -> named_declaration -> named_declaration + occurrences * hyp_location_flag -> constr -> named_declaration -> + named_declaration val error_invalid_occurrence : int list -> 'a @@ -244,6 +252,10 @@ val make_all_name_different : env -> env val global_vars : env -> constr -> identifier list val global_vars_set_of_decl : env -> named_declaration -> Idset.t +(* Gives an ordered list of hypotheses, closed by dependencies, + containing a given set *) +val dependency_closure : env -> named_context -> Idset.t -> identifier list + (* Test if an identifier is the basename of a global reference *) val is_section_variable : identifier -> bool diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 86168a1f..8680e578 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: typeclasses.ml 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: typeclasses.ml 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Names @@ -35,25 +35,24 @@ type typeclass = { cl_impl : global_reference; (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *) - cl_context : ((global_reference * bool) option * rel_declaration) list; + cl_context : (global_reference * bool) option list * rel_context; (* Context of definitions and properties on defs, will not be shared *) cl_props : rel_context; (* The method implementaions as projections. *) - cl_projs : (identifier * constant) list; + cl_projs : (identifier * constant option) list; } type typeclasses = (global_reference, typeclass) Gmap.t -type globality = int option - type instance = { is_class: global_reference; is_pri: int option; - is_global: globality; (* Sections where the instance should be redeclared, - Some n for n sections, None for discard at end of section. *) + -1 for discard, 0 for none, mutable to avoid redeclarations + when multiple rebuild_object happen. *) + is_global: int ref; is_impl: constant; } @@ -64,13 +63,13 @@ let instance_impl is = is.is_impl let new_instance cl pri glob impl = let global = if Lib.sections_are_opened () then - if glob then Some (Lib.sections_depth ()) - else None - else Some 0 + if glob then Lib.sections_depth () + else -1 + else 0 in { is_class = cl.cl_impl; is_pri = pri ; - is_global = global ; + is_global = ref global ; is_impl = impl } let classes : typeclasses ref = ref Gmap.empty @@ -112,7 +111,7 @@ let gmap_cmap_merge old ne = ne Gmap.empty in Gmap.fold (fun cl insts acc -> - if Gmap.mem cl ne' then acc + if Gmap.mem cl acc then acc else Gmap.add cl insts acc) old ne' @@ -138,23 +137,21 @@ let subst (_,subst,(cl,m,inst)) = and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in - let do_subst_named ctx = + let do_subst_ctx ctx = list_smartmap (fun (na, b, t) -> (na, Option.smartmap do_subst b, do_subst t)) ctx in - let do_subst_ctx ctx = - list_smartmap (fun (cl, (na, b, t)) -> - (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b) cl, - (na, Option.smartmap do_subst b, do_subst t))) - ctx + let do_subst_context (grs,ctx) = + list_smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, + do_subst_ctx ctx in - let do_subst_projs projs = list_smartmap (fun (x, y) -> (x, do_subst_con y)) projs in + let do_subst_projs projs = list_smartmap (fun (x, y) -> (x, Option.smartmap do_subst_con y)) projs in let subst_class k cl classes = let k = do_subst_gr k in let cl' = { cl_impl = k; - cl_context = do_subst_ctx cl.cl_context; - cl_props = do_subst_named cl.cl_props; + cl_context = do_subst_context cl.cl_context; + cl_props = do_subst_ctx cl.cl_props; cl_projs = do_subst_projs cl.cl_projs; } in let cl' = if cl' = cl then cl else cl' in @@ -173,14 +170,18 @@ let subst (_,subst,(cl,m,inst)) = let instances = Gmap.fold subst_inst inst Gmap.empty in (classes, m, instances) +let rel_of_variable_context ctx = + List.fold_right (fun (n,_,b,t) (ctx', subst)-> + let decl = (Name n, Option.map (substn_vars 1 subst) b, substn_vars 1 subst t) in + (decl :: ctx', n :: subst)) ctx ([], []) + let discharge (_,(cl,m,inst)) = - let discharge_context subst rel = + let discharge_rel_context subst n rel = let ctx, _ = List.fold_right - (fun (gr, (id, b, t)) (ctx, k) -> - let gr' = Option.map (fun (gr, b) -> Lib.discharge_global gr, b) gr in - ((gr', (id, Option.map (substn_vars k subst) b, substn_vars k subst t)) :: ctx), succ k) - rel ([], 0) + (fun (id, b, t) (ctx, k) -> + (id, Option.smartmap (substn_vars k subst) b, substn_vars k subst t) :: ctx, succ k) + rel ([], n) in ctx in let abs_context cl = @@ -189,17 +190,22 @@ let discharge (_,(cl,m,inst)) = | ConstRef cst -> Lib.section_segment_of_constant cst | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in + let discharge_context ctx' subst (grs, ctx) = + let grs' = List.map (fun _ -> None) subst @ + list_smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs + in grs', discharge_rel_context subst 1 ctx @ ctx' + in let subst_class k cl acc = let cl_impl' = Lib.discharge_global cl.cl_impl in let cl' = if cl_impl' == cl.cl_impl then cl else let ctx = abs_context cl in - { cl with cl_impl = cl_impl'; - cl_context = - List.map (fun (na,impl,b,t) -> None, (Name na,b,t)) ctx @ - (discharge_context (List.map (fun (na, _, _, _) -> na) ctx) cl.cl_context); - cl_projs = list_smartmap (fun (x, y) -> x, Lib.discharge_con y) cl.cl_projs } + let ctx', subst = rel_of_variable_context ctx in + { cl_impl = cl_impl'; + cl_context = discharge_context ctx' subst cl.cl_context; + cl_props = discharge_rel_context subst (succ (List.length (fst cl.cl_context))) cl.cl_props; + cl_projs = list_smartmap (fun (x, y) -> x, Option.smartmap Lib.discharge_con y) cl.cl_projs } in Gmap.add cl_impl' cl' acc in let classes = Gmap.fold subst_class cl Gmap.empty in @@ -220,13 +226,13 @@ let rebuild (cl,m,inst) = let inst = Gmap.map (fun insts -> Cmap.fold (fun k is insts -> - match is.is_global with - | None -> insts - | Some 0 -> Cmap.add k is insts - | Some n -> + match !(is.is_global) with + | -1 -> insts + | 0 -> Cmap.add k is insts + | n -> add_instance_hint is.is_impl is.is_pri; - let is' = { is with is_global = Some (pred n) } - in Cmap.add k is' insts) insts Cmap.empty) + is.is_global := pred n; + Cmap.add k is insts) insts Cmap.empty) inst in (cl, m, inst) @@ -247,7 +253,10 @@ let update () = let add_class c = classes := Gmap.add c.cl_impl c !classes; - methods := List.fold_left (fun acc x -> Gmap.add (snd x) c.cl_impl acc) !methods c.cl_projs; + methods := List.fold_left (fun acc x -> + match snd x with + | Some m -> Gmap.add m c.cl_impl acc + | None -> acc) !methods c.cl_projs; update () let class_info c = @@ -255,7 +264,7 @@ let class_info c = with _ -> not_a_class (Global.env()) (constr_of_global c) let instance_constructor cl args = - let pars = fst (list_chop (List.length cl.cl_context) args) in + let pars = fst (list_chop (List.length (fst cl.cl_context)) args) in match cl.cl_impl with | IndRef ind -> applistc (mkConstruct (ind, 1)) args, applistc (mkInd ind) pars @@ -319,19 +328,15 @@ let is_implicit_arg k = | InternalHole -> true | _ -> false -let class_of_constr c = - let extract_cl c = - try Some (class_info (global_of_constr c)) with _ -> None - in - match kind_of_term c with - App (c, _) -> extract_cl c - | _ -> extract_cl c - -let dest_class_app c = - let cl c = class_info (global_of_constr c) in - match kind_of_term c with - App (c, args) -> cl c, args - | _ -> cl c, [||] +let global_class_of_constr env c = + try class_info (global_of_constr c) + with Not_found -> not_a_class env c + +let dest_class_app env c = + let cl, args = decompose_app c in + global_class_of_constr env cl, args + +let class_of_constr c = try Some (fst (dest_class_app (Global.env ()) c)) with _ -> None (* To embed a boolean for resolvability status. This is essentially a hack to mark which evars correspond to diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index fdbb78a9..d8e15895 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: typeclasses.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: typeclasses.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Names @@ -25,18 +25,20 @@ open Util (* This module defines type-classes *) type typeclass = { (* The class implementation: a record parameterized by the context with defs in it or a definition if - the class is a singleton. This acts as the classe's global identifier. *) + the class is a singleton. This acts as the class' global identifier. *) cl_impl : global_reference; (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. - The boolean indicates if the typeclass argument is a direct superclass. *) - cl_context : ((global_reference * bool) option * rel_declaration) list; + The boolean indicates if the typeclass argument is a direct superclass and the global reference + gives a direct link to the class itself. *) + cl_context : (global_reference * bool) option list * rel_context; (* Context of definitions and properties on defs, will not be shared *) cl_props : rel_context; - (* The methods implementations of the typeclass as projections. *) - cl_projs : (identifier * constant) list; + (* The methods implementations of the typeclass as projections. Some may be undefinable due to + sorting restrictions. *) + cl_projs : (identifier * constant option) list; } type instance @@ -52,9 +54,13 @@ val add_instance : instance -> unit val class_info : global_reference -> typeclass (* raises a UserError if not a class *) -val class_of_constr : constr -> typeclass option -val dest_class_app : constr -> typeclass * constr array (* raises a UserError if not a class *) +(* These raise a UserError if not a class. *) +val dest_class_app : env -> constr -> typeclass * constr list + +(* Just return None if not a class *) +val class_of_constr : constr -> typeclass option + val instance_impl : instance -> constant val is_class : global_reference -> bool diff --git a/pretyping/unification.ml b/pretyping/unification.ml index b3c920a2..981a5605 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: unification.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: unification.ml 11819 2009-01-20 20:04:50Z herbelin $ *) open Pp open Util @@ -86,18 +86,22 @@ let rec subst_meta_instances bl c = | Meta i -> (try assoc_pair i bl with Not_found -> c) | _ -> map_constr (subst_meta_instances bl) c -let solve_pattern_eqn_array env f l c (metasubst,evarsubst) = +let solve_pattern_eqn_array (env,nb) sigma f l c (metasubst,evarsubst) = match kind_of_term f with | Meta k -> let c = solve_pattern_eqn env (Array.to_list l) c in let n = Array.length l - List.length (fst (decompose_lam c)) in let pb = (ConvUpToEta n,TypeNotProcessed) in - (k,c,pb)::metasubst,evarsubst + if noccur_between 1 nb c then + (k,lift (-nb) c,pb)::metasubst,evarsubst + else error_cannot_unify_local env sigma (mkApp (f, l),c,c) | Evar ev -> (* Currently unused: incompatible with eauto/eassumption backtracking *) metasubst,(ev,solve_pattern_eqn env (Array.to_list l) c)::evarsubst | _ -> assert false +let push d (env,n) = (push_rel_assum d env,n+1) + (*******************************) (* Unification à l'ordre 0 de m et n: [unify_0 env sigma cv_pb m n] @@ -136,28 +140,47 @@ let default_no_delta_unify_flags = { modulo_delta = empty_transparent_state; } -let expand_constant env flags c = - match kind_of_term c with +let expand_key env = function + | Some (ConstKey cst) -> constant_opt_value env cst + | Some (VarKey id) -> named_body id env + | Some (RelKey _) -> None + | None -> None + +let key_of flags f = + match kind_of_term f with | Const cst when is_transparent (ConstKey cst) && - Cpred.mem cst (snd flags.modulo_delta) -> - constant_opt_value env cst + Cpred.mem cst (snd flags.modulo_delta) -> + Some (ConstKey cst) | Var id when is_transparent (VarKey id) && - Idpred.mem id (fst flags.modulo_delta) -> - named_body id env + Idpred.mem id (fst flags.modulo_delta) -> + Some (VarKey id) | _ -> None - + +let oracle_order env cf1 cf2 = + match cf1 with + | None -> + (match cf2 with + | None -> None + | Some k2 -> Some false) + | Some k1 -> + match cf2 with + | None -> Some true + | Some k2 -> Some (Conv_oracle.oracle_order k1 k2) + let unify_0_with_initial_metas subst conv_at_top env sigma cv_pb flags m n = - let nb = nb_rel env in - let trivial_unify pb (metasubst,_) m n = + let trivial_unify curenv pb (metasubst,_) m n = let subst = if flags.use_metas_eagerly then metasubst else fst subst in match subst_defined_metas subst m with - | Some m -> - (match flags.modulo_conv_on_closed_terms with + | Some m1 -> + if (match flags.modulo_conv_on_closed_terms with Some flags -> - is_trans_fconv (conv_pb_of pb) flags env sigma m n - | None -> constr_cmp (conv_pb_of cv_pb) m n) - | _ -> constr_cmp (conv_pb_of cv_pb) m n in - let rec unirec_rec curenv pb b ((metasubst,evarsubst) as substn) curm curn = + is_trans_fconv (conv_pb_of pb) flags env sigma m1 n + | None -> false) then true else + if (not (is_ground_term (create_evar_defs sigma) m1)) + || occur_meta_or_existential n then false else + error_cannot_unify curenv sigma (m, n) + | _ -> false in + let rec unirec_rec (curenv,nb as curenvnb) pb b ((metasubst,evarsubst) as substn) curm curn = let cM = Evarutil.whd_castappevar sigma curm and cN = Evarutil.whd_castappevar sigma curn in match (kind_of_term cM,kind_of_term cN) with @@ -167,41 +190,48 @@ let unify_0_with_initial_metas subst conv_at_top env sigma cv_pb flags m n = then (k1,cN,stN)::metasubst,evarsubst else if k1 = k2 then substn else (k2,cM,stM)::metasubst,evarsubst - | Meta k, _ -> + | Meta k, _ when not (dependent cM cN) -> (* Here we check that [cN] does not contain any local variables *) - if (closedn nb cN) - then (k,cN,snd (extract_instance_status pb))::metasubst,evarsubst + if nb = 0 then + (k,cN,snd (extract_instance_status pb))::metasubst,evarsubst + else if noccur_between 1 nb cN then + (k,lift (-nb) cN,snd (extract_instance_status pb))::metasubst, + evarsubst else error_cannot_unify_local curenv sigma (m,n,cN) - | _, Meta k -> + | _, Meta k when not (dependent cN cM) -> (* Here we check that [cM] does not contain any local variables *) - if (closedn nb cM) - then (k,cM,fst (extract_instance_status pb))::metasubst,evarsubst + if nb = 0 then + (k,cM,snd (extract_instance_status pb))::metasubst,evarsubst + else if noccur_between 1 nb cM + then + (k,lift (-nb) cM,fst (extract_instance_status pb))::metasubst, + evarsubst else error_cannot_unify_local curenv sigma (m,n,cM) | Evar ev, _ -> metasubst,((ev,cN)::evarsubst) | _, Evar ev -> metasubst,((ev,cM)::evarsubst) | Lambda (na,t1,c1), Lambda (_,t2,c2) -> - unirec_rec (push_rel_assum (na,t1) curenv) topconv true - (unirec_rec curenv topconv true substn t1 t2) c1 c2 + unirec_rec (push (na,t1) curenvnb) topconv true + (unirec_rec curenvnb topconv true substn t1 t2) c1 c2 | Prod (na,t1,c1), Prod (_,t2,c2) -> - unirec_rec (push_rel_assum (na,t1) curenv) (prod_pb pb) true - (unirec_rec curenv topconv true substn t1 t2) c1 c2 - | LetIn (_,a,_,c), _ -> unirec_rec curenv pb b substn (subst1 a c) cN - | _, LetIn (_,a,_,c) -> unirec_rec curenv pb b substn cM (subst1 a c) + unirec_rec (push (na,t1) curenvnb) (prod_pb pb) true + (unirec_rec curenvnb topconv true substn t1 t2) c1 c2 + | LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb b substn (subst1 a c) cN + | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb b substn cM (subst1 a c) | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> - array_fold_left2 (unirec_rec curenv topconv true) - (unirec_rec curenv topconv true - (unirec_rec curenv topconv true substn p1 p2) c1 c2) cl1 cl2 + array_fold_left2 (unirec_rec curenvnb topconv true) + (unirec_rec curenvnb topconv true + (unirec_rec curenvnb topconv true substn p1 p2) c1 c2) cl1 cl2 | App (f1,l1), _ when - isMeta f1 & is_unification_pattern curenv f1 l1 & + isMeta f1 & is_unification_pattern curenvnb f1 l1 cN & not (dependent f1 cN) -> - solve_pattern_eqn_array curenv f1 l1 cN substn + solve_pattern_eqn_array curenvnb sigma f1 l1 cN substn | _, App (f2,l2) when - isMeta f2 & is_unification_pattern curenv f2 l2 & + isMeta f2 & is_unification_pattern curenvnb f2 l2 cM & not (dependent f2 cM) -> - solve_pattern_eqn_array curenv f2 l2 cM substn + solve_pattern_eqn_array curenvnb sigma f2 l2 cM substn | App (f1,l1), App (f2,l2) -> let len1 = Array.length l1 @@ -216,43 +246,66 @@ let unify_0_with_initial_metas subst conv_at_top env sigma cv_pb flags m n = let extras,restl1 = array_chop (len1-len2) l1 in (appvect (f1,extras), restl1, f2, l2) in let pb = ConvUnderApp (len1,len2) in - array_fold_left2 (unirec_rec curenv topconv true) - (unirec_rec curenv pb true substn f1 f2) l1 l2 + array_fold_left2 (unirec_rec curenvnb topconv true) + (unirec_rec curenvnb pb true substn f1 f2) l1 l2 with ex when precatchable_exception ex -> - expand curenv pb b substn cM f1 l1 cN f2 l2) + expand curenvnb pb b substn cM f1 l1 cN f2 l2) - | _ -> + | _ -> + if constr_cmp (conv_pb_of cv_pb) cM cN then substn else let (f1,l1) = match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in let (f2,l2) = match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in - expand curenv pb b substn cM f1 l1 cN f2 l2 + expand curenvnb pb b substn cM f1 l1 cN f2 l2 - and expand curenv pb b substn cM f1 l1 cN f2 l2 = - if trivial_unify pb substn cM cN then substn + and expand (curenv,_ as curenvnb) pb b substn cM f1 l1 cN f2 l2 = + if trivial_unify curenv pb substn cM cN then substn else if b then - match expand_constant curenv flags f1 with - | Some c -> - unirec_rec curenv pb b substn (whd_betaiotazeta (mkApp(c,l1))) cN - | None -> - match expand_constant curenv flags f2 with - | Some c -> - unirec_rec curenv pb b substn cM (whd_betaiotazeta (mkApp(c,l2))) - | None -> - error_cannot_unify curenv sigma (cM,cN) + let cf1 = key_of flags f1 and cf2 = key_of flags f2 in + match oracle_order curenv cf1 cf2 with + | None -> error_cannot_unify curenv sigma (cM,cN) + | Some true -> + (match expand_key curenv cf1 with + | Some c -> + unirec_rec curenvnb pb b substn (whd_betaiotazeta (mkApp(c,l1))) cN + | None -> + (match expand_key curenv cf2 with + | Some c -> + unirec_rec curenvnb pb b substn cM (whd_betaiotazeta (mkApp(c,l2))) + | None -> + error_cannot_unify curenv sigma (cM,cN))) + | Some false -> + (match expand_key curenv cf2 with + | Some c -> + unirec_rec curenvnb pb b substn cM (whd_betaiotazeta (mkApp(c,l2))) + | None -> + (match expand_key curenv cf1 with + | Some c -> + unirec_rec curenvnb pb b substn (whd_betaiotazeta (mkApp(c,l1))) cN + | None -> + error_cannot_unify curenv sigma (cM,cN))) else error_cannot_unify curenv sigma (cM,cN) in - if (not(occur_meta m)) && - (match flags.modulo_conv_on_closed_terms with + if (if occur_meta m then false else + if (match flags.modulo_conv_on_closed_terms with Some flags -> is_trans_fconv (conv_pb_of cv_pb) flags env sigma m n - | None -> constr_cmp (conv_pb_of cv_pb) m n) - then + | None -> constr_cmp (conv_pb_of cv_pb) m n) then true else + if (not (is_ground_term (create_evar_defs sigma) m)) + || occur_meta_or_existential n then false else + if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with + | Some (cv_id, cv_k), (dl_id, dl_k) -> + Idpred.subset dl_id cv_id && Cpred.subset dl_k cv_k + | None,(dl_id, dl_k) -> + Idpred.is_empty dl_id && Cpred.is_empty dl_k) + then error_cannot_unify env sigma (m, n) else false) + then subst else - unirec_rec env cv_pb conv_at_top subst m n + unirec_rec (env,0) cv_pb conv_at_top subst m n let unify_0 = unify_0_with_initial_metas ([],[]) true @@ -428,7 +481,7 @@ let w_coerce_to_type env evd c cty mvty = try_to_coerce env evd c cty tycon let w_coerce env evd mv c = - let cty = get_type_of env (evars_of evd) c in + let cty = get_type_of_with_meta env (evars_of evd) (metas_of evd) c in let mvty = Typing.meta_type evd mv in w_coerce_to_type env evd c cty mvty @@ -443,7 +496,7 @@ let unify_to_type env evd flags c u = let unify_type env evd flags mv c = let mvty = Typing.meta_type evd mv in - if occur_meta mvty then + if occur_meta_or_existential mvty then unify_to_type env evd flags c mvty else ([],[]) @@ -490,9 +543,9 @@ let w_merge env with_types flags (metas,evars) evd = let evd' = mimick_evar evd flags f (Array.length cl) evn in w_merge_rec evd' metas evars eqns | _ -> - w_merge_rec (solve_simple_evar_eqn env evd ev rhs') - metas evars' eqns - end + w_merge_rec (solve_simple_evar_eqn env evd ev rhs') + metas evars' eqns + end | [] -> (* Process metas *) @@ -536,7 +589,7 @@ let w_merge env with_types flags (metas,evars) evd = let (evd', c) = applyHead sp_env evd nargs hdc in let (mc,ec) = unify_0 sp_env (evars_of evd') Cumul flags - (Retyping.get_type_of sp_env (evars_of evd') c) ev.evar_concl in + (Retyping.get_type_of_with_meta sp_env (evars_of evd') (metas_of evd') c) ev.evar_concl in let evd'' = w_merge_rec evd' mc ec [] in if (evars_of evd') == (evars_of evd'') then Evd.evar_define sp c evd'' @@ -559,10 +612,10 @@ let w_unify_meta_types env ?(flags=default_unify_flags) evd = [clenv_typed_unify M N clenv] expects in addition that expected types of metavars are unifiable with the types of their instances *) -let check_types env evd subst m n = +let check_types env evd flags subst m n = if isEvar (fst (whd_stack m)) or isEvar (fst (whd_stack n)) then unify_0_with_initial_metas subst true env (evars_of evd) topconv - default_unify_flags + flags (Retyping.get_type_of_with_meta env (evars_of evd) (metas_of evd) m) (Retyping.get_type_of_with_meta env (evars_of evd) (metas_of evd) n) else @@ -570,7 +623,7 @@ let check_types env evd subst m n = let w_unify_core_0 env with_types cv_pb flags m n evd = let (mc1,evd') = retract_coercible_metas evd in - let subst1 = check_types env evd (mc1,[]) m n in + let subst1 = check_types env evd flags (mc1,[]) m n in let subst2 = unify_0_with_initial_metas subst1 true env (evars_of evd') cv_pb flags m n in @@ -659,7 +712,7 @@ let w_unify_to_subterm_list env flags allow_K oplist t evd = if isMeta op then if allow_K then (evd,op::l) else error "Match_subterm" - else if occur_meta op then + else if occur_meta_or_existential op then let (evd',cl) = try (* This is up to delta for subterms w/o metas ... *) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 465c062b..5d09570e 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: vnorm.ml 11017 2008-05-29 13:00:24Z barras $ i*) +(*i $Id: vnorm.ml 11424 2008-09-30 12:10:28Z jforest $ i*) open Names open Declarations @@ -20,7 +20,7 @@ open Vm (* Calcul de la forme normal d'un terme *) (*******************************************) -let crazy_type = mkSet +let crazy_type = mkSet let decompose_prod env t = let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in @@ -178,7 +178,7 @@ and nf_stk env c t stk = nf_stk env (mkApp(c,args)) t stk | Zfix (f,vargs) :: stk -> let fa, typ = nf_fix_app env f vargs in - let _,_,codom = decompose_prod env typ in + let _,_,codom = try decompose_prod env typ with _ -> exit 120 in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> let (mind,_ as ind),allargs = find_rectype_a env t in @@ -187,6 +187,7 @@ and nf_stk env c t stk = let params,realargs = Util.array_chop nparams allargs in let pT = hnf_prod_applist env (type_of_ind env ind) (Array.to_list params) in + let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params (type_of_switch sw) pT in (* Calcul du type des branches *) let btypes = build_branches_type env ind mib mip params dep p in @@ -210,7 +211,7 @@ and nf_predicate env ind mip params v pT = | Vfun f, Prod _ -> let k = nb_rel env in let vb = body_of_vfun k f in - let name,dom,codom = decompose_prod env pT in + let name,dom,codom = try decompose_prod env pT with _ -> exit 121 in let dep,body = nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in dep, mkLambda(name,dom,body) @@ -232,7 +233,7 @@ and nf_args env vargs t = let args = Array.init len (fun i -> - let _,dom,codom = decompose_prod env !t in + let _,dom,codom = try decompose_prod env !t with _ -> exit 123 in let c = nf_val env (arg vargs i) dom in t := subst1 c codom; c) in !t,args @@ -243,7 +244,7 @@ and nf_bargs env b t = let args = Array.init len (fun i -> - let _,dom,codom = decompose_prod env !t in + let _,dom,codom = try decompose_prod env !t with _ -> exit 124 in let c = nf_val env (bfield b i) dom in t := subst1 c codom; c) in args @@ -251,7 +252,11 @@ and nf_bargs env b t = and nf_fun env f typ = let k = nb_rel env in let vb = body_of_vfun k f in - let name,dom,codom = decompose_prod env typ in + let name,dom,codom = + try decompose_prod env typ + with _ -> + raise (Type_errors.TypeError(env,Type_errors.ReferenceVariables typ)) + in let body = nf_val (push_rel (name,None,dom) env) vb codom in mkLambda(name,dom,body) diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 92794ac3..f5204be5 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: clenvtac.ml 11166 2008-06-22 13:23:35Z herbelin $ *) +(* $Id: clenvtac.ml 11709 2008-12-20 11:42:15Z msozeau $ *) open Pp open Util @@ -47,16 +47,17 @@ let clenv_cast_meta clenv = and crec_hd u = match kind_of_term (strip_outer_cast u) with - | Meta mv -> - (try + | Meta mv -> + (try let b = Typing.meta_type clenv.evd mv in - if occur_meta b then u - else mkCast (mkMeta mv, DEFAULTcast, b) + if occur_meta b then + raise (RefinerError (MetaInType b)); + mkCast (mkMeta mv, DEFAULTcast, b) with Not_found -> u) - | App(f,args) -> mkApp (crec_hd f, Array.map crec args) - | Case(ci,p,c,br) -> - mkCase (ci, crec_hd p, crec_hd c, Array.map crec br) - | _ -> u + | App(f,args) -> mkApp (crec_hd f, Array.map crec args) + | Case(ci,p,c,br) -> + mkCase (ci, crec_hd p, crec_hd c, Array.map crec br) + | _ -> u in crec @@ -71,10 +72,15 @@ let clenv_pose_dependent_evars with_evars clenv = clenv_pose_metas_as_evars clenv dep_mvs -let clenv_refine with_evars clenv gls = +let clenv_refine with_evars ?(with_classes=true) clenv gls = let clenv = clenv_pose_dependent_evars with_evars clenv in + let evd' = + if with_classes then + Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd + else clenv.evd + in tclTHEN - (tclEVARS (evars_of clenv.evd)) + (tclEVARS (evars_of evd')) (refine (clenv_cast_meta clenv (clenv_value clenv))) gls @@ -105,11 +111,11 @@ let fail_quick_unif_flags = { } (* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *) -let unifyTerms m n gls = +let unifyTerms ?(flags=fail_quick_unif_flags) m n gls = let env = pf_env gls in let evd = create_goal_evar_defs (project gls) in - let evd' = w_unify false env CONV ~flags:fail_quick_unif_flags m n evd in + let evd' = w_unify false env CONV ~flags m n evd in tclIDTAC {it = gls.it; sigma = evars_of evd'} -let unify m gls = - let n = pf_concl gls in unifyTerms m n gls +let unify ?(flags=fail_quick_unif_flags) m gls = + let n = pf_concl gls in unifyTerms ~flags m n gls diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli index 29442ded..04a5eb57 100644 --- a/proofs/clenvtac.mli +++ b/proofs/clenvtac.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: clenvtac.mli 11166 2008-06-22 13:23:35Z herbelin $ i*) +(*i $Id: clenvtac.mli 11709 2008-12-20 11:42:15Z msozeau $ i*) (*i*) open Util @@ -21,8 +21,8 @@ open Unification (*i*) (* Tactics *) -val unify : constr -> tactic -val clenv_refine : evars_flag -> clausenv -> tactic +val unify : ?flags:unify_flags -> constr -> tactic +val clenv_refine : evars_flag -> ?with_classes:bool -> clausenv -> tactic val res_pf : clausenv -> ?with_evars:evars_flag -> ?allow_K:bool -> ?flags:unify_flags -> tactic val elim_res_pf_THEN_i : clausenv -> (clausenv -> tactic array) -> tactic diff --git a/proofs/logic.ml b/proofs/logic.ml index 21ee9a9f..a04216cb 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: logic.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: logic.ml 11796 2009-01-18 13:41:39Z herbelin $ *) open Pp open Util @@ -37,6 +37,7 @@ type refiner_error = | CannotApply of constr * constr | NotWellTyped of constr | NonLinearProof of constr + | MetaInType of constr (* Errors raised by the tactics *) | IntroNeedsProduct @@ -57,29 +58,18 @@ let rec catchable_exception = function |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _ |CannotFindWellTypedAbstraction _ |UnsolvableImplicit _)) -> true + | Typeclasses_errors.TypeClassError + (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true | _ -> false +let error_no_such_hypothesis id = + error ("No such hypothesis: " ^ string_of_id id ^ ".") + (* Tells if the refiner should check that the submitted rules do not produce invalid subgoals *) let check = ref false let with_check = Flags.with_option check -(************************************************************************) -(************************************************************************) -(* Implementation of the structural rules (moving and deleting - hypotheses around) *) - -(* The Clear tactic: it scans the context for hypotheses to be removed - (instead of iterating on the list of identifier to be removed, which - forces the user to give them in order). *) - -let clear_hyps sigma ids sign cl = - let evdref = ref (Evd.create_goal_evar_defs sigma) in - let (hyps,concl) = Evarutil.clear_hyps_in_evi evdref sign cl ids in - (hyps,concl,evars_of !evdref) - -(* The ClearBody tactic *) - (* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and returns [tail::(f head (id,_,_) (rev tail))] *) let apply_to_hyp sign id f = @@ -97,6 +87,22 @@ let apply_to_hyp_and_dependent_on sign id f g = let check_typability env sigma c = if !check then let _ = type_of env sigma c in () +(************************************************************************) +(************************************************************************) +(* Implementation of the structural rules (moving and deleting + hypotheses around) *) + +(* The Clear tactic: it scans the context for hypotheses to be removed + (instead of iterating on the list of identifier to be removed, which + forces the user to give them in order). *) + +let clear_hyps sigma ids sign cl = + let evdref = ref (Evd.create_goal_evar_defs sigma) in + let (hyps,concl) = Evarutil.clear_hyps_in_evi evdref sign cl ids in + (hyps,concl,evars_of !evdref) + +(* The ClearBody tactic *) + let recheck_typability (what,id) env sigma t = try check_typability env sigma t with _ -> @@ -126,6 +132,82 @@ let remove_hyp_body env sigma id = in reset_with_named_context sign env +(* Reordering of the context *) + +(* faire le minimum d'echanges pour que l'ordre donne soit un *) +(* sous-ordre du resultat. Par exemple, 2 hyps non mentionnee ne sont *) +(* pas echangees. Choix: les hyps mentionnees ne peuvent qu'etre *) +(* reculees par rapport aux autres (faire le contraire!) *) + +let mt_q = (Idmap.empty,[]) +let push_val y = function + (_,[] as q) -> q + | (m, (x,l)::q) -> (m, (x,Idset.add y l)::q) +let push_item x v (m,l) = + (Idmap.add x v m, (x,Idset.empty)::l) +let mem_q x (m,_) = Idmap.mem x m +let rec find_q x (m,q) = + let v = Idmap.find x m in + let m' = Idmap.remove x m in + let rec find accs acc = function + [] -> raise Not_found + | [(x',l)] -> + if x=x' then ((v,Idset.union accs l),(m',List.rev acc)) + else raise Not_found + | (x',l as i)::((x'',l'')::q as itl) -> + if x=x' then + ((v,Idset.union accs l), + (m',List.rev acc@(x'',Idset.add x (Idset.union l l''))::q)) + else find (Idset.union l accs) (i::acc) itl in + find Idset.empty [] q + +let occur_vars_in_decl env hyps d = + if Idset.is_empty hyps then false else + let ohyps = global_vars_set_of_decl env d in + Idset.exists (fun h -> Idset.mem h ohyps) hyps + +let reorder_context env sign ord = + let ords = List.fold_right Idset.add ord Idset.empty in + if List.length ord <> Idset.cardinal ords then + error "Order list has duplicates"; + let rec step ord expected ctxt_head moved_hyps ctxt_tail = + match ord with + | [] -> List.rev ctxt_tail @ ctxt_head + | top::ord' when mem_q top moved_hyps -> + let ((d,h),mh) = find_q top moved_hyps in + if occur_vars_in_decl env h d then + errorlabstrm "reorder_context" + (str "Cannot move declaration " ++ pr_id top ++ spc() ++ + str "before " ++ + prlist_with_sep pr_spc pr_id + (Idset.elements (Idset.inter h + (global_vars_set_of_decl env d)))); + step ord' expected ctxt_head mh (d::ctxt_tail) + | _ -> + (match ctxt_head with + | [] -> error_no_such_hypothesis (List.hd ord) + | (x,_,_ as d) :: ctxt -> + if Idset.mem x expected then + step ord (Idset.remove x expected) + ctxt (push_item x d moved_hyps) ctxt_tail + else + step ord expected + ctxt (push_val x moved_hyps) (d::ctxt_tail)) in + step ord ords sign mt_q [] + +let reorder_val_context env sign ord = + val_of_named_context (reorder_context env (named_context_of_val sign) ord) + + + + +let check_decl_position env sign (x,_,_ as d) = + let needed = global_vars_set_of_decl env d in + let deps = dependency_closure env (named_context_of_val sign) needed in + if List.mem x deps then + error ("Cannot create self-referring hypothesis "^string_of_id x); + x::deps + (* Auxiliary functions for primitive MOVE tactic * * [move_hyp with_dep toleft (left,(hfrom,typfrom),right) hto] moves @@ -134,9 +216,6 @@ let remove_hyp_body env sigma id = * on the right side [right] if [toleft=false]. * If [with_dep] then dependent hypotheses are moved accordingly. *) -let error_no_such_hypothesis id = - error ("No such hypothesis: " ^ string_of_id id ^ ".") - let rec get_hyp_after h = function | [] -> error_no_such_hypothesis h | (hyp,_,_) :: right -> @@ -219,14 +298,23 @@ let rename_hyp id1 id2 sign = (* Will only be used on terms given to the Refine rule which have meta variables only in Application and Case *) +let error_unsupported_deep_meta c = + errorlabstrm "" (strbrk "Application of lemmas whose beta-iota normal " ++ + strbrk "form contains metavariables deep inside the term is not " ++ + strbrk "supported; try \"refine\" instead.") + let collect_meta_variables c = - let rec collrec acc c = match kind_of_term c with - | Meta mv -> mv::acc - | Cast(c,_,_) -> collrec acc c - | (App _| Case _) -> fold_constr collrec acc c - | _ -> acc - in - List.rev(collrec [] c) + let rec collrec deep acc c = match kind_of_term c with + | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc + | Cast(c,_,_) -> collrec deep acc c + | (App _| Case _) -> fold_constr (collrec deep) acc c + | _ -> fold_constr (collrec true) acc c + in + List.rev (collrec false [] c) + +let check_meta_variables c = + if not (list_distinct (collect_meta_variables c)) then + raise (RefinerError (NonLinearProof c)) let check_conv_leq_goal env sigma arg ty conclty = if !check & not (is_conv_leq env sigma ty conclty) then @@ -248,9 +336,10 @@ let rec mk_refgoals sigma goal goalacc conclty trm = *) match kind_of_term trm with | Meta _ -> - if !check && occur_meta conclty then - anomaly "refined called with a dependent meta"; - (mk_goal hyps (nf_betaiota conclty))::goalacc, conclty + let conclty = nf_betaiota conclty in + if !check && occur_meta conclty then + raise (RefinerError (MetaInType conclty)); + (mk_goal hyps conclty)::goalacc, conclty | Cast (t,_, ty) -> check_typability env sigma ty; @@ -261,12 +350,10 @@ let rec mk_refgoals sigma goal goalacc conclty trm = let (acc',hdty) = match kind_of_term f with | Ind _ | Const _ - when not (array_exists occur_meta l) (* we could be finer *) - & (isInd f or has_polymorphic_type (destConst f)) - -> + when (isInd f or has_polymorphic_type (destConst f)) -> (* Sort-polymorphism of definition and inductive types *) goalacc, - type_of_global_reference_knowing_parameters env sigma f l + type_of_global_reference_knowing_conclusion env sigma f conclty | _ -> mk_hdgoals sigma goal goalacc f in @@ -288,6 +375,7 @@ let rec mk_refgoals sigma goal goalacc conclty trm = | _ -> if occur_meta trm then anomaly "refiner called with a meta in non app/case subterm"; + let t'ty = goal_type_of env sigma trm in check_conv_leq_goal env sigma trm t'ty conclty; (goalacc,t'ty) @@ -358,14 +446,19 @@ and mk_casegoals sigma goal goalacc p c = let convert_hyp sign sigma (id,b,bt as d) = - apply_to_hyp sign id - (fun _ (_,c,ct) _ -> - let env = Global.env_of_context sign in - if !check && not (is_conv env sigma bt ct) then - error ("Incorrect change of the type of "^(string_of_id id)^"."); - if !check && not (Option.Misc.compare (is_conv env sigma) b c) then - error ("Incorrect change of the body of "^(string_of_id id)^"."); - d) + let env = Global.env() in + let reorder = ref [] in + let sign' = + apply_to_hyp sign id + (fun _ (_,c,ct) _ -> + let env = Global.env_of_context sign in + if !check && not (is_conv env sigma bt ct) then + error ("Incorrect change of the type of "^(string_of_id id)^"."); + if !check && not (Option.Misc.compare (is_conv env sigma) b c) then + error ("Incorrect change of the body of "^(string_of_id id)^"."); + if !check then reorder := check_decl_position env sign d; + d) in + reorder_val_context env sign' !reorder (* Normalizing evars in a goal. Called by tactic Local_constraints (i.e. when the sigma of the proof tree changes). Detect if the @@ -418,7 +511,9 @@ let prim_refiner r sigma goal = nexthyp, cl,sigma else - (push_named_context_val (id,None,t) sign),cl,sigma in + (if !check && mem_named_context id (named_context_of_val sign) then + error "New variable is already declared"; + push_named_context_val (id,None,t) sign,cl,sigma) in let sg2 = mk_goal sign cl in if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma) @@ -478,8 +573,7 @@ let prim_refiner r sigma goal = (mk_sign sign all, sigma) | Refine c -> - if not (list_distinct (collect_meta_variables c)) then - raise (RefinerError (NonLinearProof c)); + check_meta_variables c; let (sgl,cl') = mk_refgoals sigma goal [] cl c in let sgl = List.rev sgl in (sgl, sigma) @@ -518,6 +612,10 @@ let prim_refiner r sigma goal = move_hyp withdep toleft (left,declfrom,right) hto in ([mk_goal hyps' cl], sigma) + | Order ord -> + let hyps' = reorder_val_context env sign ord in + ([mk_goal hyps' cl], sigma) + | Rename (id1,id2) -> if !check & id1 <> id2 && List.mem id2 (ids_of_named_context (named_context_of_val sign)) then @@ -628,7 +726,7 @@ let prim_extractor subfun vl pft = | Some (Prim (ThinBody _),[pf]) -> subfun vl pf - | Some (Prim (Move _),[pf]) -> + | Some (Prim (Move _|Order _),[pf]) -> subfun vl pf | Some (Prim (Rename (id1,id2)),[pf]) -> diff --git a/proofs/logic.mli b/proofs/logic.mli index def02c8c..2f3a0d89 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: logic.mli 10785 2008-04-13 21:41:54Z herbelin $ i*) +(*i $Id: logic.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Names @@ -54,6 +54,7 @@ type refiner_error = | CannotApply of constr * constr | NotWellTyped of constr | NonLinearProof of constr + | MetaInType of constr (*i Errors raised by the tactics i*) | IntroNeedsProduct diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 6d8f09ea..0aba9f5f 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: pfedit.ml 10850 2008-04-25 18:07:44Z herbelin $ *) +(* $Id: pfedit.ml 11745 2009-01-04 18:43:08Z herbelin $ *) open Pp open Util @@ -34,6 +34,7 @@ open Safe_typing type proof_topstate = { mutable top_end_tac : tactic option; top_init_tac : tactic option; + top_compute_guard : bool; top_goal : goal; top_strength : Decl_kinds.goal_kind; top_hook : declaration_hook } @@ -207,7 +208,7 @@ let set_xml_cook_proof f = xml_cook_proof := f let cook_proof k = let (pfs,ts) = get_state() and ident = get_current_proof_name () in - let {evar_concl=concl} = ts.top_goal + let {evar_concl=concl} = ts.top_goal and strength = ts.top_strength in let pfterm = extract_pftreestate pfs in !xml_cook_proof (strength,pfs); @@ -217,7 +218,7 @@ let cook_proof k = const_entry_type = Some concl; const_entry_opaque = true; const_entry_boxed = false}, - strength, ts.top_hook)) + ts.top_compute_guard, strength, ts.top_hook)) let current_proof_statement () = let ts = get_topstate() in @@ -251,11 +252,12 @@ let set_end_tac tac = (* Modifying the current prooftree *) (*********************************************************************) -let start_proof na str sign concl ?init_tac hook = +let start_proof na str sign concl ?init_tac ?(compute_guard=false) hook = let top_goal = mk_goal sign concl None in let ts = { top_end_tac = None; top_init_tac = init_tac; + top_compute_guard = compute_guard; top_goal = top_goal; top_strength = str; top_hook = hook} diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 42c24081..464f6286 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: pfedit.mli 10850 2008-04-25 18:07:44Z herbelin $ i*) +(*i $Id: pfedit.mli 11745 2009-01-04 18:43:08Z herbelin $ i*) (*i*) open Util @@ -80,7 +80,7 @@ val get_undo : unit -> int option val start_proof : identifier -> goal_kind -> named_context_val -> constr -> - ?init_tac:tactic -> declaration_hook -> unit + ?init_tac:tactic -> ?compute_guard:bool -> declaration_hook -> unit (* [restart_proof ()] restarts the current focused proof from the beginning or fails if no proof is focused *) @@ -104,10 +104,11 @@ val suspend_proof : unit -> unit (*s [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 *) + it fails if there is no current proof of if it is not completed; + it also tells if the guardness condition has to be inferred. *) val cook_proof : (Refiner.pftreestate -> unit) -> - identifier * (Entries.definition_entry * goal_kind * declaration_hook) + identifier * (Entries.definition_entry * bool * goal_kind * declaration_hook) (* To export completed proofs to xml *) val set_xml_cook_proof : (goal_kind * pftreestate -> unit) -> unit diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml index 41935c9c..1e673853 100644 --- a/proofs/proof_type.ml +++ b/proofs/proof_type.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: proof_type.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(*i $Id: proof_type.ml 11639 2008-11-27 17:48:32Z barras $ *) (*i*) open Environ @@ -37,6 +37,7 @@ type prim_rule = | Thin of identifier list | ThinBody of identifier list | Move of bool * identifier * identifier move_location + | Order of identifier list | Rename of identifier * identifier | Change_evars diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index a7057a7d..21cd8b28 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: proof_type.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: proof_type.mli 11639 2008-11-27 17:48:32Z barras $ i*) (*i*) open Environ @@ -37,6 +37,7 @@ type prim_rule = | Thin of identifier list | ThinBody of identifier list | Move of bool * identifier * identifier move_location + | Order of identifier list | Rename of identifier * identifier | Change_evars diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 072a38b6..ad8ee3a2 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: redexpr.ml 11094 2008-06-10 19:35:23Z herbelin $ *) +(* $Id: redexpr.ml 11481 2008-10-20 19:23:51Z herbelin $ *) open Pp open Util @@ -46,12 +46,13 @@ let set_strategy_one ref l = Csymtable.set_transparent_const sp | _ -> () -let cache_strategy str = +let cache_strategy (_,str) = List.iter (fun (lev,ql) -> List.iter (fun q -> set_strategy_one q lev) ql) str -let subst_strategy (_,subs,obj) = +let subst_strategy (_,subs,(local,obj)) = + local, list_smartmap (fun (k,ql as entry) -> let ql' = list_smartmap (Mod_subst.subst_evaluable_reference subs) ql in @@ -68,14 +69,16 @@ let map_strategy f l = Some q' -> q' :: ql | None -> ql) ql [] in if ql'=[] then str else (lev,ql')::str) l [] in - if l'=[] then None else Some l' + if l'=[] then None else Some (false,l') -let export_strategy obj = +let export_strategy (local,obj) = + if local then None else map_strategy (function EvalVarRef _ -> None | EvalConstRef _ as q -> Some q) obj -let classify_strategy (_,obj) = Substitute obj +let classify_strategy (_,(local,_ as obj)) = + if local then Dispose else Substitute obj let disch_ref ref = match ref with @@ -84,7 +87,8 @@ let disch_ref ref = if c==c' then Some ref else Some (EvalConstRef c') | _ -> Some ref -let discharge_strategy (_,obj) = +let discharge_strategy (_,(local,obj)) = + if local then None else map_strategy disch_ref obj let (inStrategy,outStrategy) = @@ -98,8 +102,7 @@ let (inStrategy,outStrategy) = let set_strategy local str = - if local then cache_strategy str - else Lib.add_anonymous_leaf (inStrategy str) + Lib.add_anonymous_leaf (inStrategy (local,str)) let _ = Summary.declare_summary "Transparent constants and variables" diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 6e08e741..a9a1f51d 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: refiner.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: refiner.ml 11865 2009-01-28 17:34:30Z herbelin $ *) open Pp open Util @@ -462,7 +462,7 @@ let weak_progress gls ptree = (not (same_goal (List.hd gls.it) ptree.it)) let progress gls ptree = - (not (ptree.sigma == gls.sigma)) || + (not (eq_evar_map ptree.sigma gls.sigma)) || (weak_progress gls ptree) diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 95130ac5..a6ba3af5 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: refiner.mli 10879 2008-05-01 22:14:20Z msozeau $ i*) +(*i $Id: refiner.mli 11735 2009-01-02 17:22:31Z herbelin $ i*) (*i*) open Term @@ -137,6 +137,7 @@ exception FailError of int * Pp.std_ppcmds level or do nothing. *) val catch_failerror : exn -> unit +val tclORELSE0 : tactic -> tactic -> tactic val tclORELSE : tactic -> tactic -> tactic val tclREPEAT : tactic -> tactic val tclREPEAT_MAIN : tactic -> tactic diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml index 8e51171f..66136afa 100644 --- a/proofs/tacexpr.ml +++ b/proofs/tacexpr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tacexpr.ml 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: tacexpr.ml 11739 2009-01-02 19:33:19Z herbelin $ i*) open Names open Topconstr @@ -58,12 +58,7 @@ let make_red_flag = add_flag {rBeta = false; rIota = false; rZeta = false; rDelta = false; rConst = []} -type hyp_location_flag = (* To distinguish body and type of local defs *) - | InHyp - | InHypTypeOnly - | InHypValueOnly - -type 'a raw_hyp_location = 'a with_occurrences * hyp_location_flag +type 'a raw_hyp_location = 'a with_occurrences * Termops.hyp_location_flag type 'id move_location = | MoveAfter of 'id @@ -103,7 +98,6 @@ type 'id message_token = | MsgInt of int | MsgIdent of 'id - type 'id gsimple_clause = ('id raw_hyp_location) option (* onhyps: [None] means *on every hypothesis* @@ -133,16 +127,15 @@ type multi = | RepeatStar | RepeatPlus -type pattern_expr = constr_expr - (* Type of patterns *) type 'a match_pattern = | Term of 'a - | Subterm of identifier option * 'a + | Subterm of bool * identifier option * 'a (* Type of hypotheses for a Match Context rule *) type 'a match_context_hyps = | Hyp of name located * 'a match_pattern + | Def of name located * 'a match_pattern * 'a match_pattern (* Type of a Match rule for Match Context and Match *) type ('a,'t) match_rule = @@ -158,7 +151,8 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr = | TacExact of 'constr | TacExactNoCheck of 'constr | TacVmCastNoCheck of 'constr - | TacApply of advanced_flag * evars_flag * 'constr with_bindings list + | TacApply of advanced_flag * evars_flag * 'constr with_bindings list * + ('id * intro_pattern_expr located option) option | TacElim of evars_flag * 'constr with_bindings * 'constr with_bindings option | TacElimType of 'constr @@ -170,7 +164,7 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr = | TacCofix of identifier option | TacMutualCofix of hidden_flag * identifier * (identifier * 'constr) list | TacCut of 'constr - | TacAssert of 'tac option * intro_pattern_expr located * 'constr + | TacAssert of 'tac option * intro_pattern_expr located option * 'constr | TacGeneralize of ('constr with_occurrences * name) list | TacGeneralizeDep of 'constr | TacLetTac of name * 'constr * 'id gclause * letin_flag @@ -287,7 +281,7 @@ and glob_tactic_expr = type raw_tactic_expr = (constr_expr, - pattern_expr, + constr_pattern_expr, reference or_by_notation, reference or_by_notation, reference, @@ -296,7 +290,7 @@ type raw_tactic_expr = type raw_atomic_tactic_expr = (constr_expr, (* constr *) - pattern_expr, (* pattern *) + constr_pattern_expr, (* pattern *) reference or_by_notation, (* evaluable reference *) reference or_by_notation, (* inductive *) reference, (* ltac reference *) @@ -305,7 +299,7 @@ type raw_atomic_tactic_expr = type raw_tactic_arg = (constr_expr, - pattern_expr, + constr_pattern_expr, reference or_by_notation, reference or_by_notation, reference, diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 6bbaff08..bf194d47 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacmach.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: tacmach.ml 11639 2008-11-27 17:48:32Z barras $ *) open Pp open Util @@ -202,6 +202,9 @@ let thin_body_no_check ids gl = let move_hyp_no_check with_dep id1 id2 gl = refiner (Prim (Move (with_dep,id1,id2))) gl +let order_hyps idl gl = + refiner (Prim (Order idl)) gl + let rec rename_hyp_no_check l gl = match l with | [] -> tclIDTAC gl | (id1,id2)::l -> diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 2fc66e71..cdcb8bfd 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tacmach.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: tacmach.mli 11639 2008-11-27 17:48:32Z barras $ i*) (*i*) open Names @@ -133,6 +133,7 @@ val thin_body_no_check : identifier list -> tactic val move_hyp_no_check : bool -> identifier -> identifier move_location -> tactic val rename_hyp_no_check : (identifier*identifier) list -> tactic +val order_hyps : identifier list -> tactic val mutual_fix : identifier -> int -> (identifier * int * constr) list -> tactic val mutual_cofix : identifier -> (identifier * constr) list -> tactic diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index 2e19011f..7aa57d9b 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tactic_debug.ml 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id: tactic_debug.ml 11576 2008-11-10 19:13:15Z msozeau $ i*) open Names open Constrextern @@ -129,7 +129,7 @@ let hyp_bound = function | Name id -> " (bound to "^(Names.string_of_id id)^")" (* Prints a matched hypothesis *) -let db_matched_hyp debug env (id,c) ido = +let db_matched_hyp debug env (id,_,c) ido = if debug <> DebugOff & !skip = 0 then msgnl (str "Hypothesis " ++ str ((Names.string_of_id id)^(hyp_bound ido)^ @@ -148,8 +148,8 @@ let db_mc_pattern_success debug = let pp_match_pattern env = function | Term c -> Term (extern_constr_pattern (names_of_rel_context env) c) - | Subterm (o,c) -> - Subterm (o,(extern_constr_pattern (names_of_rel_context env) c)) + | Subterm (b,o,c) -> + Subterm (b,o,(extern_constr_pattern (names_of_rel_context env) c)) (* Prints a failure message for an hypothesis pattern *) let db_hyp_pattern_failure debug env (na,hyp) = diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli index 6de8244d..63c89547 100644 --- a/proofs/tactic_debug.mli +++ b/proofs/tactic_debug.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tactic_debug.mli 9092 2006-08-28 11:42:14Z bertot $ i*) +(*i $Id: tactic_debug.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) open Environ open Pattern @@ -45,7 +45,7 @@ val db_pattern_rule : (* Prints a matched hypothesis *) val db_matched_hyp : - debug_info -> env -> identifier * constr -> name -> unit + debug_info -> env -> identifier * constr option * constr -> name -> unit (* Prints the matched conclusion *) val db_matched_concl : debug_info -> env -> constr -> unit diff --git a/scripts/coqc.ml b/scripts/coqc.ml index 41fb0803..784e2d51 100644 --- a/scripts/coqc.ml +++ b/scripts/coqc.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coqc.ml 10235 2007-10-18 12:25:03Z notin $ *) +(* $Id: coqc.ml 11749 2009-01-05 14:01:04Z notin $ *) (* Afin de rendre Coq plus portable, ce programme Caml remplace le script coqc. @@ -24,17 +24,9 @@ let environment = Unix.environment () -let bindir = ref Coq_config.bindir let binary = ref ("coqtop." ^ Coq_config.best) let image = ref "" -(* the $COQBIN environment variable has priority over the Coq_config value *) -let _ = - try - let c = Sys.getenv "COQBIN" in - if c <> "" then bindir := c - with Not_found -> () - (* coqc options *) let specification = ref false @@ -116,12 +108,8 @@ let parse_args () = | ("-verbose" | "--verbose") :: rem -> verbose := true ; parse (cfiles,args) rem | "-boot" :: rem -> - bindir:= Filename.concat Coq_config.coqtop "bin"; + Flags.boot := true; parse (cfiles, "-boot"::args) rem - | "-bindir" :: d :: rem -> - bindir := d ; parse (cfiles,args) rem - | "-bindir" :: [] -> - usage () | "-byte" :: rem -> binary := "coqtop.byte"; parse (cfiles,args) rem | "-opt" :: rem -> @@ -141,7 +129,7 @@ let parse_args () = | ("-I"|"-include"|"-outputstate" |"-inputstate"|"-is"|"-load-vernac-source"|"-l"|"-load-vernac-object" |"-load-ml-source"|"-require"|"-load-ml-object"|"-user" - |"-init-file"|"-dump-glob" as o) :: rem -> + |"-init-file" | "-dump-glob" | "-coqlib" as o) :: rem -> begin match rem with | s :: rem' -> parse (cfiles,s::o::args) rem' @@ -150,19 +138,22 @@ let parse_args () = | "-R" as o :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem | ("-notactics"|"-debug"|"-nolib" - | "-debugVM"|"-alltransp"|"-VMno" + |"-debugVM"|"-alltransp"|"-VMno" |"-batch"|"-nois" |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet" - |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-translate" |"-strict-implicit" - |"-dont-load-proofs"|"-impredicative-set"|"-vm" - | "-unboxed-values" | "-unboxed-definitions" | "-draw-vm-instr" - as o) :: rem -> + |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit" + |"-dont-load-proofs"|"-impredicative-set"|"-vm" + |"-unboxed-values"|"-unboxed-definitions"|"-draw-vm-instr" + |"-no-glob"|"-noglob" as o) :: rem -> parse (cfiles,o::args) rem - | "-where" :: _ -> - let coqlib = - try Sys.getenv "COQLIB" with Not_found -> Coq_config.coqlib - in - print_endline coqlib; exit 0 + + | ("-where") :: _ -> + (try print_endline (Envars.coqlib ()) + with Util.UserError(_,pps) -> Pp.msgerrnl (Pp.hov 0 pps)); + exit 0 + + | ("-config" | "--config") :: _ -> Usage.print_config (); exit 0 + | ("-v"|"--version") :: _ -> Usage.version () | f :: rem -> @@ -184,14 +175,15 @@ let parse_args () = let main () = let cfiles, args = parse_args () in - if cfiles = [] then begin - prerr_endline "coqc: too few arguments" ; - usage () - end; - let coqtopname = - if !image <> "" then !image else Filename.concat !bindir (!binary ^ Coq_config.exec_extension) - in -(* List.iter (compile coqtopname args) cfiles*) - Unix.handle_unix_error (compile coqtopname args) cfiles + if cfiles = [] then begin + prerr_endline "coqc: too few arguments" ; + usage () + end; + let coqtopname = + if !image <> "" then !image + else Filename.concat (Envars.coqbin ()) (!binary ^ Coq_config.exec_extension) + in + (* List.iter (compile coqtopname args) cfiles*) + Unix.handle_unix_error (compile coqtopname args) cfiles let _ = Printexc.print main (); exit 0 diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml index 2569b292..9a7d30b1 100644 --- a/scripts/coqmktop.ml +++ b/scripts/coqmktop.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coqmktop.ml 11380 2008-09-07 12:27:27Z glondu $ *) +(* $Id: coqmktop.ml 11784 2009-01-14 11:36:32Z herbelin $ *) (* coqmktop is a script to link Coq, analogous to ocamlmktop. The command line contains options specific to coqmktop, options for the @@ -17,7 +17,7 @@ open Unix (* Objects to link *) (* 1. Core objects *) -let ocamlobjs = ["unix.cma";"nums.cma"] +let ocamlobjs = ["str.cma";"unix.cma";"nums.cma"] let dynobjs = ["dynlink.cma"] let camlp4objs = ["gramlib.cma"] let libobjs = ocamlobjs @ camlp4objs @@ -44,7 +44,6 @@ let notopobjs = gramobjs (* 4. High-level tactics objects *) (* environment *) -let src_coqtop = ref Coq_config.coqtop let opt = ref false let full = ref false let top = ref false @@ -57,11 +56,14 @@ let src_dirs () = if !coqide then [[ "ide" ]] else [] let includes () = - List.fold_right - (fun d l -> "-I" :: List.fold_left Filename.concat !src_coqtop d :: l) - (src_dirs ()) - (["-I"; "\"" ^ Coq_config.camlp4lib ^ "\""] @ - (if !coqide then ["-thread"; "-I"; "+lablgtk2"] else [])) + let coqlib = Envars.coqlib () in + let camlp4lib = Envars.camlp4lib () in + List.fold_right + (fun d l -> "-I" :: ("\"" ^ List.fold_left Filename.concat coqlib d ^ "\"") :: l) + (src_dirs ()) + (["-I"; "\"" ^ camlp4lib ^ "\""] @ + ["-I"; "\"" ^ coqlib ^ "\""] @ + (if !coqide then ["-thread"; "-I"; "+lablgtk2"] else [])) (* Transform bytecode object file names in native object file names *) let native_suffix f = @@ -83,15 +85,16 @@ let module_of_file name = (* Build the list of files to link and the list of modules names *) let files_to_link userfiles = - let dyn_objs = if not !opt then dynobjs else [] in + let dyn_objs = + if not !opt || Coq_config.has_natdynlink then dynobjs else [] in let toplevel_objs = if !top then topobjs else if !opt then notopobjs else [] in let ide_objs = if !coqide then - "str.cma"::"threads.cma"::"lablgtk.cma"::"gtkThread.cmo"::ide + "threads.cma"::"lablgtk.cma"::"gtkThread.cmo"::ide else [] in let ide_libs = if !coqide then - ["str.cma" ; "threads.cma" ; "lablgtk.cma" ; "gtkThread.cmo" ; + ["threads.cma" ; "lablgtk.cma" ; "gtkThread.cmo" ; "ide/ide.cma" ] else [] in @@ -135,22 +138,33 @@ let all_subdirs dir = let usage () = prerr_endline "Usage: coqmktop files Flags.are: - -srcdir dir Specify where the Coq source files are - -o exec-file Specify the name of the resulting toplevel - -opt Compile in native code - -full Link high level tactics - -top Build Coq on a ocaml toplevel (incompatible with -opt) - -searchisos Build a toplevel for SearchIsos - -ide Build a toplevel for the Coq IDE - -R dir Specify recursively directories for Ocaml\n"; + -coqlib dir Specify where the Coq object files are + -camlbin dir Specify where the OCaml binaries are + -camlp4bin dir Specify where the CAmp4/5 binaries are + -o exec-file Specify the name of the resulting toplevel + -boot Run in boot mode + -opt Compile in native code + -full Link high level tactics + -top Build Coq on a ocaml toplevel (incompatible with -opt) + -searchisos Build a toplevel for SearchIsos + -ide Build a toplevel for the Coq IDE + -R dir Specify recursively directories for Ocaml\n"; exit 1 (* parsing of the command line *) let parse_args () = let rec parse (op,fl) = function | [] -> List.rev op, List.rev fl - | "-srcdir" :: d :: rem -> src_coqtop := d ; parse (op,fl) rem - | "-srcdir" :: _ -> usage () + | "-coqlib" :: d :: rem -> + Flags.coqlib_spec := true; Flags.coqlib := d ; parse (op,fl) rem + | "-coqlib" :: _ -> usage () + | "-camlbin" :: d :: rem -> + Flags.camlbin_spec := true; Flags.camlbin := d ; parse (op,fl) rem + | "-camlbin" :: _ -> usage () + | "-camlp4bin" :: d :: rem -> + Flags.camlp4bin_spec := true; Flags.camlp4bin := d ; parse (op,fl) rem + | "-camlp4bin" :: _ -> usage () + | "-boot" :: rem -> Flags.boot := true; parse (op,fl) rem | "-opt" :: rem -> opt := true ; parse (op,fl) rem | "-full" :: rem -> full := true ; parse (op,fl) rem | "-top" :: rem -> top := true ; parse (op,fl) rem @@ -198,59 +212,23 @@ let clean file = rm (basename ^ ".cmx") end -(* Gives all modules in [dir]. Uses [.cmi] suffixes. Uses [Unix]. *) -let all_modules_in_dir dir = - try - let lst = ref [] - and dh = Unix.opendir dir in - try - while true do - let stg = Unix.readdir dh in - if (Filename.check_suffix stg ".cmi") then - lst := !lst @ [String.capitalize (Filename.chop_suffix stg ".cmi")] - done; - [] - with End_of_file -> - Unix.closedir dh; !lst - with Unix.Unix_error (_,"opendir",_) -> - failwith ("all_modules_in_dir: directory "^dir^" not found") - -(* Gives a part of command line (corresponding to dir) for [extract_crc] *) -let crc_cmd dir = - " -I "^dir^(List.fold_right (fun x y -> " "^x^y) (all_modules_in_dir dir) - "") - -(* Same as [crc_cmd] but recursively *) -let rec_crc_cmd dir = - List.fold_right (fun x y -> x^y) (List.map crc_cmd (all_subdirs dir)) "" - (* Creates another temporary file for Dynlink if needed *) let tmp_dynlink()= let tmp = Filename.temp_file "coqdynlink" ".ml" in let _ = Sys.command ("echo \"Dynlink.init();;\" > "^tmp) in - let _ = Sys.command (Coq_config.camllib^"/extract_crc"^(crc_cmd - Coq_config.camllib)^(crc_cmd Coq_config.camlp4lib)^(rec_crc_cmd - Coq_config.coqtop)^" >> "^tmp) in - let _ = Sys.command ("echo \";;\" >> "^tmp) in - let _ = - Sys.command ("echo \"Dynlink.add_available_units crc_unit_list;;\" >> "^ - tmp) - in tmp (* Initializes the kind of loading in the main program *) let declare_loading_string () = - if !opt then - "Mltop.set Mltop.Native;;\n" - else if not !top then - "Mltop.set Mltop.WithoutTop;;\n" + if not !top then + "Mltop.remove ();;" else "let ppf = Format.std_formatter;; - Mltop.set (Mltop.WithTop + Mltop.set_top {Mltop.load_obj=Topdirs.dir_load ppf; Mltop.use_file=Topdirs.dir_use ppf; Mltop.add_dir=Topdirs.dir_directory; - Mltop.ml_loop=(fun () -> Toploop.loop ppf) });;\n" + Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\n" (* create a temporary main file to link *) let create_tmp_main_file modules = @@ -279,16 +257,17 @@ let create_tmp_main_file modules = let main () = let (options, userfiles) = parse_args () in (* which ocaml command to invoke *) + let camlbin = Envars.camlbin () in let prog = if !opt then begin (* native code *) if !top then failwith "no custom toplevel in native code !"; - let ocamloptexec = Filename.concat Coq_config.camldir "ocamlopt" in + let ocamloptexec = Filename.concat camlbin "ocamlopt" in ocamloptexec^" -linkall" end else (* bytecode (we shunt ocamlmktop script which fails on win32) *) let ocamlmktoplib = " toplevellib.cma" in - let ocamlcexec = Filename.concat Coq_config.camldir "ocamlc" in + let ocamlcexec = Filename.concat camlbin "ocamlc" in let ocamlccustom = Printf.sprintf "%s %s -linkall " ocamlcexec Coq_config.coqrunbyteflags in (if !top then ocamlccustom^ocamlmktoplib else ocamlccustom) @@ -307,22 +286,22 @@ let main () = try let args = options @ (includes ()) @ copts @ tolink @ dynlink @ [ main_file ] in - (* add topstart.cmo explicitly because we shunted ocamlmktop wrapper *) + (* add topstart.cmo explicitly because we shunted ocamlmktop wrapper *) let args = if !top then args @ [ "topstart.cmo" ] else args in - (* Now, with the .cma, we MUST use the -linkall option *) + (* Now, with the .cma, we MUST use the -linkall option *) let command = String.concat " " (prog::"-rectypes"::args) in - if !echo then - begin - print_endline command; - print_endline - ("(command length is " ^ - (string_of_int (String.length command)) ^ " characters)"); - flush Pervasives.stdout - end; - let retcode = Sys.command command in - clean main_file; - (* command gives the exit code in HSB, and signal in LSB !!! *) - if retcode > 255 then retcode lsr 8 else retcode + if !echo then + begin + print_endline command; + print_endline + ("(command length is " ^ + (string_of_int (String.length command)) ^ " characters)"); + flush Pervasives.stdout + end; + let retcode = Sys.command command in + clean main_file; + (* command gives the exit code in HSB, and signal in LSB !!! *) + if retcode > 255 then retcode lsr 8 else retcode with e -> clean main_file; raise e diff --git a/tactics/auto.ml b/tactics/auto.ml index 066ed786..1212656b 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: auto.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: auto.ml 11739 2009-01-02 19:33:19Z herbelin $ *) open Pp open Util @@ -59,6 +59,8 @@ type pri_auto_tactic = { code : auto_tactic (* the tactic to apply when the concl matches pat *) } +type hint_entry = global_reference option * pri_auto_tactic + let pri_ord {pri=pri1} {pri=pri2} = pri1 - pri2 let pri_order {pri=pri1} {pri=pri2} = pri1 <= pri2 @@ -110,34 +112,60 @@ module Constr_map = Map.Make(struct let compare = Pervasives.compare end) +let is_transparent_gr (ids, csts) = function + | VarRef id -> Idpred.mem id ids + | ConstRef cst -> Cpred.mem cst csts + | IndRef _ | ConstructRef _ -> false + +let fmt_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_THEN_trivial_fail (c,clenv) -> + (str"apply " ++ pr_lconstr c ++ str" ; trivial") + | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) + | Extern tac -> + (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) + +let pr_autotactic = fmt_autotactic + module Hint_db = struct type t = { hintdb_state : Names.transparent_state; use_dn : bool; - hintdb_map : search_entry Constr_map.t + hintdb_map : search_entry Constr_map.t; + (* A list of unindexed entries starting with an unfoldable constant + or with no associated pattern. *) + hintdb_nopat : stored_data list } - let empty use_dn = { hintdb_state = empty_transparent_state; - use_dn = use_dn; - hintdb_map = Constr_map.empty } + let empty st use_dn = { hintdb_state = st; + use_dn = use_dn; + hintdb_map = Constr_map.empty; + hintdb_nopat = [] } let find key db = try Constr_map.find key db.hintdb_map with Not_found -> empty_se - + let map_all k db = let (l,l',_) = find k db in - Sort.merge pri_order l l' + Sort.merge pri_order (db.hintdb_nopat @ l) l' let map_auto (k,c) db = let st = if db.use_dn then Some db.hintdb_state else None in - lookup_tacs (k,c) st (find k db) - + let l' = lookup_tacs (k,c) st (find k db) in + Sort.merge pri_order db.hintdb_nopat l' + let is_exact = function | Give_exact _ -> true | _ -> false + let rebuild_db st' db = + { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map } + let add_one (k,v) db = let st',rebuild = match v.code with @@ -148,27 +176,43 @@ module Hint_db = struct | EvalConstRef cst -> (ids, Cpred.add cst csts)), true | _ -> db.hintdb_state, false in - let dnst, db = - if db.use_dn then - Some st', { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map } - else None, db + let dnst, db, k = + if db.use_dn then + let db', k' = + if rebuild then rebuild_db st' db, k + else (* not an unfold *) + (match k with + | Some gr -> db, if is_transparent_gr st' gr then None else k + | None -> db, None) + in + (Some st', db', k') + else None, db, k in - let oval = find k db in let pat = if not db.use_dn && is_exact v.code then None else v.pat in - { db with hintdb_map = Constr_map.add k (add_tac pat v dnst oval) db.hintdb_map; - hintdb_state = st' } + match k with + | None -> + if not (List.mem v db.hintdb_nopat) then + { db with hintdb_nopat = v :: db.hintdb_nopat } + else db + | Some gr -> + let oval = find gr db in + { db with hintdb_map = Constr_map.add gr (add_tac pat v dnst oval) db.hintdb_map; + hintdb_state = st' } let add_list l db = List.fold_right add_one l db - let iter f db = Constr_map.iter (fun k (l,l',_) -> f k (l@l')) db.hintdb_map + let iter f db = + f None db.hintdb_nopat; + Constr_map.iter (fun k (l,l',_) -> f (Some k) (l@l')) db.hintdb_map let transparent_state db = db.hintdb_state - let set_transparent_state db st = { db with hintdb_state = st } + let set_transparent_state db st = + let db = if db.use_dn then rebuild_db st db else db in + { db with hintdb_state = st } - let set_rigid db cst = - let (ids,csts) = db.hintdb_state in - { db with hintdb_state = (ids, Cpred.remove cst csts) } + let use_dn db = db.use_dn + end module Hintdbmap = Gmap @@ -235,21 +279,21 @@ let make_exact_entry pri (c,cty) = let ce = mk_clenv_from dummy_goal (c,cty) in let c' = clenv_type ce in let pat = Pattern.pattern_of_constr c' in - (head_of_constr_reference (List.hd (head_constr cty)), + (Some (head_of_constr_reference (fst (head_constr cty))), { pri=(match pri with Some pri -> pri | None -> 0); pat=Some pat; code=Give_exact c }) -let make_apply_entry env sigma (eapply,verbose) pri (c,cty) = - let cty = hnf_constr env sigma cty in - match kind_of_term cty with +let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) = + let cty = if hnf then hnf_constr env sigma cty else cty in + match kind_of_term cty with | Prod _ -> let ce = mk_clenv_from dummy_goal (c,cty) in let c' = clenv_type ce in let pat = Pattern.pattern_of_constr c' in let hd = (try head_pattern_bound pat - with BoundPattern -> failwith "make_apply_entry") in + with BoundPattern -> failwith "make_apply_entry") in let nmiss = List.length (clenv_missing ce) in if nmiss = 0 then - (hd, + (Some hd, { pri = (match pri with None -> nb_hyp cty | Some p -> p); pat = Some pat; code = Res_pf(c,{ce with env=empty_env}) }) @@ -258,14 +302,14 @@ let make_apply_entry env sigma (eapply,verbose) pri (c,cty) = if verbose then warn (str "the hint: eapply " ++ pr_lconstr c ++ str " will only be used by eauto"); - (hd, + (Some hd, { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); pat = Some pat; code = ERes_pf(c,{ce with env=empty_env}) }) end | _ -> failwith "make_apply_entry" -(* flags is (e,v) with e=true if eapply and v=true if verbose +(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose c is a constr cty is the type of constr *) @@ -279,14 +323,14 @@ let make_resolves env sigma flags pri c = if ents = [] then errorlabstrm "Hint" (pr_lconstr c ++ spc() ++ - (if fst flags then str"cannot be used as a hint." + (if pi1 flags then str"cannot be used as a hint." else str "can be used as a hint only for eauto.")); ents (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma (hname,_,htyp) = try - [make_apply_entry env sigma (true, false) None + [make_apply_entry env sigma (true, true, false) None (mkVar hname, htyp)] with | Failure _ -> [] @@ -294,23 +338,23 @@ let make_resolve_hyp env sigma (hname,_,htyp) = (* REM : in most cases hintname = id *) let make_unfold (ref, eref) = - (ref, + (Some ref, { pri = 4; pat = None; code = Unfold_nth eref }) let make_extern pri pat tacast = - let hdconstr = try_head_pattern pat in + let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri=pri; - pat = Some pat; + pat = pat; code= Extern tacast }) let make_trivial env sigma c = let t = hnf_constr env sigma (type_of env sigma c) in - let hd = head_of_constr_reference (List.hd (head_constr t)) in + let hd = head_of_constr_reference (fst (head_constr t)) in let ce = mk_clenv_from dummy_goal (c,t) in - (hd, { pri=1; + (Some hd, { pri=1; pat = Some (Pattern.pattern_of_constr (clenv_type ce)); code=Res_pf_THEN_trivial_fail(c,{ce with env=empty_env}) }) @@ -328,15 +372,29 @@ let add_hint dbname hintlist = let db' = Hint_db.add_list hintlist db in searchtable_add (dbname,db') with Not_found -> - let db = Hint_db.add_list hintlist (Hint_db.empty false) in + let db = Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false) in searchtable_add (dbname,db) -type hint_action = CreateDB of bool | UpdateDB of (global_reference * pri_auto_tactic) list +let add_transparency dbname grs b = + let db = searchtable_map dbname in + let st = Hint_db.transparent_state db in + let st' = + List.fold_left (fun (ids, csts) gr -> + match gr with + | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts) + | EvalVarRef v -> (if b then Idpred.add else Idpred.remove) v ids, csts) + st grs + in searchtable_add (dbname, Hint_db.set_transparent_state db st') + +type hint_action = | CreateDB of bool * transparent_state + | AddTransparency of evaluable_global_reference list * bool + | AddTactic of (global_reference option * pri_auto_tactic) list let cache_autohint (_,(local,name,hints)) = match hints with - | CreateDB b -> searchtable_add (name, Hint_db.empty b) - | UpdateDB hints -> add_hint name hints + | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b) + | AddTransparency (grs, b) -> add_transparency name grs b + | AddTactic hints -> add_hint name hints let forward_subst_tactic = ref (fun _ -> failwith "subst_tactic is not installed for auto") @@ -351,11 +409,15 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) = code = code ; } in - let subst_hint (lab,data as hint) = - let lab',elab' = subst_global subst lab in - let lab' = - try head_of_constr_reference (List.hd (head_constr_bound elab' [])) - with Tactics.Bound -> lab' in + let subst_key gr = + let (lab'', elab') = subst_global subst gr in + let gr' = + (try head_of_constr_reference (fst (head_constr_bound elab')) + with Tactics.Bound -> lab'') + in if gr' == gr then gr else gr' + in + let subst_hint (k,data as hint) = + let k' = Option.smartmap subst_key k in let data' = match data.code with | Res_pf (c, clenv) -> let c' = subst_mps subst c in @@ -383,18 +445,21 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) = if tac==tac' then data else trans_data data (Extern tac') in - if lab' == lab && data' == data then hint else - (lab',data') + if k' == k && data' == data then hint else + (k',data') in match hintlist with | CreateDB _ -> obj - | UpdateDB hintlist -> + | AddTransparency (grs, b) -> + let grs' = list_smartmap (subst_evaluable_reference subst) grs in + if grs==grs' then obj else (local, name, AddTransparency (grs', b)) + | AddTactic hintlist -> let hintlist' = list_smartmap subst_hint hintlist in if hintlist' == hintlist then obj else - (local,name,UpdateDB hintlist') + (local,name,AddTactic hintlist') let classify_autohint (_,((local,name,hintlist) as obj)) = - if local or hintlist = (UpdateDB []) then Dispose else Substitute obj + if local or hintlist = (AddTactic []) then Dispose else Substitute obj let export_autohint ((local,name,hintlist) as obj) = if local then None else Some obj @@ -408,8 +473,8 @@ let (inAutoHint,outAutoHint) = export_function = export_autohint } -let create_hint_db l n b = - Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB b)) +let create_hint_db l n st b = + Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st))) (**************************************************************************) (* The "Hint" vernacular command *) @@ -419,29 +484,40 @@ let add_resolves env sigma clist local dbnames = (fun dbname -> Lib.add_anonymous_leaf (inAutoHint - (local,dbname, UpdateDB - (List.flatten (List.map (fun (x, y) -> - make_resolves env sigma (true,Flags.is_verbose()) x y) clist))))) + (local,dbname, AddTactic + (List.flatten (List.map (fun (x, hnf, y) -> + make_resolves env sigma (true,hnf,Flags.is_verbose()) x y) clist))))) dbnames let add_unfolds l local dbnames = List.iter (fun dbname -> Lib.add_anonymous_leaf - (inAutoHint (local,dbname, UpdateDB (List.map make_unfold l)))) + (inAutoHint (local,dbname, AddTactic (List.map make_unfold l)))) + dbnames + +let add_transparency l b local dbnames = + List.iter + (fun dbname -> Lib.add_anonymous_leaf + (inAutoHint (local,dbname, AddTransparency (l, b)))) dbnames -let add_extern pri (patmetas,pat) tacast local dbname = +let add_extern pri pat tacast local dbname = (* We check that all metas that appear in tacast have at least one occurence in the left pattern pat *) let tacmetas = [] in - match (list_subtract tacmetas patmetas) with - | i::_ -> - errorlabstrm "add_extern" - (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound.") - | [] -> + match pat with + | Some (patmetas,pat) -> + (match (list_subtract tacmetas patmetas) with + | i::_ -> + errorlabstrm "add_extern" + (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound.") + | [] -> + Lib.add_anonymous_leaf + (inAutoHint(local,dbname, AddTactic [make_extern pri (Some pat) tacast]))) + | None -> Lib.add_anonymous_leaf - (inAutoHint(local,dbname, UpdateDB [make_extern pri pat tacast])) + (inAutoHint(local,dbname, AddTactic [make_extern pri None tacast])) let add_externs pri pat tacast local dbnames = List.iter (add_extern pri pat tacast local) dbnames @@ -450,7 +526,7 @@ let add_trivials env sigma l local dbnames = List.iter (fun dbname -> Lib.add_anonymous_leaf ( - inAutoHint(local,dbname, UpdateDB (List.map (make_trivial env sigma) l)))) + inAutoHint(local,dbname, AddTactic (List.map (make_trivial env sigma) l)))) dbnames let forward_intern_tac = @@ -464,7 +540,7 @@ let add_hints local dbnames0 h = let f = Constrintern.interp_constr sigma env in match h with | HintsResolve lhints -> - add_resolves env sigma (List.map (fun (pri, x) -> pri, f x) lhints) local dbnames + add_resolves env sigma (List.map (fun (pri, b, x) -> pri, b, f x) lhints) local dbnames | HintsImmediate lhints -> add_trivials env sigma (List.map f lhints) local dbnames | HintsUnfold lhints -> @@ -478,21 +554,35 @@ let add_hints local dbnames0 h = (str "Cannot coerce" ++ spc () ++ pr_global gr ++ spc () ++ str "to an evaluable reference.") in - if !Flags.dump then Constrintern.add_glob (loc_of_reference r) gr; + Dumpglob.add_glob (loc_of_reference r) gr; (gr,r') in add_unfolds (List.map f lhints) local dbnames + | HintsTransparency (lhints, b) -> + let f r = + let gr = Syntax_def.global_with_alias r in + let r' = match gr with + | ConstRef c -> EvalConstRef c + | VarRef c -> EvalVarRef c + | _ -> + errorlabstrm "evalref_of_ref" + (str "Cannot coerce" ++ spc () ++ pr_global gr ++ spc () ++ + str "to an evaluable reference.") + in + Dumpglob.add_glob (loc_of_reference r) gr; + r' in + add_transparency (List.map f lhints) b local dbnames | HintsConstructors lqid -> let add_one qid = let env = Global.env() and sigma = Evd.empty in let isp = inductive_of_reference qid in let consnames = (snd (Global.lookup_inductive isp)).mind_consnames in let lcons = list_tabulate - (fun i -> None, mkConstruct (isp,i+1)) (Array.length consnames) in + (fun i -> None, true, mkConstruct (isp,i+1)) (Array.length consnames) in add_resolves env sigma lcons local dbnames in List.iter add_one lqid | HintsExtern (pri, patcom, tacexp) -> - let pat = Constrintern.interp_constrpattern Evd.empty (Global.env()) patcom in - let tacexp = !forward_intern_tac (fst pat) tacexp in + let pat = Option.map (Constrintern.intern_constr_pattern Evd.empty (Global.env())) patcom in + let tacexp = !forward_intern_tac (match pat with None -> [] | Some (l, _) -> l) tacexp in add_externs pri pat tacexp local dbnames | HintsDestruct(na,pri,loc,pat,code) -> if dbnames0<>[] then @@ -503,7 +593,7 @@ let add_hints local dbnames0 h = (* Functions for printing the hints *) (**************************************************************************) -let fmt_autotactic = +let pr_autotactic = function | Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c) | ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c) @@ -514,19 +604,19 @@ let fmt_autotactic = | Extern tac -> (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) -let fmt_hint v = - (fmt_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ()) +let pr_hint v = + (pr_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ()) -let fmt_hint_list hintlist = - (str " " ++ hov 0 (prlist fmt_hint hintlist) ++ fnl ()) +let pr_hint_list hintlist = + (str " " ++ hov 0 (prlist pr_hint hintlist) ++ fnl ()) -let fmt_hints_db (name,db,hintlist) = +let pr_hints_db (name,db,hintlist) = (str "In the database " ++ str name ++ str ":" ++ if hintlist = [] then (str " nothing" ++ fnl ()) - else (fnl () ++ fmt_hint_list hintlist)) + else (fnl () ++ pr_hint_list hintlist)) (* Print all hints associated to head c in any database *) -let fmt_hint_list_for_head c = +let pr_hint_list_for_head c = let dbs = Hintdbmap.to_list !searchtable in let valid_dbs = map_succeed @@ -538,19 +628,16 @@ let fmt_hint_list_for_head c = else hov 0 (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++ - hov 0 (prlist fmt_hints_db valid_dbs)) + hov 0 (prlist pr_hints_db valid_dbs)) -let fmt_hint_ref ref = fmt_hint_list_for_head ref +let pr_hint_ref ref = pr_hint_list_for_head ref (* Print all hints associated to head id in any database *) -let print_hint_ref ref = ppnl(fmt_hint_ref ref) +let print_hint_ref ref = ppnl(pr_hint_ref ref) -let fmt_hint_term cl = +let pr_hint_term cl = try - let (hdc,args) = match head_constr_bound cl [] with - | hdc::args -> (hdc,args) - | [] -> assert false - in + let (hdc,args) = head_constr_bound cl in let hd = head_of_constr_reference hdc in let dbs = Hintdbmap.to_list !searchtable in let valid_dbs = @@ -568,14 +655,14 @@ let fmt_hint_term cl = (str "No hint applicable for current goal") else (str "Applicable Hints :" ++ fnl () ++ - hov 0 (prlist fmt_hints_db valid_dbs)) + hov 0 (prlist pr_hints_db valid_dbs)) with Bound | Match_failure _ | Failure _ -> (str "No hint applicable for current goal") let error_no_such_hint_database x = error ("No such Hint database: "^x^".") -let print_hint_term cl = ppnl (fmt_hint_term cl) +let print_hint_term cl = ppnl (pr_hint_term cl) (* print all hints that apply to the concl of the current goal *) let print_applicable_hint () = @@ -591,9 +678,15 @@ let print_hint_db db = str"Unfoldable constant definitions: " ++ pr_cpred csts ++ fnl ())); Hint_db.iter (fun head hintlist -> - msg (hov 0 - (str "For " ++ pr_global head ++ str " -> " ++ - fmt_hint_list hintlist))) + match head with + | Some head -> + msg (hov 0 + (str "For " ++ pr_global head ++ str " -> " ++ + pr_hint_list hintlist)) + | None -> + msg (hov 0 + (str "For any goal -> " ++ + pr_hint_list hintlist))) db let print_hint_db_by_name dbname = @@ -618,7 +711,10 @@ let print_searchtable () = (* tactics with a trace mechanism for automatic search *) (**************************************************************************) -let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) +let priority l = List.filter (fun (_,hint) -> hint.pri = 0) l + +let select_unfold_extern = + List.filter (function (_,{code = (Unfold_nth _ | Extern _)}) -> true | _ -> false) (* tell auto not to reuse already instantiated metas in unification (for compatibility, since otherwise, apply succeeds oftener) *) @@ -633,25 +729,33 @@ let auto_unif_flags = { (* Try unification with the precompiled clause, then use registered Apply *) -let unify_resolve_nodelta (c,clenv) gls = - let clenv' = connect_clenv gls clenv in - let _ = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gls in - h_simplest_apply c gls +let unify_resolve_nodelta (c,clenv) gl = + let clenv' = connect_clenv gl clenv in + let _ = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in + h_simplest_apply c gl -let unify_resolve flags (c,clenv) gls = - let clenv' = connect_clenv gls clenv in - let _ = clenv_unique_resolver false ~flags clenv' gls in - h_apply true false [c,NoBindings] gls +let unify_resolve flags (c,clenv) gl = + let clenv' = connect_clenv gl clenv in + let _ = clenv_unique_resolver false ~flags clenv' gl in + h_apply true false [inj_open c,NoBindings] gl +let unify_resolve_gen = function + | None -> unify_resolve_nodelta + | Some flags -> unify_resolve flags (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types *) -let make_local_hint_db eapply lems g = - let sign = pf_hyps g in - let hintlist = list_map_append (pf_apply make_resolve_hyp g) sign in - let hintlist' = list_map_append (pf_apply make_resolves g (eapply,false) None) lems in - Hint_db.add_list hintlist' (Hint_db.add_list hintlist (Hint_db.empty false)) +let add_hint_lemmas eapply lems hint_db gl = + let hintlist' = + list_map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in + Hint_db.add_list hintlist' hint_db + +let make_local_hint_db eapply lems gl = + let sign = pf_hyps gl in + let hintlist = list_map_append (pf_apply make_resolve_hyp gl) sign in + add_hint_lemmas eapply lems + (Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false)) gl (* Serait-ce possible de compiler d'abord la tactique puis de faire la substitution sans passer par bdize dont l'objectif est de préparer un @@ -671,10 +775,13 @@ let forward_interp_tactic = let set_extern_interp f = forward_interp_tactic := f let conclPattern concl pat tac gl = - let constr_bindings = - try matches pat concl - with PatternMatchingFailure -> error "conclPattern" in - !forward_interp_tactic constr_bindings tac gl + let constr_bindings = + match pat with + | None -> [] + | Some pat -> + try matches pat concl + with PatternMatchingFailure -> error "conclPattern" in + !forward_interp_tactic constr_bindings tac gl (**************************************************************************) (* The Trivial tactic *) @@ -684,6 +791,10 @@ let conclPattern concl pat tac gl = (* Papageno : cette fonction a été pas mal simplifiée depuis que la base de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) +let flags_of_state st = + {auto_unif_flags with + modulo_conv_on_closed_terms = Some st; modulo_delta = st} + let rec trivial_fail_db mod_delta db_list local_db gl = let intro_tac = tclTHEN intro @@ -697,29 +808,12 @@ let rec trivial_fail_db mod_delta db_list local_db gl = (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl and my_find_search_nodelta db_list local_db hdc concl = - let tacl = - if occur_existential concl then - list_map_append (Hint_db.map_all hdc) - (local_db::db_list) - else - list_map_append (Hint_db.map_auto (hdc,concl)) - (local_db::db_list) - in - List.map - (fun {pri=b; pat=p; code=t} -> - (b, - match t with - | Res_pf (term,cl) -> unify_resolve_nodelta (term,cl) - | ERes_pf (_,c) -> (fun gl -> error "eres_pf") - | Give_exact c -> exact_check c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN - (unify_resolve_nodelta (term,cl)) - (trivial_fail_db false db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> - conclPattern concl (Option.get p) tacast)) - tacl + if occur_existential concl then + List.map (fun hint -> (None,hint)) + (list_map_append (Hint_db.map_all hdc) (local_db::db_list)) + else + List.map (fun hint -> (None,hint)) + (list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_delta @@ -727,46 +821,51 @@ and my_find_search mod_delta = and my_find_search_delta db_list local_db hdc concl = let flags = {auto_unif_flags with use_metas_eagerly = true} in - let tacl = if occur_existential concl then list_map_append (fun db -> - let st = {flags with modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> (st,x)) (Hint_db.map_all hdc db)) + if Hint_db.use_dn db then + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (Some flags, x)) (Hint_db.map_auto (hdc,concl) db) + else + let flags = {flags with modulo_delta = Hint_db.transparent_state db} in + List.map (fun x -> (Some flags,x)) (Hint_db.map_all hdc db)) (local_db::db_list) else list_map_append (fun db -> - let (ids, csts as st) = Hint_db.transparent_state db in - let st, l = - let l = - if (Idpred.is_empty ids && Cpred.is_empty csts) - then Hint_db.map_auto (hdc,concl) db - else Hint_db.map_all hdc db - in {flags with modulo_delta = st}, l - in List.map (fun x -> (st,x)) l) + if Hint_db.use_dn db then + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (Some flags, x)) (Hint_db.map_auto (hdc,concl) db) + else + let (ids, csts as st) = Hint_db.transparent_state db in + let flags, l = + let l = + if (Idpred.is_empty ids && Cpred.is_empty csts) + then Hint_db.map_auto (hdc,concl) db + else Hint_db.map_all hdc db + in {flags with modulo_delta = st}, l + in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) - in - List.map - (fun (st, {pri=b; pat=p; code=t}) -> - (b, - match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (_,c) -> (fun gl -> error "eres_pf") - | Give_exact c -> exact_check c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN - (unify_resolve st (term,cl)) - (trivial_fail_db true db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> - conclPattern concl (Option.get p) tacast)) - tacl + +and tac_of_hint db_list local_db concl (flags, {pat=p; code=t}) = + match t with + | Res_pf (term,cl) -> unify_resolve_gen flags (term,cl) + | ERes_pf (_,c) -> (fun gl -> error "eres_pf") + | Give_exact c -> exact_check c + | Res_pf_THEN_trivial_fail (term,cl) -> + tclTHEN + (unify_resolve_gen flags (term,cl)) + (trivial_fail_db (flags <> None) db_list local_db) + | Unfold_nth c -> unfold_in_concl [all_occurrences,c] + | Extern tacast -> conclPattern concl p tacast and trivial_resolve mod_delta db_list local_db cl = try - let hdconstr = List.hd (head_constr_bound cl []) in - priority - (my_find_search mod_delta db_list local_db (head_of_constr_reference hdconstr) cl) + let hdconstr,_ = head_constr_bound cl in + List.map (tac_of_hint db_list local_db cl) + (priority + (my_find_search mod_delta db_list local_db + (head_of_constr_reference hdconstr) cl)) with Bound | Not_found -> [] @@ -804,70 +903,82 @@ let h_trivial lems l = let possible_resolve mod_delta db_list local_db cl = try - let hdconstr = List.hd (head_constr_bound cl []) in - List.map snd - (my_find_search mod_delta db_list local_db (head_of_constr_reference hdconstr) cl) + let hdconstr,_ = head_constr_bound cl in + List.map (tac_of_hint db_list local_db cl) + (my_find_search mod_delta db_list local_db + (head_of_constr_reference hdconstr) cl) with Bound | Not_found -> [] -let decomp_unary_term c gls = - let typc = pf_type_of gls c in - let hd = List.hd (head_constr typc) in - if Hipattern.is_conjunction hd then - simplest_case c gls - else - errorlabstrm "Auto.decomp_unary_term" (str "Not a unary type.") - -let decomp_empty_term c gls = - let typc = pf_type_of gls c in - let (hd,_) = decompose_app typc in - if Hipattern.is_empty_type hd then - simplest_case c gls +let decomp_unary_term_then (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 + | None -> + kont2 gl + with UserError _ -> kont2 gl + +let decomp_empty_term (id,_,typc) gl = + if Hipattern.is_empty_type typc then + simplest_case (mkVar 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 obtappined 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 (tclLAST_DECL (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 + (* 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 *) -let rec search_gen decomp n mod_delta db_list local_db extra_sign goal = - if n=0 then error "BOUND 2"; - let decomp_tacs = match decomp with - | 0 -> [] - | p -> - (tclTRY_sign decomp_empty_term extra_sign) - :: - (List.map - (fun id -> tclTHENSEQ - [decomp_unary_term (mkVar id); - clear [id]; - search_gen decomp p mod_delta db_list local_db []]) - (pf_ids_of_hyps goal)) - in - let intro_tac = - tclTHEN intro - (fun g' -> - let (hid,_,htyp as d) = pf_last_hyp g' in - let hintl = - try - [make_apply_entry (pf_env g') (project g') - (true,false) None - (mkVar hid, htyp)] - with Failure _ -> [] - in - search_gen decomp n mod_delta db_list (Hint_db.add_list hintl local_db) [d] g') - in - let rec_tacs = - List.map - (fun ntac -> - tclTHEN ntac - (search_gen decomp (n-1) mod_delta db_list local_db empty_named_context)) - (possible_resolve mod_delta db_list local_db (pf_concl goal)) - in - tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal +exception Uplift of tactic list +let rec search_gen p n mod_delta db_list local_db = + let rec search n local_db gl = + if n=0 then error "BOUND 2"; + tclFIRST + (assumption :: + intros_decomp p (search n) [] local_db 1 :: + List.map (fun ntac -> tclTHEN ntac (search (n-1) local_db)) + (possible_resolve mod_delta db_list local_db (pf_concl gl))) gl + in + search n local_db let search = search_gen 0 @@ -883,8 +994,7 @@ let delta_auto mod_delta n lems dbnames gl = error_no_such_hint_database x) ("core"::dbnames) in - let hyps = pf_hyps gl in - tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl) hyps) gl + tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl let auto = delta_auto false @@ -896,8 +1006,7 @@ let delta_full_auto mod_delta n lems gl = let dbnames = Hintdbmap.dom !searchtable in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map (fun x -> searchtable_map x) dbnames in - let hyps = pf_hyps gl in - tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl) hyps) gl + tclTRY (search 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 @@ -922,14 +1031,15 @@ let h_auto n lems l = (* Depth of search after decomposition of hypothesis, by default one look for an immediate solution *) -(* Papageno : de toute façon un paramète > 1 est traité comme 1 pour - l'instant *) -let default_search_decomp = ref 1 - -let destruct_auto des_opt lems n gl = - let hyps = pf_hyps gl in - search_gen des_opt n false (List.map searchtable_map ["core";"extcore"]) - (make_local_hint_db false lems gl) hyps gl +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) @@ -952,7 +1062,7 @@ let make_resolve_any_hyp env sigma (id,_,ty) = let ents = map_succeed (fun f -> f (mkVar id,ty)) - [make_exact_entry None; make_apply_entry env sigma (true,false) None] + [make_exact_entry None; make_apply_entry env sigma (true,true,false) None] in ents @@ -988,25 +1098,23 @@ let compileAutoArg contac = function let compileAutoArgList contac = List.map (compileAutoArg contac) -let rec super_search n db_list local_db argl goal = +let rec super_search n db_list local_db argl gl = if n = 0 then error "BOUND 2"; tclFIRST (assumption :: - (tclTHEN intro + 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)) + argl g) :: - ((List.map - (fun ntac -> + List.map (fun ntac -> tclTHEN ntac (super_search (n-1) db_list local_db argl)) - (possible_resolve false db_list local_db (pf_concl goal))) + (possible_resolve false db_list local_db (pf_concl gl)) @ - (compileAutoArgList - (super_search (n-1) db_list local_db argl) argl))) goal + compileAutoArgList (super_search (n-1) db_list local_db argl) argl) gl let search_superauto n to_add argl g = let sigma = diff --git a/tactics/auto.mli b/tactics/auto.mli index edaaa1c1..c9065ef3 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: auto.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: auto.mli 11735 2009-01-02 17:22:31Z herbelin $ i*) (*i*) open Util @@ -44,20 +44,24 @@ type stored_data = pri_auto_tactic type search_entry = stored_data list * stored_data list * stored_data Btermdn.t +(* The head may not be bound. *) + +type hint_entry = global_reference option * pri_auto_tactic + module Hint_db : sig type t - val empty : bool -> t + val empty : transparent_state -> bool -> t val find : global_reference -> t -> search_entry val map_all : global_reference -> t -> pri_auto_tactic list val map_auto : global_reference * constr -> t -> pri_auto_tactic list - val add_one : global_reference * pri_auto_tactic -> t -> t - val add_list : (global_reference * pri_auto_tactic) list -> t -> t - val iter : (global_reference -> stored_data list -> unit) -> t -> unit + val add_one : hint_entry -> t -> t + val add_list : (hint_entry) list -> t -> t + val iter : (global_reference option -> stored_data list -> unit) -> t -> unit + val use_dn : t -> bool val transparent_state : t -> transparent_state val set_transparent_state : t -> transparent_state -> t - val set_rigid : t -> constant -> t end type hint_db_name = string @@ -68,7 +72,12 @@ val searchtable_map : hint_db_name -> hint_db val searchtable_add : (hint_db_name * hint_db) -> unit -val create_hint_db : bool -> hint_db_name -> bool -> unit +(* [create_hint_db local name st use_dn]. + [st] is a transparency state for unification using this db + [use_dn] switches the use of the discrimination net for all hints + and patterns. *) + +val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit val current_db_names : unit -> hint_db_name list @@ -86,16 +95,18 @@ val print_hint_db_by_name : hint_db_name -> unit [c] is the term given as an exact proof to solve the goal; [ctyp] is the type of [c]. *) -val make_exact_entry : int option -> constr * constr -> global_reference * pri_auto_tactic +val make_exact_entry : int option -> constr * constr -> hint_entry (* [make_apply_entry (eapply,verbose) pri (c,cty)]. [eapply] is true if this hint will be used only with EApply; + [hnf] should be true if we should expand the head of cty before searching for + products; [c] is the term given as an exact proof to solve the goal; - [cty] is the type of [hc]. *) - + [cty] is the type of [c]. *) + val make_apply_entry : - env -> evar_map -> bool * bool -> int option -> constr * constr - -> global_reference * pri_auto_tactic + env -> evar_map -> bool * bool * bool -> int option -> constr * constr + -> hint_entry (* A constr which is Hint'ed will be: (1) used as an Exact, if it does not start with a product @@ -105,8 +116,8 @@ val make_apply_entry : has missing arguments. *) val make_resolves : - env -> evar_map -> bool * bool -> int option -> constr -> - (global_reference * pri_auto_tactic) list + env -> evar_map -> bool * bool * bool -> int option -> constr -> + hint_entry list (* [make_resolve_hyp hname htyp]. used to add an hypothesis to the local hint database; @@ -114,14 +125,13 @@ val make_resolves : If the hyp cannot be used as a Hint, the empty list is returned. *) val make_resolve_hyp : - env -> evar_map -> named_declaration -> - (global_reference * pri_auto_tactic) list + env -> evar_map -> named_declaration -> hint_entry list (* [make_extern pri pattern tactic_expr] *) val make_extern : - int -> constr_pattern -> Tacexpr.glob_tactic_expr - -> global_reference * pri_auto_tactic + int -> constr_pattern option -> Tacexpr.glob_tactic_expr + -> hint_entry val set_extern_interp : (patvar_map -> Tacexpr.glob_tactic_expr -> tactic) -> unit @@ -140,7 +150,7 @@ val set_extern_subst_tactic : val make_local_hint_db : bool -> constr list -> goal sigma -> hint_db -val priority : (int * 'a) list -> 'a list +val priority : ('a * pri_auto_tactic) list -> ('a * pri_auto_tactic) list val default_search_depth : int ref @@ -156,7 +166,7 @@ val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the right values to build a tactic *) -val conclPattern : constr -> constr_pattern -> Tacexpr.glob_tactic_expr -> tactic +val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> tactic (* The Auto tactic *) @@ -192,7 +202,7 @@ val gen_trivial : constr list -> hint_db_name list option -> tactic val full_trivial : constr list -> tactic val h_trivial : constr list -> hint_db_name list option -> tactic -val fmt_autotactic : auto_tactic -> Pp.std_ppcmds +val pr_autotactic : auto_tactic -> Pp.std_ppcmds (*s The following is not yet up to date -- Papageno. *) diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index 6eb5e359..e609fb77 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -9,7 +9,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: class_tactics.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: class_tactics.ml4 11823 2009-01-21 15:32:37Z msozeau $ *) open Pp open Util @@ -43,7 +43,8 @@ open Evd let default_eauto_depth = 100 let typeclasses_db = "typeclass_instances" -let _ = Auto.auto_init := (fun () -> Auto.create_hint_db false typeclasses_db false) +let _ = Auto.auto_init := (fun () -> + Auto.create_hint_db false typeclasses_db full_transparent_state true) let check_imported_library d = let d' = List.map id_of_string d in @@ -60,26 +61,20 @@ let init_setoid () = (** Typeclasses instance search tactic / eauto *) -let evars_of_term init c = - let rec evrec acc c = - match kind_of_term c with - | Evar (n, _) -> Intset.add n acc - | _ -> fold_constr evrec acc c - in - evrec init c - let intersects s t = Intset.exists (fun el -> Intset.mem el t) s open Auto -let e_give_exact c gl = +let e_give_exact flags c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in - if occur_existential t1 or occur_existential t2 then - tclTHEN (Clenvtac.unify t1) (exact_check c) gl - else exact_check c gl - -let assumption id = e_give_exact (mkVar id) + if occur_existential t1 or occur_existential t2 then + tclTHEN (Clenvtac.unify (* ~flags *) t1) (exact_no_check c) gl + else exact_check c gl +(* let t1 = (pf_type_of gl c) in *) +(* tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl *) + +let assumption flags id = e_give_exact flags (mkVar id) open Unification @@ -89,19 +84,21 @@ let auto_unif_flags = { modulo_delta = var_full_transparent_state; } -let unify_e_resolve st (c,clenv) gls = +let unify_e_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in - let clenv' = clenv_unique_resolver false - ~flags:{auto_unif_flags with modulo_delta = st} clenv' gls + let clenv' = clenv_unique_resolver false ~flags clenv' gls in - Clenvtac.clenv_refine true clenv' gls + Clenvtac.clenv_refine true ~with_classes:false clenv' gls -let unify_resolve st (c,clenv) gls = +let unify_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in - let clenv' = clenv_unique_resolver false - ~flags:{auto_unif_flags with modulo_delta = st} clenv' gls + let clenv' = clenv_unique_resolver false ~flags clenv' gls in - Clenvtac.clenv_refine false clenv' gls + Clenvtac.clenv_refine false ~with_classes:false clenv' gls + +let flags_of_state st = + {auto_unif_flags with + modulo_conv_on_closed_terms = Some st; modulo_delta = st} let rec e_trivial_fail_db db_list local_db goal = let tacl = @@ -119,47 +116,43 @@ let rec e_trivial_fail_db db_list local_db goal = and e_my_find_search db_list local_db hdc concl = let hdc = head_of_constr_reference hdc in let hintl = - if occur_existential concl then - list_map_append - (fun db -> - let st = Hint_db.transparent_state db in - List.map (fun x -> (st, x)) (Hint_db.map_all hdc db)) - (local_db::db_list) - else - list_map_append - (fun db -> - let st = Hint_db.transparent_state db in - List.map (fun x -> (st, x)) (Hint_db.map_auto (hdc,concl) db)) - (local_db::db_list) + list_map_append + (fun db -> + if Hint_db.use_dn db then + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (flags, x)) (Hint_db.map_auto (hdc,concl) db) + else + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (flags, x)) (Hint_db.map_all hdc db)) + (local_db::db_list) in let tac_of_hint = - fun (st, {pri=b; pat = p; code=t}) -> + fun (flags, {pri=b; pat = p; code=t}) -> let tac = match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve st (term,cl) - | Give_exact (c) -> e_give_exact c + | Res_pf (term,cl) -> unify_resolve flags (term,cl) + | ERes_pf (term,cl) -> unify_e_resolve flags (term,cl) + | Give_exact (c) -> e_give_exact flags c | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve st (term,cl)) + tclTHEN (unify_e_resolve flags (term,cl)) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> conclPattern concl - (Option.get p) tacast + | Extern tacast -> conclPattern concl p tacast in - (tac,b,fmt_autotactic t) + (tac,b,pr_autotactic t) in List.map tac_of_hint hintl and e_trivial_resolve db_list local_db gl = try e_my_find_search db_list local_db - (List.hd (head_constr_bound gl [])) gl + (fst (head_constr_bound gl)) gl with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = try e_my_find_search db_list local_db - (List.hd (head_constr_bound gl [])) gl + (fst (head_constr_bound gl)) gl with Bound | Not_found -> [] let find_first_goal gls = @@ -184,14 +177,14 @@ let rec catchable = function | e -> Logic.catchable_exception e let is_dep gl gls = - let evs = evars_of_term Intset.empty gl.evar_concl in + let evs = Evarutil.evars_of_term gl.evar_concl in if evs = Intset.empty then false else List.fold_left (fun b gl -> if b then b else - let evs' = evars_of_term Intset.empty gl.evar_concl in + let evs' = Evarutil.evars_of_term gl.evar_concl in intersects evs evs') false gls @@ -210,7 +203,7 @@ module SearchProblem = struct prlist (pr_ev evars) (sig_it gls) let filter_tactics (glls,v) l = - let glls,nv = apply_tac_list tclNORMEVAR glls in + let glls,nv = apply_tac_list Refiner.tclNORMEVAR glls in let v p = v (nv p) in let rec aux = function | [] -> [] @@ -243,37 +236,35 @@ module SearchProblem = struct [] else let (cut, do_cut, ldb as hdldb) = List.hd s.localdb in - if !cut then [] + if !cut then +(* let {it=gls; sigma=sigma} = fst s.tacres in *) +(* msg (str"cut:" ++ pr_ev sigma (List.hd gls) ++ str"\n"); *) + [] else begin - Option.iter (fun r -> r := true) do_cut; let {it=gl; sigma=sigma} = fst s.tacres in + Option.iter (fun r -> +(* msg (str"do cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *) + r := true) do_cut; + let sigma = Evarutil.nf_evars sigma in + let gl = List.map (Evarutil.nf_evar_info sigma) gl in let nbgl = List.length gl in - let g = { it = List.hd gl ; sigma = sigma } in +(* let gl' = { it = gl ; sigma = sigma } in *) +(* let tacres' = gl', snd s.tacres in *) let new_db, localdb = let tl = List.tl s.localdb in match tl with | [] -> hdldb, tl | (cut', do', ldb') :: rest -> - if not (is_dep (Evarutil.nf_evar_info sigma (List.hd gl)) (List.tl gl)) then + if not (is_dep (List.hd gl) (List.tl gl)) then let fresh = ref false in - if do' = None then + if do' = None then ( +(* msg (str"adding a cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *) (fresh, None, ldb), (cut', Some fresh, ldb') :: rest - else - (cut', None, ldb), tl + ) else ( +(* msg (str"keeping the previous cut:" ++ pr_ev sigma (List.hd gl) ++ str"\n"); *) + (cut', None, ldb), tl ) else hdldb, tl in let localdb = new_db :: localdb in - let assumption_tacs = - let l = - filter_tactics s.tacres - (List.map - (fun id -> (Eauto.e_give_exact_constr (mkVar id), 0, - (str "exact" ++ spc () ++ pr_id id))) - (List.filter (fun id -> filter_hyp (pf_get_hyp_typ g id)) - (pf_ids_of_hyps g))) - in - List.map (fun (res,pri,pp) -> { s with tacres = res; pri = 0; - last_tactic = pp; localdb = List.tl s.localdb }) l - in let intro_tac = List.map (fun ((lgls,_) as res,pri,pp) -> @@ -300,14 +291,13 @@ module SearchProblem = struct last_tactic = pp; pri = pri; localdb = list_tabulate (fun _ -> new_db) (nbgl'-nbgl) @ localdb } in - let concl = Evarutil.nf_evar (project g) (pf_concl g) in let rec_tacs = let l = - filter_tactics s.tacres (e_possible_resolve s.dblist ldb concl) + filter_tactics s.tacres (e_possible_resolve s.dblist ldb (List.hd gl).evar_concl) in List.map possible_resolve l in - List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) + List.sort compare (intro_tac @ rec_tacs) end let pp s = @@ -318,46 +308,6 @@ end module Search = Explore.Make(SearchProblem) - -let filter_pat c = - try - let morg = Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism")) in - let morc = constr_of_global morg in - match kind_of_term c with - | App(morph, [| t; r; m |]) when eq_constr morph morc -> - (fun y -> - (match y.pat with - Some (PApp (PRef mor, [| t'; r'; m' |])) when mor = morg -> - (match m' with - | PRef c -> if isConst m then eq_constr (constr_of_global c) m else false - | _ -> true) - | _ -> true)) - | _ -> fun _ -> true - with _ -> fun _ -> true - -let morphism_class = - lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism")))) - -let morphism_proxy_class = - lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.MorphismProxy")))) - -let filter c = - try let morc = constr_of_global (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism"))) in - match kind_of_term c with - | App(morph, [| t; r; m |]) when eq_constr morph morc -> - (fun y -> - let (_, r) = decompose_prod y in - (match kind_of_term r with - App (morph', [| t'; r'; m' |]) when eq_constr morph' morc -> - (match kind_of_term m' with - | Rel n -> true - | Const c -> eq_constr m m' - | App _ -> true - | _ -> false) - | _ -> false)) - | _ -> fun _ -> true - with _ -> fun _ -> true - let make_initial_state n gls dblist localdbs = { depth = n; tacres = gls; @@ -379,11 +329,39 @@ let e_breadth_search debug s = in let s = tac s in s.tacres with Not_found -> error "eauto: breadth first search failed." + +(* A special one for getting everything into a dnet. *) + +let is_transparent_gr (ids, csts) = function + | VarRef id -> Idpred.mem id ids + | ConstRef cst -> Cpred.mem cst csts + | IndRef _ | ConstructRef _ -> false + +let make_resolve_hyp env sigma st flags pri (id, _, cty) = + let ctx, ar = decompose_prod cty in + let keep = + match kind_of_term (fst (decompose_app ar)) with + | Const c -> is_class (ConstRef c) + | Ind i -> is_class (IndRef i) + | _ -> false + in + if keep then let c = mkVar id in + map_succeed + (fun f -> f (c,cty)) + [make_exact_entry pri; make_apply_entry env sigma flags pri] + else [] + +let make_local_hint_db st eapply lems g = + let sign = pf_hyps g in + let hintlist = list_map_append (pf_apply make_resolve_hyp g st (eapply,false,false) None) sign in + let hintlist' = list_map_append (pf_apply make_resolves g (eapply,false,false) None) lems in + Hint_db.add_list hintlist' (Hint_db.add_list hintlist (Hint_db.empty st true)) + let e_search_auto debug (in_depth,p) lems st db_list gls = let sigma = Evd.sig_sig (fst gls) and gls' = Evd.sig_it (fst gls) in let local_dbs = List.map (fun gl -> - let db = make_local_hint_db true lems ({it = gl; sigma = sigma}) in - (ref false, None, Hint_db.set_transparent_state db st)) gls' in + let db = make_local_hint_db st true lems ({it = gl; sigma = sigma}) in + (ref false, None, db)) gls' in let state = make_initial_state p gls db_list local_dbs in if in_depth then e_depth_search debug state @@ -394,7 +372,8 @@ let full_eauto debug n lems gls = let dbnames = current_db_names () in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map searchtable_map dbnames in - e_search_auto debug n lems empty_transparent_state db_list gls + let db = searchtable_map typeclasses_db in + e_search_auto debug n lems (Hint_db.transparent_state db) db_list gls let nf_goal (gl, valid) = { gl with sigma = Evarutil.nf_evars gl.sigma }, valid @@ -415,16 +394,23 @@ let valid goals p res_sigma l = else sigma) !res_sigma goals l in raise (Found evm) + +let is_dependent ev evm = + Evd.fold (fun ev' evi dep -> + if ev = ev' then dep + else dep || occur_evar ev evi.evar_concl) + evm false let resolve_all_evars_once debug (mode, depth) env p evd = let evm = Evd.evars_of evd in let goals, evm' = Evd.fold - (fun ev evi (gls, evm) -> + (fun ev evi (gls, evm') -> if evi.evar_body = Evar_empty && Typeclasses.is_resolvable evi - && p ev evi then ((ev,evi) :: gls, Evd.add evm ev (Typeclasses.mark_unresolvable evi)) else - (gls, Evd.add evm ev evi)) +(* && not (is_dependent ev evm) *) + && p ev evi then ((ev,evi) :: gls, Evd.add evm' ev (Typeclasses.mark_unresolvable evi)) else + (gls, Evd.add evm' ev evi)) evm ([], Evd.empty) in let goals = List.rev goals in @@ -463,7 +449,7 @@ let rec merge_deps deps = function let split_evars evm = Evd.fold (fun ev evi acc -> - let deps = evars_of_term (Intset.singleton ev) evi.evar_concl in + let deps = Intset.union (Intset.singleton ev) (Evarutil.evars_of_term evi.evar_concl) in merge_deps deps acc) evm [] @@ -501,7 +487,7 @@ let resolve_all_evars debug m env p oevd do_split fail = (fun ev evi (b,acc) -> (* focus on one instance if only one was searched for *) if class_of_constr evi.evar_concl <> None then - if not b then + if not b (* || do_split *) then true, Some ev else b, None else b, acc) evm (false, None) @@ -528,35 +514,36 @@ let _ = VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings -| [ "Typeclasses" "unfold" reference_list(cl) ] -> [ - add_hints false [typeclasses_db] (Vernacexpr.HintsUnfold cl) +| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ + add_hints false [typeclasses_db] (Vernacexpr.HintsTransparency (cl, true)) ] END - + VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings -| [ "Typeclasses" "rigid" reference_list(cl) ] -> [ - let db = searchtable_map typeclasses_db in - let db' = - List.fold_left (fun acc r -> - let gr = Syntax_def.global_with_alias r in - match gr with - | ConstRef c -> Hint_db.set_rigid acc c - | _ -> acc) db cl - in - searchtable_add (typeclasses_db,db') - ] +| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ + add_hints false [typeclasses_db] (Vernacexpr.HintsTransparency (cl, false)) + ] END (** Typeclass-based rewriting. *) -let respect_proj = lazy (mkConst (snd (List.hd (Lazy.force morphism_class).cl_projs))) +let morphism_class = + lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism")))) + +let morphism_proxy_class = + lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.MorphismProxy")))) + +let respect_proj = lazy (mkConst (Option.get (snd (List.hd (Lazy.force morphism_class).cl_projs)))) let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) -let try_find_reference dir s = +let try_find_global_reference dir s = let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in - constr_of_global (Nametab.absolute_reference sp) - + Nametab.absolute_reference sp + +let try_find_reference dir s = + constr_of_global (try_find_global_reference dir s) + let gen_constant dir s = Coqlib.gen_constant "Class_setoid" dir s let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1") let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2") @@ -565,23 +552,28 @@ let iff = lazy (gen_constant ["Init"; "Logic"] "iff") let coq_all = lazy (gen_constant ["Init"; "Logic"] "all") let impl = lazy (gen_constant ["Program"; "Basics"] "impl") let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow") -let coq_id = lazy (gen_constant ["Program"; "Basics"] "id") +let coq_id = lazy (gen_constant ["Init"; "Datatypes"] "id") let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive") +let reflexive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "reflexivity") let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity") let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric") let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry") +let symmetric_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "symmetry") let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive") let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity") +let transitive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "transitivity") let coq_inverse = lazy (gen_constant (* ["Classes"; "RelationClasses"] "inverse" *) ["Program"; "Basics"] "flip") let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) +(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; new_Type (); rel |]) *) let complement = lazy (gen_constant ["Classes"; "RelationClasses"] "complement") +let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") let respectful_dep = lazy (gen_constant ["Classes"; "Morphisms"] "respectful_dep") @@ -592,6 +584,8 @@ let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultR let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) +(* let mk_relation a = mkProd (Anonymous, a, mkProd (Anonymous, a, new_Type ())) *) + let coq_relationT = lazy (gen_constant ["Classes";"Relations"] "relationT") let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive") @@ -638,8 +632,6 @@ let split_head = function hd :: tl -> hd, tl | [] -> assert(false) -exception DependentMorphism - let build_signature isevars env m (cstrs : 'a option list) (finalcstr : 'a Lazy.t option) (f : 'a -> constr) = let new_evar isevars env t = Evarutil.e_new_evar isevars env @@ -656,21 +648,28 @@ let build_signature isevars env m (cstrs : 'a option list) (finalcstr : 'a Lazy. let t = Reductionops.whd_betadeltaiota env (Evd.evars_of !isevars) ty in match kind_of_term t, l with | Prod (na, ty, b), obj :: cstrs -> - if dependent (mkRel 1) ty then raise DependentMorphism; - let (b, arg, evars) = aux (Environ.push_rel (na, None, ty) env) b cstrs in - let ty = Reductionops.nf_betaiota ty in - let relty = mk_relty ty obj in - let arg' = mkApp (Lazy.force respectful, [| ty ; b ; relty ; arg |]) in - mkProd(na, ty, b), arg', (ty, relty) :: evars + if dependent (mkRel 1) b then + let (b, arg, evars) = aux (Environ.push_rel (na, None, ty) env) b cstrs in + let ty = Reductionops.nf_betaiota ty in + let pred = mkLambda (na, ty, b) in + let liftarg = mkLambda (na, ty, arg) in + let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in + mkProd(na, ty, b), arg', (ty, None) :: evars + else + let (b', arg, evars) = aux env (subst1 mkProp b) cstrs in + let ty = Reductionops.nf_betaiota ty in + let relty = mk_relty ty obj in + let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in + mkProd(na, ty, b), newarg, (ty, Some relty) :: evars | _, obj :: _ -> anomaly "build_signature: not enough products" | _, [] -> (match finalcstr with None -> let t = Reductionops.nf_betaiota ty in let rel = mk_relty t None in - t, rel, [t, rel] + t, rel, [t, Some rel] | Some codom -> let (t, rel) = Lazy.force codom in - t, rel, [t, rel]) + t, rel, [t, Some rel]) in aux env m cstrs let morphism_proof env evars carrier relation x = @@ -678,18 +677,15 @@ let morphism_proof env evars carrier relation x = mkApp (Lazy.force morphism_proxy_type, [| carrier ; relation; x |]) in Evarutil.e_new_evar evars env goal -let find_class_proof proof_type proof_method env carrier relation = +let find_class_proof proof_type proof_method env evars carrier relation = try - let goal = - mkApp (Lazy.force proof_type, [| carrier ; relation |]) - in - let inst = resolve_one_typeclass env goal in - mkApp (Lazy.force proof_method, [| carrier ; relation ; inst |]) + let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in + Typeclasses.resolve_one_typeclass env evars goal with e when Logic.catchable_exception e -> raise Not_found -let reflexive_proof env = find_class_proof reflexive_type reflexive_proof env -let symmetric_proof env = find_class_proof symmetric_type symmetric_proof env -let transitive_proof env = find_class_proof transitive_type transitive_proof env +let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env +let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env +let get_transitive_proof env = find_class_proof transitive_type transitive_proof env exception FoundInt of int @@ -711,28 +707,29 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars let cl_args = [| appmtype' ; signature ; appm |] in let app = mkApp (Lazy.force morphism_type, cl_args) in let morph = Evarutil.e_new_evar evars env app in - let proj = - mkApp (Lazy.force respect_proj, - Array.append cl_args [|morph|]) - in - morph, proj, sigargs, appm, morphobjs, morphobjs' + morph, morph, sigargs, appm, morphobjs, morphobjs' in let projargs, respars, typeargs = array_fold_left2 (fun (acc, sigargs, typeargs') x y -> let (carrier, relation), sigargs = split_head sigargs in - match y with - None -> - let proof = morphism_proof env evars carrier relation x in - [ proof ; x ; x ] @ acc, sigargs, x :: typeargs' - | Some (p, (_, _, _, t')) -> - [ p ; t'; x ] @ acc, sigargs, t' :: typeargs') + match relation with + | Some relation -> + (match y with + | None -> + let proof = morphism_proof env evars carrier relation x in + [ proof ; x ; x ] @ acc, sigargs, x :: typeargs' + | Some (p, (_, _, _, t')) -> + [ p ; t'; x ] @ acc, sigargs, t' :: typeargs') + | None -> + if y <> None then error "Cannot rewrite the argument of a dependent function"; + x :: acc, sigargs, x :: typeargs') ([], sigargs, []) args args' in let proof = applistc proj (List.rev projargs) in let newt = applistc m' (List.rev typeargs) in match respars with - [ a, r ] -> (proof, (a, r, oldt, fnewt newt)) + [ a, Some r ] -> (proof, (a, r, oldt, fnewt newt)) | _ -> assert(false) (* Adapted from setoid_replace. *) @@ -755,24 +752,32 @@ let evd_convertible env evd x y = let decompose_setoid_eqhyp env sigma c left2right = let ctype = Typing.type_of env sigma c in - let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ctype) in - let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in - let rec split_last_two = function - | [c1;c2] -> [],(c1, c2) - | x::y::z -> - let l,res = split_last_two (y::z) in x::l, res - | _ -> error "The term provided is not an applied relation." in - let others,(c1,c2) = split_last_two args in - let ty1, ty2 = - Typing.mtype_of env eqclause.evd c1, Typing.mtype_of env eqclause.evd c2 + let find_rel ty = + let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in + let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in + let rec split_last_two = function + | [c1;c2] -> [],(c1, c2) + | x::y::z -> + let l,res = split_last_two (y::z) in x::l, res + | _ -> error "The term provided is not an applied relation." in + let others,(c1,c2) = split_last_two args in + let ty1, ty2 = + Typing.mtype_of env eqclause.evd c1, Typing.mtype_of env eqclause.evd c2 + in + if not (evd_convertible env eqclause.evd ty1 ty2) then None + else + Some { cl=eqclause; prf=(Clenv.clenv_value eqclause); + car=ty1; rel=mkApp (equiv, Array.of_list others); + l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None } in - if not (evd_convertible env eqclause.evd ty1 ty2) then - error "The term does not end with an applied homogeneous relation." - else - { cl=eqclause; prf=(Clenv.clenv_value eqclause); - car=ty1; rel=mkApp (equiv, Array.of_list others); - l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None } - + match find_rel ctype with + | Some c -> c + | None -> + let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' ctx) with + | Some c -> c + | None -> error "The term does not end with an applied homogeneous relation." + let rewrite_unif_flags = { Unification.modulo_conv_on_closed_terms = None; Unification.use_metas_eagerly = true; @@ -798,32 +803,19 @@ let refresh_hypinfo env sigma hypinfo = match c with | Some c -> (* Refresh the clausenv to not get the same meta twice in the goal. *) - hypinfo := decompose_setoid_eqhyp cl.env (Evd.evars_of cl.evd) c l2r; + hypinfo := decompose_setoid_eqhyp env (Evd.evars_of cl.evd) c l2r; | _ -> () else () let unify_eqn env sigma hypinfo t = - try + if isEvar t then None + else try let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in let env', prf, c1, c2, car, rel = let left = if l2r then c1 else c2 in match abs with Some (absprf, absprfty) -> - (*if convertible env cl.evd left t then - cl, prf, c1, c2, car, rel - else raise Not_found*) let env' = clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl in - let env' = - let mvs = clenv_dependent false env' in - clenv_pose_metas_as_evars env' mvs - in - let c1 = Clenv.clenv_nf_meta env' c1 - and c2 = Clenv.clenv_nf_meta env' c2 - and car = Clenv.clenv_nf_meta env' car - and rel = Clenv.clenv_nf_meta env' rel in - hypinfo := { !hypinfo with - cl = env'; - abs = Some (Clenv.clenv_value env', Clenv.clenv_type env') }; env', prf, c1, c2, car, rel | None -> let env' = @@ -838,7 +830,7 @@ let unify_eqn env sigma hypinfo t = let mvs = clenv_dependent false env' in clenv_pose_metas_as_evars env' mvs in - let evd' = Typeclasses.resolve_typeclasses env'.env env'.evd in + let evd' = Typeclasses.resolve_typeclasses ~fail:false env'.env env'.evd in let env' = { env' with evd = evd' } in let nf c = Evarutil.nf_evar (Evd.evars_of evd') (Clenv.clenv_nf_meta env' c) in let c1 = nf c1 and c2 = nf c2 @@ -855,11 +847,11 @@ let unify_eqn env sigma hypinfo t = let res = if l2r then (prf, (car, rel, c1, c2)) else - try (mkApp (symmetric_proof env car rel, [| c1 ; c2 ; prf |]), (car, rel, c2, c1)) + try (mkApp (get_symmetric_proof env Evd.empty car rel, [| c1 ; c2 ; prf |]), (car, rel, c2, c1)) with Not_found -> (prf, (car, inverse car rel, c2, c1)) in Some (env', res) - with _ -> None + with e when catchable e -> None let unfold_impl t = match kind_of_term t with @@ -1041,16 +1033,18 @@ let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause g | None -> pf_concl gl, None in let cstr = - match is_hyp with - None -> (mkProp, inverse mkProp (Lazy.force impl)) - | Some _ -> (mkProp, Lazy.force impl) + let sort = mkProp in + let impl = Lazy.force impl in + match is_hyp with + | None -> (sort, inverse sort impl) + | Some _ -> (sort, impl) in - let evars = ref (Evd.create_evar_defs Evd.empty) in - let env = pf_env gl in let sigma = project gl in + let evars = ref (Evd.create_evar_defs sigma) in + let env = pf_env gl in let eq = build_new gl env sigma flags occs hypinfo concl (Some (Lazy.lazy_from_val cstr)) evars in - match eq with + match eq with | Some (p, (_, _, oldt, newt)) -> (try evars := Typeclasses.resolve_typeclasses env ~split:false ~fail:true !evars; @@ -1069,22 +1063,22 @@ let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause g mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) in cut_replacing id newt - (fun x -> Tactics.refine (mkApp (term, [| mkVar id |]))) + (fun x -> Tacmach.refine_no_check (mkApp (term, [| mkVar id |]))) | None -> (match abs with | None -> let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in tclTHENLAST (Tacmach.internal_cut_no_check false name newt) - (tclTHEN (Tactics.revert [name]) (Tactics.refine p)) + (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p)) | Some (t, ty) -> - Tactics.refine + Tacmach.refine_no_check (mkApp (mkLambda (Name (id_of_string "newt"), newt, mkLambda (Name (id_of_string "lemma"), ty, mkApp (p, [| mkRel 2 |]))), [| mkMeta goal_meta; t |]))) in - let evartac = + let evartac = let evd = Evd.evars_of undef in if not (evd = Evd.empty) then Refiner.tclEVARS (Evd.merge sigma evd) else tclIDTAC @@ -1104,8 +1098,7 @@ let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause g (* tclFAIL 1 (str"setoid rewrite failed") gl *) let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause gl = - try cl_rewrite_clause_aux ~flags hypinfo goal_meta occs clause gl - with DependentMorphism -> tclFAIL 0 (str " setoid rewrite failed: cannot handle dependent morphisms") gl + cl_rewrite_clause_aux ~flags hypinfo goal_meta occs clause gl let cl_rewrite_clause (evm,c) left2right occs clause gl = init_setoid (); @@ -1113,10 +1106,6 @@ let cl_rewrite_clause (evm,c) left2right occs clause gl = let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in let env = pf_env gl in let evars = Evd.merge (project gl) evm in -(* let c = *) -(* let j = Pretyping.Default.understand_judgment_tcc evars env c in *) -(* j.Environ.uj_val *) -(* in *) let hypinfo = ref (decompose_setoid_eqhyp env evars c left2right) in cl_rewrite_clause_aux hypinfo meta occs clause gl @@ -1248,9 +1237,7 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance binders instance fields = - new_instance binders instance fields - ~on_free_vars:Classes.fail_on_free_vars - None + new_instance binders instance (CRecord (dummy_loc,None,fields)) ~generalize:false None let require_library dirpath = let qualid = (dummy_loc, Libnames.qualid_of_dirpath (Libnames.dirpath_of_string dirpath)) in @@ -1259,17 +1246,17 @@ let require_library dirpath = let declare_instance_refl binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" in anew_instance binders instance - [((dummy_loc,id_of_string "reflexivity"),[],lemma)] + [((dummy_loc,id_of_string "reflexivity"),lemma)] let declare_instance_sym binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" in anew_instance binders instance - [((dummy_loc,id_of_string "symmetry"),[],lemma)] + [((dummy_loc,id_of_string "symmetry"),lemma)] let declare_instance_trans binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" in anew_instance binders instance - [((dummy_loc,id_of_string "transitivity"),[],lemma)] + [((dummy_loc,id_of_string "transitivity"),lemma)] let constr_tac = Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor (false,None))) @@ -1294,16 +1281,16 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( anew_instance binders instance - [((dummy_loc,id_of_string "PreOrder_Reflexive"), [], lemma1); - ((dummy_loc,id_of_string "PreOrder_Transitive"),[], lemma3)]) + [((dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1); + ((dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)]) | (None, Some lemma2, Some lemma3) -> let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in ignore( anew_instance binders instance - [((dummy_loc,id_of_string "PER_Symmetric"), [], lemma2); - ((dummy_loc,id_of_string "PER_Transitive"),[], lemma3)]) + [((dummy_loc,id_of_string "PER_Symmetric"), lemma2); + ((dummy_loc,id_of_string "PER_Transitive"),lemma3)]) | (Some lemma1, Some lemma2, Some lemma3) -> let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in @@ -1311,9 +1298,9 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance binders instance - [((dummy_loc,id_of_string "Equivalence_Reflexive"), [], lemma1); - ((dummy_loc,id_of_string "Equivalence_Symmetric"), [], lemma2); - ((dummy_loc,id_of_string "Equivalence_Transitive"),[], lemma3)]) + [((dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1); + ((dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2); + ((dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)]) type 'a binders_let_argtype = (local_binder list, 'a) Genarg.abstract_argument_type @@ -1456,8 +1443,10 @@ let build_morphism_signature m = let t', sig_, evars = build_signature isevars env t cstrs None snd in let _ = List.iter (fun (ty, rel) -> - let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in - ignore (Evarutil.e_new_evar isevars env default)) + Option.iter (fun rel -> + let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in + ignore (Evarutil.e_new_evar isevars env default)) + rel) evars in let morph = @@ -1473,8 +1462,7 @@ let default_morphism sign m = let isevars = ref (Evd.create_evar_defs Evd.empty) in let t = Typing.type_of env Evd.empty m in let _, sign, evars = - try build_signature isevars env t (fst sign) (snd sign) (fun (ty, rel) -> rel) - with DependentMorphism -> error "Cannot infer the signature of dependent morphisms" + build_signature isevars env t (fst sign) (snd sign) (fun (ty, rel) -> rel) in let morph = mkApp (Lazy.force morphism_type, [| t; sign; m |]) @@ -1490,16 +1478,14 @@ let add_setoid binders a aeq t n = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance binders instance - [((dummy_loc,id_of_string "Equivalence_Reflexive"), [], mkappc "Seq_refl" [a;aeq;t]); - ((dummy_loc,id_of_string "Equivalence_Symmetric"), [], mkappc "Seq_sym" [a;aeq;t]); - ((dummy_loc,id_of_string "Equivalence_Transitive"),[], mkappc "Seq_trans" [a;aeq;t])]) + [((dummy_loc,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + ((dummy_loc,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + ((dummy_loc,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) let add_morphism_infer m n = init_setoid (); let instance_id = add_suffix n "_Morphism" in - let instance = try build_morphism_signature m - with DependentMorphism -> error "Cannot infer the signature of dependent morphisms" - in + let instance = build_morphism_signature m in if Lib.is_modtype () then let cst = Declare.declare_internal_constant instance_id (Entries.ParameterEntry (instance,false), Decl_kinds.IsAssumption Decl_kinds.Logical) @@ -1513,7 +1499,8 @@ let add_morphism_infer m n = Command.start_proof instance_id kind instance (fun _ -> function Libnames.ConstRef cst -> - add_instance (Typeclasses.new_instance (Lazy.force morphism_class) None false cst); + add_instance (Typeclasses.new_instance + (Lazy.force morphism_class) None false cst); declare_projection n instance_id (ConstRef cst) | _ -> assert false); Pfedit.by (Tacinterp.interp <:tactic< Coq.Classes.SetoidTactics.add_morphism_tactic>>)) (); @@ -1529,10 +1516,8 @@ let add_morphism binders m s n = [cHole; s; m])) in let tac = Tacinterp.interp <:tactic> in - ignore(new_instance binders instance [] - ~on_free_vars:Classes.fail_on_free_vars - ~tac ~hook:(fun cst -> declare_projection n instance_id (ConstRef cst)) - None) + ignore(new_instance binders instance (CRecord (dummy_loc,None,[])) + ~generalize:false ~tac ~hook:(fun cst -> declare_projection n instance_id (ConstRef cst)) None) VERNAC COMMAND EXTEND AddSetoid1 [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> @@ -1573,62 +1558,59 @@ let check_evar_map_of_evars_defs evd = ) metas let unification_rewrite l2r c1 c2 cl car rel but gl = - let (env',c') = + let env = pf_env gl in + let (evd',c') = try (* ~flags:(false,true) to allow to mark occurrences that must not be rewritten simply by replacing them with let-defined definitions in the context *) - Unification.w_unify_to_subterm ~flags:rewrite_unif_flags (pf_env gl) ((if l2r then c1 else c2),but) cl.evd + Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env ((if l2r then c1 else c2),but) cl.evd with Pretype_errors.PretypeError _ -> (* ~flags:(true,true) to make Ring work (since it really exploits conversion) *) Unification.w_unify_to_subterm ~flags:rewrite2_unif_flags - (pf_env gl) ((if l2r then c1 else c2),but) cl.evd + env ((if l2r then c1 else c2),but) cl.evd + in + let evd' = Typeclasses.resolve_typeclasses ~fail:false env evd' in + let cl' = {cl with evd = evd'} in + let cl' = + let mvs = clenv_dependent false cl' in + clenv_pose_metas_as_evars cl' mvs in - let cl' = {cl with evd = env'} in - let c1 = Clenv.clenv_nf_meta cl' c1 - and c2 = Clenv.clenv_nf_meta cl' c2 in - check_evar_map_of_evars_defs env'; - let prf = Clenv.clenv_value cl' in - let prfty = Clenv.clenv_type cl' in + let nf c = Evarutil.nf_evar (Evd.evars_of cl'.evd) (Clenv.clenv_nf_meta cl' c) in + let c1 = nf c1 and c2 = nf c2 and car = nf car and rel = nf rel in + check_evar_map_of_evars_defs cl'.evd; + let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)} -let get_hyp gl c clause l2r = - let hi = decompose_setoid_eqhyp (pf_env gl) (project gl) c l2r in +let get_hyp gl (evm,c) clause l2r = + let evars = Evd.merge (project gl) evm in + let hi = decompose_setoid_eqhyp (pf_env gl) evars c l2r in let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl let general_rewrite_flags = { under_lambdas = false; on_morphisms = false } -let general_s_rewrite l2r occs c ~new_goals gl = +let general_s_rewrite cl l2r occs c ~new_goals gl = let meta = Evarutil.new_meta() in - let hypinfo = ref (get_hyp gl c None l2r) in - cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs None gl - -let general_s_rewrite_in id l2r occs c ~new_goals gl = - let meta = Evarutil.new_meta() in - let hypinfo = ref (get_hyp gl c (Some id) l2r) in - cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs (Some (([],id), [])) gl + let hypinfo = ref (get_hyp gl c cl l2r) in + let cl' = Option.map (fun id -> (([],id), [])) cl in + cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs cl' gl +(* if fst c = Evd.empty || fst c == project gl then tac gl *) +(* else *) +(* let evars = Evd.merge (fst c) (project gl) in *) +(* tclTHEN (Refiner.tclEVARS evars) tac gl *) let general_s_rewrite_clause x = init_setoid (); match x with - | None -> general_s_rewrite - | Some id -> general_s_rewrite_in id + | None -> general_s_rewrite None + | Some id -> general_s_rewrite (Some id) let _ = Equality.register_general_setoid_rewrite_clause general_s_rewrite_clause -(* [setoid_]{reflexivity,symmetry,transitivity} tactics *) - -let relation_of_constr c = - match kind_of_term c with - | App (f, args) when Array.length args >= 2 -> - let relargs, args = array_chop (Array.length args - 2) args in - mkApp (f, relargs), args - | _ -> error "Not an applied relation." - let is_loaded d = let d' = List.map id_of_string d in let dir = make_dirpath (List.rev d') in @@ -1637,36 +1619,175 @@ let is_loaded d = let try_loaded f gl = if is_loaded ["Coq";"Classes";"RelationClasses"] then f gl else tclFAIL 0 (str"You need to require Coq.Classes.RelationClasses first") gl - -let setoid_reflexivity gl = + +let try_classes t gls = + try t gls + with (Pretype_errors.PretypeError _) as e -> raise e + +TACTIC EXTEND try_classes + [ "try_classes" tactic(t) ] -> [ try_classes (snd t) ] +END + +open Rawterm +open Environ +open Refiner + +let typeclass_app evm gl ?(bindings=NoBindings) c ty = + let nprod = nb_prod (pf_concl gl) in + let n = nb_prod ty - nprod in + if n<0 then error "Apply_tc: theorem has not enough premisses."; + Refiner.tclTHEN (Refiner.tclEVARS evm) + (fun gl -> + let clause = make_clenv_binding_apply gl (Some n) (c,ty) bindings in + let cl' = evar_clenv_unique_resolver true ~flags:default_unify_flags clause gl in + let evd' = Typeclasses.resolve_typeclasses cl'.env ~fail:true cl'.evd in + tclTHEN (Clenvtac.clenv_refine true {cl' with evd = evd'}) + tclNORMEVAR gl) gl + +open Tacinterp +open Pretyping + +let my_ist = + { lfun = []; + avoid_ids = []; + debug = Tactic_debug.DebugOff; + trace = [] } + +let rawconstr_and_expr (evd, c) = c + +let rawconstr_and_expr_of_rawconstr_bindings = function + | NoBindings -> NoBindings + | ImplicitBindings l -> ImplicitBindings (List.map rawconstr_and_expr l) + | ExplicitBindings l -> ExplicitBindings (List.map (fun (l,b,c) -> (l,b,rawconstr_and_expr c)) l) + +let my_glob_sign sigma env = { + ltacvars = [], [] ; + ltacrecvars = []; + gsigma = sigma ; + genv = env } + +let typeclass_app_constrexpr t ?(bindings=NoBindings) gl = let env = pf_env gl in - let rel, args = relation_of_constr (pf_concl gl) in - try - apply (reflexive_proof env (pf_type_of gl args.(0)) rel) gl - with Not_found -> - tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared reflexive relation") - gl - -let setoid_symmetry gl = + let evars = ref (create_evar_defs (project gl)) in + let gs = my_glob_sign (project gl) env in + let t', bl = Tacinterp.intern_constr_with_bindings gs (t,bindings) in + let j = Pretyping.Default.understand_judgment_tcc evars env (fst t') in + let bindings = Tacinterp.interp_bindings my_ist gl bl in + typeclass_app (Evd.evars_of !evars) gl ~bindings:bindings j.uj_val j.uj_type + +let typeclass_app_raw t gl = let env = pf_env gl in - let rel, args = relation_of_constr (pf_concl gl) in - try - apply (symmetric_proof env (pf_type_of gl args.(0)) rel) gl - with Not_found -> - tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared symmetric relation") - gl + let evars = ref (create_evar_defs (project gl)) in + let j = Pretyping.Default.understand_judgment_tcc evars env t in + typeclass_app (Evd.evars_of !evars) gl j.uj_val j.uj_type + +let pr_gen prc _prlc _prtac c = prc c + +let pr_ceb _prc _prlc _prtac raw = mt () + +let interp_constr_expr_bindings _ _ t = t + +let intern_constr_expr_bindings ist t = t + +open Pcoq.Tactic + +type constr_expr_bindings = constr_expr with_bindings + +ARGUMENT EXTEND constr_expr_bindings + TYPED AS constr_expr_bindings + PRINTED BY pr_ceb + + INTERPRETED BY interp_constr_expr_bindings + GLOBALIZED BY intern_constr_expr_bindings + + + [ constr_with_bindings(c) ] -> [ c ] +END + +TACTIC EXTEND apply_typeclasses +[ "typeclass_app" constr_expr_bindings(t) ] -> [ typeclass_app_constrexpr (fst t) ~bindings:(snd t) ] +END +TACTIC EXTEND apply_typeclasses_abbrev +[ "tcapp" raw(t) ] -> [ typeclass_app_raw t ] +END + +(* [setoid_]{reflexivity,symmetry,transitivity} tactics *) + +let not_declared env ty rel = + tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++ + str ty ++ str" relation. Maybe you need to import the Setoid library") + +let relation_of_constr env c = + match kind_of_term c with + | App (f, args) when Array.length args >= 2 -> + let relargs, args = array_chop (Array.length args - 2) args in + mkApp (f, relargs), args + | _ -> errorlabstrm "relation_of_constr" + (str "The term " ++ Printer.pr_constr_env env c ++ str" is not an applied relation.") -let setoid_transitivity c gl = +let setoid_proof gl ty fn fallback = let env = pf_env gl in - let rel, args = relation_of_constr (pf_concl gl) in - try + try + let rel, args = relation_of_constr env (pf_concl gl) in + let evm, car = project gl, pf_type_of gl args.(0) in + fn env evm car rel gl + with e -> + match fallback gl with + | Some tac -> tac gl + | None -> + match e with + | Not_found -> + let rel, args = relation_of_constr env (pf_concl gl) in + not_declared env ty rel gl + | _ -> raise e + +let setoid_reflexivity gl = + setoid_proof gl "reflexive" + (fun env evm car rel -> apply (get_reflexive_proof env evm car rel)) + (reflexivity_red true) + +let setoid_symmetry gl = + setoid_proof gl "symmetric" + (fun env evm car rel -> apply (get_symmetric_proof env evm car rel)) + (symmetry_red true) + +let setoid_transitivity c gl = + setoid_proof gl "transitive" + (fun env evm car rel -> apply_with_bindings - ((transitive_proof env (pf_type_of gl args.(0)) rel), - Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ]) gl - with Not_found -> - tclFAIL 0 - (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared transitive relation") gl - + ((get_transitive_proof env evm car rel), + Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ])) + (transitivity_red true c) + +(* + let setoid_proof gl ty ?(bindings=NoBindings) meth fallback = + try + typeclass_app_constrexpr + (CRef (Qualid (dummy_loc, Nametab.shortest_qualid_of_global Idset.empty + (Lazy.force meth)))) ~bindings gl + with Not_found | Typeclasses_errors.TypeClassError (_, _) | + Stdpp.Exc_located (_, Typeclasses_errors.TypeClassError (_, _)) -> + match fallback gl with + | Some tac -> tac gl + | None -> + let env = pf_env gl in + let rel, args = relation_of_constr env (pf_concl gl) in + not_declared env ty rel gl + +let setoid_reflexivity gl = + setoid_proof gl "reflexive" reflexive_proof_global (reflexivity_red true) + +let setoid_symmetry gl = + setoid_proof gl "symmetric" symmetric_proof_global (symmetry_red true) + +let setoid_transitivity c gl = + let binding_name = + next_ident_away (id_of_string "y") (ids_of_named_context (named_context (pf_env gl))) + in + setoid_proof gl "transitive" + ~bindings:(Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp binding_name, constrIn c ]) + transitive_proof_global (transitivity_red true c) +*) let setoid_symmetry_in id gl = let ctype = pf_type_of gl (mkVar id) in let binders,concl = Sign.decompose_prod_assum ctype in @@ -1696,49 +1817,11 @@ TACTIC EXTEND setoid_symmetry END TACTIC EXTEND setoid_reflexivity - [ "setoid_reflexivity" ] -> [ setoid_reflexivity ] +[ "setoid_reflexivity" ] -> [ setoid_reflexivity ] END TACTIC EXTEND setoid_transitivity - [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ] -END - -let try_classes t gls = - try t gls - with (Pretype_errors.PretypeError _) as e -> raise e - -TACTIC EXTEND try_classes - [ "try_classes" tactic(t) ] -> [ try_classes (snd t) ] -END - -open Rawterm - -let constrexpr = Pcoq.Tactic.open_constr -type 'a constr_expr_argtype = (open_constr_expr, 'a) Genarg.abstract_argument_type - -let (wit_constrexpr : Genarg.tlevel constr_expr_argtype), - (globwit_constrexpr : Genarg.glevel constr_expr_argtype), - (rawwit_const_expr : Genarg.rlevel constr_expr_argtype) = - Genarg.create_arg "constrexpr" - -open Environ -open Refiner - -TACTIC EXTEND apply_typeclasses - [ "typeclass_app" raw(t) ] -> [ fun gl -> - let nprod = nb_prod (pf_concl gl) in - let env = pf_env gl in - let evars = ref (create_evar_defs (project gl)) in - let j = Pretyping.Default.understand_judgment_tcc evars env t in - let n = nb_prod j.uj_type - nprod in - if n<0 then error "Apply_tc: theorem has not enough premisses."; - Refiner.tclTHEN (Refiner.tclEVARS (Evd.evars_of !evars)) - (fun gl -> - let clause = make_clenv_binding_apply gl (Some n) (j.uj_val,j.uj_type) NoBindings in - let cl' = evar_clenv_unique_resolver true ~flags:default_unify_flags clause gl in - let evd' = Typeclasses.resolve_typeclasses cl'.env ~fail:true cl'.evd in - Clenvtac.clenv_refine true {cl' with evd = evd'} gl) gl - ] +[ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ] END let rec head_of_constr t = @@ -1752,6 +1835,105 @@ let rec head_of_constr t = TACTIC EXTEND head_of_constr [ "head_of_constr" ident(h) constr(c) ] -> [ let c = head_of_constr c in - letin_tac None (Name h) c allHyps + letin_tac None (Name h) c None allHyps + ] +END + + +let coq_List_nth = lazy (gen_constant ["Lists"; "List"] "nth") +let coq_List_cons = lazy (gen_constant ["Lists"; "List"] "cons") +let coq_List_nil = lazy (gen_constant ["Lists"; "List"] "nil") + +let freevars c = + let rec frec acc c = match kind_of_term c with + | Var id -> Idset.add id acc + | _ -> fold_constr frec acc c + in + frec Idset.empty c + +let coq_zero = lazy (gen_constant ["Init"; "Datatypes"] "O") +let coq_succ = lazy (gen_constant ["Init"; "Datatypes"] "S") +let coq_nat = lazy (gen_constant ["Init"; "Datatypes"] "nat") + +let rec coq_nat_of_int = function + | 0 -> Lazy.force coq_zero + | n -> mkApp (Lazy.force coq_succ, [| coq_nat_of_int (pred n) |]) + +let varify_constr_list ty def varh c = + let vars = Idset.elements (freevars c) in + let mkaccess i = + mkApp (Lazy.force coq_List_nth, + [| ty; coq_nat_of_int i; varh; def |]) + in + let l = List.fold_right (fun id acc -> + mkApp (Lazy.force coq_List_cons, [| ty ; mkVar id; acc |])) + vars (mkApp (Lazy.force coq_List_nil, [| ty |])) + in + let subst = + list_map_i (fun i id -> (id, mkaccess i)) 0 vars + in + l, replace_vars subst c + +let coq_varmap_empty = lazy (gen_constant ["ring"; "Quote"] "Empty_vm") +let coq_varmap_node = lazy (gen_constant ["ring"; "Quote"] "Node_vm") +(* | Node_vm : A -> varmap -> varmap -> varmap. *) + +let coq_varmap_lookup = lazy (gen_constant ["ring"; "Quote"] "varmap_find") + +let coq_index_left = lazy (gen_constant ["ring"; "Quote"] "Left_idx") +let coq_index_right = lazy (gen_constant ["ring"; "Quote"] "Right_idx") +let coq_index_end = lazy (gen_constant ["ring"; "Quote"] "End_idx") + +let rec split_interleaved l r = function + | hd :: hd' :: tl' -> + split_interleaved (hd :: l) (hd' :: r) tl' + | hd :: [] -> (List.rev (hd :: l), List.rev r) + | [] -> (List.rev l, List.rev r) + +(* let rec mkidx i acc = *) +(* if i mod 2 = 0 then *) +(* let acc' = mkApp (Lazy.force coq_index_left, [|acc|]) in *) +(* if i = 0 then acc' *) +(* else mkidx (i / 2) acc' *) +(* else *) +(* let acc' = mkApp (Lazy.force coq_index_right, [|acc|]) in *) +(* if i = 1 then acc' *) +(* else mkidx (i / 2) acc' *) + +let rec mkidx i p = + if i mod 2 = 0 then + if i = 0 then mkApp (Lazy.force coq_index_left, [|Lazy.force coq_index_end|]) + else mkApp (Lazy.force coq_index_left, [|mkidx (i - p) (2 * p)|]) + else if i = 1 then mkApp (Lazy.force coq_index_right, [|Lazy.force coq_index_end|]) + else mkApp (Lazy.force coq_index_right, [|mkidx (i - p) (2 * p)|]) + +let varify_constr_varmap ty def varh c = + let vars = Idset.elements (freevars c) in + let mkaccess i = + mkApp (Lazy.force coq_varmap_lookup, + [| ty; def; i; varh |]) + in + let rec vmap_aux l cont = + match l with + | [] -> [], mkApp (Lazy.force coq_varmap_empty, [| ty |]) + | hd :: tl -> + let left, right = split_interleaved [] [] tl in + let leftvars, leftmap = vmap_aux left (fun x -> cont (mkApp (Lazy.force coq_index_left, [| x |]))) in + let rightvars, rightmap = vmap_aux right (fun x -> cont (mkApp (Lazy.force coq_index_right, [| x |]))) in + (hd, cont (Lazy.force coq_index_end)) :: leftvars @ rightvars, + mkApp (Lazy.force coq_varmap_node, [| ty; hd; leftmap ; rightmap |]) + in + let subst, vmap = vmap_aux (def :: List.map (fun x -> mkVar x) vars) (fun x -> x) in + let subst = List.map (fun (id, x) -> (destVar id, mkaccess x)) (List.tl subst) in + vmap, replace_vars subst c + + +TACTIC EXTEND varify + [ "varify" ident(varh) ident(h') constr(ty) constr(def) constr(c) ] -> [ + let vars, c' = varify_constr_varmap ty def (mkVar varh) c in + tclTHEN (letin_tac None (Name varh) vars None allHyps) + (letin_tac None (Name h') c' None allHyps) ] END + + diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml index 97225617..c99884c0 100644 --- a/tactics/decl_interp.ml +++ b/tactics/decl_interp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: decl_interp.ml 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: decl_interp.ml 11576 2008-11-10 19:13:15Z msozeau $ i*) open Util open Names @@ -94,8 +94,10 @@ let rec add_vars_of_simple_pattern globs = function (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) | CPatDelimiters (_,_,p) -> add_vars_of_simple_pattern globs p - | CPatCstr (_,_,pl) | CPatNotation(_,_,pl) -> + | CPatCstr (_,_,pl) -> List.fold_left add_vars_of_simple_pattern globs pl + | CPatNotation(_,_,(pl,pll)) -> + List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll)) | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs | _ -> globs @@ -342,7 +344,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = (fun (loc,(id,_)) -> RVar (loc,id)) params in let dum_args= - list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark false)) + list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark (Evd.Define false))) oib.Declarations.mind_nrealargs in raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in let pat_vars,aliases,patt = interp_pattern env pat in diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml index 5356868a..839a494a 100644 --- a/tactics/decl_proof_instr.ml +++ b/tactics/decl_proof_instr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: decl_proof_instr.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: decl_proof_instr.ml 11671 2008-12-12 12:43:03Z herbelin $ *) open Util open Pp @@ -107,7 +107,7 @@ let clean_tmp gls = clean_all (tmp_ids gls) gls let assert_postpone id t = - assert_as true (dummy_loc, Genarg.IntroIdentifier id) t + assert_tac (Name id) t (* start a proof *) @@ -264,7 +264,7 @@ let add_justification_hyps keep items gls = | _ -> let id=pf_get_new_id local_hyp_prefix gls in keep:=Idset.add id !keep; - tclTHEN (letin_tac None (Names.Name id) c Tacexpr.nowhere) + tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere) (thin_body [id]) gls in tclMAP add_aux items gls @@ -780,7 +780,7 @@ let consider_tac c hyps gls = | _ -> let id = pf_get_new_id (id_of_string "_tmp") gls in tclTHEN - (forward None (dummy_loc, Genarg.IntroIdentifier id) c) + (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c) (consider_match false [] [id] hyps) gls @@ -811,7 +811,7 @@ let rec build_function args body = let define_tac id args body gls = let t = build_function args body in - letin_tac None (Name id) t Tacexpr.nowhere gls + letin_tac None (Name id) t None Tacexpr.nowhere gls (* tactics for reconsider *) diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli index 2e235a01..877c8047 100644 --- a/tactics/decl_proof_instr.mli +++ b/tactics/decl_proof_instr.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: decl_proof_instr.mli 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: decl_proof_instr.mli 11481 2008-10-20 19:23:51Z herbelin $ *) open Refiner open Names diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index 14731b26..f3e1559f 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: dhyp.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: dhyp.ml 11739 2009-01-02 19:33:19Z herbelin $ *) (* Chet's comments about this tactic : @@ -131,6 +131,7 @@ 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 *) @@ -248,7 +249,7 @@ let add_destructor_hint local na loc pat pri code = errorlabstrm "add_destructor_hint" (str "The tactic should be a function of the hypothesis name.") end in - let (_,pat) = Constrintern.interp_constrpattern Evd.empty (Global.env()) pat + let (_,pat) = Constrintern.intern_constr_pattern Evd.empty (Global.env()) pat in let pat = match loc with | HypLocation b -> diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 1503ca9a..67bdeb46 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: eauto.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: eauto.ml4 11735 2009-01-02 17:22:31Z herbelin $ *) open Pp open Util @@ -31,9 +31,9 @@ open Auto open Rawterm open Hiddentac -let e_give_exact c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in +let e_give_exact ?(flags=Unification.default_unify_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in if occur_existential t1 or occur_existential t2 then - tclTHEN (Clenvtac.unify t1) (exact_check c) gl + tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl else exact_check c gl let assumption id = e_give_exact (mkVar id) @@ -91,6 +91,8 @@ open Unification (* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) (***************************************************************************) +let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) + (* no delta yet *) let unify_e_resolve flags (c,clenv) gls = @@ -140,12 +142,11 @@ and e_my_find_search_nodelta db_list local_db hdc concl = tclTHEN (unify_e_resolve_nodelta (term,cl)) (e_trivial_fail_db false db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> conclPattern concl - (Option.get p) tacast + | Extern tacast -> conclPattern concl p tacast in - (tac,fmt_autotactic t)) + (tac,pr_autotactic t)) (*i - fun gls -> pPNL (fmt_autotactic t); Format.print_flush (); + fun gls -> pPNL (pr_autotactic t); Format.print_flush (); try tac gls with e when Logic.catchable_exception(e) -> (Format.print_string "Fail\n"; @@ -174,17 +175,16 @@ and e_my_find_search_delta db_list local_db hdc concl = match t with | Res_pf (term,cl) -> unify_resolve st (term,cl) | ERes_pf (term,cl) -> unify_e_resolve st (term,cl) - | Give_exact (c) -> e_give_exact_constr c + | Give_exact (c) -> e_give_exact ~flags:st c | Res_pf_THEN_trivial_fail (term,cl) -> tclTHEN (unify_e_resolve st (term,cl)) (e_trivial_fail_db true db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> conclPattern concl - (Option.get p) tacast + | Extern tacast -> conclPattern concl p tacast in - (tac,fmt_autotactic t)) + (tac,pr_autotactic t)) (*i - fun gls -> pPNL (fmt_autotactic t); Format.print_flush (); + fun gls -> pPNL (pr_autotactic t); Format.print_flush (); try tac gls with e when Logic.catchable_exception(e) -> (Format.print_string "Fail\n"; @@ -196,15 +196,15 @@ and e_my_find_search_delta db_list local_db hdc concl = and e_trivial_resolve mod_delta db_list local_db gl = try - Auto.priority + priority (e_my_find_search mod_delta db_list local_db - (List.hd (head_constr_bound gl [])) gl) + (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let e_possible_resolve mod_delta db_list local_db gl = try List.map snd (e_my_find_search mod_delta db_list local_db - (List.hd (head_constr_bound gl [])) gl) + (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id)) @@ -460,3 +460,9 @@ TACTIC EXTEND autosimpl | [ "autosimpl" hintbases(db) ] -> [ autosimpl (match db with None -> ["core"] | Some x -> "core"::x) None ] END + +TACTIC EXTEND unify +| ["unify" constr(x) constr(y) ] -> [ unify x y ] +| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ + unify ~state:(Hint_db.transparent_state (searchtable_map base)) x y ] +END diff --git a/tactics/elim.ml b/tactics/elim.ml index 55df0f0a..fa4a7caa 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: elim.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: elim.ml 11739 2009-01-02 19:33:19Z herbelin $ *) open Pp open Util @@ -128,7 +128,7 @@ let decompose_nonrec c gls = let decompose_and c gls = general_decompose - (fun (_,t) -> is_conjunction t) + (fun (_,t) -> is_record t) c gls let decompose_or c gls = diff --git a/tactics/equality.ml b/tactics/equality.ml index 7fb19423..ba18430a 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: equality.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: equality.ml 11800 2009-01-18 18:34:15Z msozeau $ *) open Pp open Util @@ -37,12 +37,12 @@ open Tacred open Rawterm open Coqlib open Vernacexpr -open Setoid_replace open Declarations open Indrec open Printer open Clenv open Clenvtac +open Evd (* Rewriting tactics *) @@ -55,25 +55,22 @@ open Clenvtac *) (* Ad hoc asymmetric general_elim_clause *) -let general_elim_clause with_evars cls c elim = +let general_elim_clause with_evars cls sigma c l elim = try (match cls with | None -> (* was tclWEAK_PROGRESS which only fails for tactics generating one subgoal and did not fail for useless conditional rewritings generating an extra condition *) - tclNOTSAMEGOAL (general_elim with_evars c elim ~allow_K:false) + tclNOTSAMEGOAL (tclTHEN (Refiner.tclEVARS sigma) + (general_elim with_evars (c,l) elim ~allow_K:false)) | Some id -> - general_elim_in with_evars id c elim) + tclTHEN (Refiner.tclEVARS sigma) (general_elim_in with_evars id (c,l) elim)) with Pretype_errors.PretypeError (env, (Pretype_errors.NoOccurrenceFound (c', _))) -> raise (Pretype_errors.PretypeError (env, (Pretype_errors.NoOccurrenceFound (c', cls)))) -let elimination_sort_of_clause = function - | None -> elimination_sort_of_goal - | Some id -> elimination_sort_of_hyp id - (* The next function decides in particular whether to try a regular rewrite or a setoid rewrite. Approach is to break everything, if [eq] appears in head position @@ -81,11 +78,7 @@ let elimination_sort_of_clause = function If occurrences are set, use setoid_rewrite. *) -let general_s_rewrite_clause = function - | None -> general_s_rewrite - | Some id -> general_s_rewrite_in id - -let general_setoid_rewrite_clause = ref general_s_rewrite_clause +let general_setoid_rewrite_clause = ref (fun _ -> assert false) let register_general_setoid_rewrite_clause = (:=) general_setoid_rewrite_clause let is_applied_setoid_relation = ref (fun _ -> false) @@ -96,39 +89,52 @@ let is_applied_relation t = | App (c, args) when Array.length args >= 2 -> true | _ -> false -let leibniz_rewrite_ebindings_clause cls lft2rgt (c,l) with_evars gl hdcncl = - let hdcncls = string_of_inductive hdcncl in - let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in - let dir = if cls=None then lft2rgt else not lft2rgt in - let rwr_thm = if dir then hdcncls^suffix^"_r" else hdcncls^suffix in - let elim = - try pf_global gl (id_of_string rwr_thm) - with Not_found -> - error ("Cannot find rewrite principle "^rwr_thm^".") - in general_elim_clause with_evars cls (c,l) (elim,NoBindings) gl +(* find_elim determines which elimination principle is necessary to + eliminate lbeq on sort_of_gl. *) -let leibniz_eq = Lazy.lazy_from_fun build_coq_eq +let find_elim hdcncl lft2rgt cls gl = + let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in + let hdcncls = string_of_inductive hdcncl ^ suffix in + let rwr_thm = if lft2rgt = (cls = None) then hdcncls^"_r" else hdcncls in + try pf_global gl (id_of_string rwr_thm) + with Not_found -> error ("Cannot find rewrite principle "^rwr_thm^".") + +let leibniz_rewrite_ebindings_clause cls lft2rgt sigma c l with_evars gl hdcncl = + let elim = find_elim hdcncl lft2rgt cls gl in + general_elim_clause with_evars cls sigma c l (elim,NoBindings) gl + +let adjust_rewriting_direction args lft2rgt = + if List.length args = 1 then + (* equality to a constant, like in eq_true *) + (* more natural to see -> as the rewriting to the constant *) + not lft2rgt + else + (* other equality *) + lft2rgt -let general_rewrite_ebindings_clause cls lft2rgt occs (c,l) with_evars gl = +let general_rewrite_ebindings_clause cls lft2rgt occs ((c,l) : open_constr with_bindings) with_evars gl = if occs <> all_occurrences then ( !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl) else - let ctype = pf_apply get_type_of gl c in let env = pf_env gl in - let sigma = project gl in + let sigma, c' = c in + let sigma = Evd.merge sigma (project gl) in + let ctype = get_type_of env sigma c' in let rels, t = decompose_prod (whd_betaiotazeta ctype) in - match match_with_equation t with - | Some (hdcncl,_) -> (* Fast path: direct leibniz rewrite *) - leibniz_rewrite_ebindings_clause cls lft2rgt (c,l) with_evars gl hdcncl + match match_with_equality_type t with + | Some (hdcncl,args) -> (* Fast path: direct leibniz rewrite *) + let lft2rgt = adjust_rewriting_direction args lft2rgt in + leibniz_rewrite_ebindings_clause cls lft2rgt sigma c' l with_evars gl hdcncl | None -> let env' = List.fold_left (fun env (n,t) -> push_rel (n, None, t) env) env rels in let _,t' = splay_prod env' sigma t in (* Search for underlying eq *) - match match_with_equation t' with - | Some (hdcncl,_) -> (* Maybe a setoid relation with eq inside *) + match match_with_equality_type t' with + | Some (hdcncl,args) -> (* Maybe a setoid relation with eq inside *) + let lft2rgt = adjust_rewriting_direction args lft2rgt in if l = NoBindings && !is_applied_setoid_relation t then !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl else - (try leibniz_rewrite_ebindings_clause cls lft2rgt (c,l) with_evars gl hdcncl + (try leibniz_rewrite_ebindings_clause cls lft2rgt sigma c' l with_evars gl hdcncl with e -> try !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl with _ -> raise e) @@ -140,7 +146,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs (c,l) with_evars gl = let general_rewrite_ebindings = general_rewrite_ebindings_clause None let general_rewrite_bindings l2r occs (c,bl) = - general_rewrite_ebindings_clause None l2r occs (c,inj_ebindings bl) + general_rewrite_ebindings_clause None l2r occs (inj_open c,inj_ebindings bl) let general_rewrite l2r occs c = general_rewrite_bindings l2r occs (c,NoBindings) false @@ -148,9 +154,9 @@ let general_rewrite l2r occs c = let general_rewrite_ebindings_in l2r occs id = general_rewrite_ebindings_clause (Some id) l2r occs let general_rewrite_bindings_in l2r occs id (c,bl) = - general_rewrite_ebindings_clause (Some id) l2r occs (c,inj_ebindings bl) + general_rewrite_ebindings_clause (Some id) l2r occs (inj_open c,inj_ebindings bl) let general_rewrite_in l2r occs id c = - general_rewrite_ebindings_clause (Some id) l2r occs (c,NoBindings) + general_rewrite_ebindings_clause (Some id) l2r occs (inj_open c,NoBindings) let general_multi_rewrite l2r with_evars c cl = let occs_of = on_snd (List.fold_left @@ -186,7 +192,7 @@ let general_multi_rewrite l2r with_evars c cl = let do_hyps gl = (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) let ids = - let ids_in_c = Environ.global_vars_set (Global.env()) (fst c) in + let ids_in_c = Environ.global_vars_set (Global.env()) (snd (fst c)) in Idset.fold (fun id l -> list_remove id l) ids_in_c (pf_ids_of_hyps gl) in do_hyps_atleastonce ids gl in @@ -262,10 +268,10 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = let e = build_coq_eq () in let sym = build_coq_sym_eq () in let eq = applist (e, [t1;c1;c2]) in - tclTHENS (assert_tac false Anonymous eq) + tclTHENS (assert_as false None eq) [onLastHyp (fun id -> tclTHEN - (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause)) + (tclTRY (general_multi_rewrite false false (inj_open (mkVar id),NoBindings) clause)) (clear [id])); tclFIRST [assumption; @@ -450,7 +456,8 @@ let injectable env sigma t1 t2 = let descend_then sigma env head dirn = let IndType (indf,_) = try find_rectype env sigma (get_type_of env sigma head) - with Not_found -> assert false in + with Not_found -> + error "Cannot project on an inductive type derived from a dependency." in let ind,_ = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in @@ -470,7 +477,7 @@ let descend_then sigma env head dirn = (interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in mkCase (ci, p, head, Array.of_list brl))) - + (* Now we need to construct the discriminator, given a discriminable position. This boils down to: @@ -819,11 +826,14 @@ let make_iterated_tuple env sigma dflt (z,zty) = let rec build_injrec sigma env dflt c = function | [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c) | ((sp,cnum),argnum)::l -> + try let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in let newc = mkRel(cnum_nlams-argnum) in let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in (kont subval (dfltval,tuplety), - tuplety,dfltval) + tuplety,dfltval) + with + UserError _ -> failwith "caught" let build_injector sigma env dflt c cpath = let (injcode,resty,_) = build_injrec sigma env dflt c cpath in @@ -978,26 +988,11 @@ let swapEquandsInHyp id gls = cut_replacing id (swap_equands gls (pf_get_hyp_typ gls id)) (tclTHEN swapEquandsInConcl) gls -(* find_elim determines which elimination principle is necessary to - eliminate lbeq on sort_of_gl. - This is somehow an artificial choice as we could take eq_rect in - all cases (eq_ind - and eq_rec - are instances of eq_rect) [HH 2/4/06]. -*) - -let find_elim sort_of_gl lbeq = - match kind_of_term sort_of_gl with - | Sort(Prop Null) (* Prop *) -> lbeq.ind - | _ (* Set/Type *) -> - (match lbeq.rect with - | Some eq_rect -> eq_rect - | None -> errorlabstrm "find_elim" - (str "This type of substitution is not allowed.")) - (* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *) let bareRevSubstInConcl lbeq body (t,e1,e2) gls = (* find substitution scheme *) - let eq_elim = find_elim (pf_apply get_type_of gls (pf_concl gls)) lbeq in + let eq_elim = find_elim lbeq.eq false None gls in (* build substitution predicate *) let p = lambda_create (pf_env gls) (t,body) in (* apply substitution scheme *) @@ -1050,14 +1045,16 @@ let subst_tuple_term env sigma dep_pair b = let abst_B = List.fold_right (fun (e,t) body -> lambda_create env (t,subst_term e body)) e_list b in - applist(abst_B,proj_list) - + beta_applist(abst_B,proj_list) + (* Comme "replace" mais decompose les egalites dependantes *) +exception NothingToRewrite + let cutSubstInConcl_RL eqn gls = let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose eqn in let body = pf_apply subst_tuple_term gls e2 (pf_concl gls) in - assert (dependent (mkRel 1) body); + if not (dependent (mkRel 1) body) then raise NothingToRewrite; bareRevSubstInConcl lbeq body eq gls (* |- (P e1) @@ -1075,7 +1072,7 @@ let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL let cutSubstInHyp_LR eqn id gls = let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose eqn in let body = pf_apply subst_tuple_term gls e1 (pf_get_hyp_typ gls id) in - assert (dependent (mkRel 1) body); + if not (dependent (mkRel 1) body) then raise NothingToRewrite; cut_replacing id (subst1 e2 body) (tclTHENFIRST (bareRevSubstInConcl lbeq body eq)) gls @@ -1095,6 +1092,9 @@ let try_rewrite tac gls = | e when catchable_exception e -> errorlabstrm "try_rewrite" (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") + | NothingToRewrite -> + errorlabstrm "try_rewrite" + (strbrk "Nothing to rewrite.") let cutSubstClause l2r eqn cls gls = match cls with @@ -1113,33 +1113,22 @@ let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls) let rewriteInHyp l2r c id = rewriteClause l2r c (Some id) let rewriteInConcl l2r c = rewriteClause l2r c None -(* Renaming scheme correspondence new name (old name) +(* Naming scheme for rewrite and cutrewrite tactics - give equality give proof of equality + give equality give proof of equality - / cutSubstClause (subst) substClause (HypSubst on hyp) -raw | cutSubstInHyp (substInHyp) substInHyp (none) - \ cutSubstInConcl (substInConcl) substInConcl (none) + / cutSubstClause substClause +raw | cutSubstInHyp substInHyp + \ cutSubstInConcl substInConcl - / cutRewriteClause (none) rewriteClause (none) -user| cutRewriteInHyp (substHyp) rewriteInHyp (none) - \ cutRewriteInConcl (substConcl) rewriteInConcl (substHypInConcl on hyp) + / cutRewriteClause rewriteClause +user| cutRewriteInHyp rewriteInHyp + \ cutRewriteInConcl rewriteInConcl raw = raise typing error or PatternMatchingFailure user = raise user error specific to rewrite *) -(* Summary of obsolete forms -let substInConcl = cutSubstInConcl -let substInHyp = cutSubstInHyp -let hypSubst l2r id = substClause l2r (mkVar id) -let hypSubst_LR = hypSubst true -let hypSubst_RL = hypSubst false -let substHypInConcl l2r id = rewriteInConcl l2r (mkVar id) -let substConcl = cutRewriteInConcl -let substHyp = cutRewriteInHyp -*) - (**********************************************************************) (* Substitutions tactics (JCF) *) @@ -1211,8 +1200,8 @@ let subst_one x gl = (id,None,_) -> intro_using id | (id,Some hval,htyp) -> letin_tac None (Name id) - (mkCast(replace_term varx rhs hval,DEFAULTcast, - replace_term varx rhs htyp)) nowhere + (replace_term varx rhs hval) + (Some (replace_term varx rhs htyp)) nowhere in let need_rewrite = dephyps <> [] || depconcl in tclTHENLIST @@ -1273,7 +1262,7 @@ let rewrite_multi_assumption_cond cond_eq_term cl gl = begin try let dir = cond_eq_term t gl in - general_multi_rewrite dir false (mkVar id,NoBindings) cl gl + general_multi_rewrite dir false (inj_open (mkVar id),NoBindings) cl gl with | Failure _ | UserError _ -> arec rest end in @@ -1333,14 +1322,4 @@ let replace_term_in_right t hyp = replace_multi_term (Some false) t (Tacticals.o let replace_term_in t hyp = replace_multi_term None t (Tacticals.onHyp hyp) - - - - - - - - -let _ = Setoid_replace.register_replace (fun tac_opt c2 c1 gl -> replace_in_clause_maybe_by c2 c1 onConcl tac_opt gl) -let _ = Setoid_replace.register_general_rewrite general_rewrite let _ = Tactics.register_general_multi_rewrite general_multi_rewrite diff --git a/tactics/equality.mli b/tactics/equality.mli index f05ebc6c..86ad3293 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: equality.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: equality.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Util @@ -45,7 +45,7 @@ val rewriteRL : constr -> tactic val register_general_setoid_rewrite_clause : (identifier option -> bool -> - occurrences -> constr -> new_goals:constr list -> tactic) -> unit + occurrences -> open_constr -> new_goals:constr list -> tactic) -> unit val register_is_applied_setoid_relation : (constr -> bool) -> unit val general_rewrite_bindings_in : @@ -54,14 +54,14 @@ val general_rewrite_in : bool -> occurrences -> identifier -> constr -> evars_flag -> tactic val general_multi_rewrite : - bool -> evars_flag -> constr with_ebindings -> clause -> tactic + bool -> evars_flag -> open_constr with_bindings -> clause -> tactic val general_multi_multi_rewrite : - evars_flag -> (bool * multi * constr with_ebindings) list -> clause -> + evars_flag -> (bool * multi * open_constr with_bindings) list -> clause -> tactic option -> tactic -val conditional_rewrite : bool -> tactic -> constr with_ebindings -> tactic +val conditional_rewrite : bool -> tactic -> open_constr with_bindings -> tactic val conditional_rewrite_in : - bool -> identifier -> tactic -> constr with_ebindings -> tactic + bool -> identifier -> tactic -> open_constr with_bindings -> tactic val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic val replace : constr -> constr -> tactic diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 3c266c51..43c18a8b 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: evar_tactics.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: evar_tactics.ml 11576 2008-11-10 19:13:15Z msozeau $ *) open Term open Util @@ -75,5 +75,5 @@ let let_evar name typ gls = let evd = Evd.create_goal_evar_defs gls.sigma in let evd',evar = Evarutil.new_evar evd (pf_env gls) typ in Refiner.tclTHEN (Refiner.tclEVARS (evars_of evd')) - (Tactics.letin_tac None name evar nowhere) gls + (Tactics.letin_tac None name evar None nowhere) gls diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli index dbf7db31..cc06d2c6 100644 --- a/tactics/evar_tactics.mli +++ b/tactics/evar_tactics.mli @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: evar_tactics.mli 6621 2005-01-21 17:24:37Z herbelin $ i*) +(*i $Id: evar_tactics.mli 11512 2008-10-27 12:28:36Z herbelin $ i*) open Tacmach open Names open Tacexpr +open Termops val instantiate : int -> Rawterm.rawconstr -> (identifier * hyp_location_flag, unit) location -> tactic diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index a0230b28..694c3495 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: extraargs.ml4 11094 2008-06-10 19:35:23Z herbelin $ *) +(* $Id: extraargs.ml4 11800 2009-01-18 18:34:15Z msozeau $ *) open Pp open Pcoq @@ -16,6 +16,7 @@ open Genarg open Names open Tacexpr open Tacinterp +open Termops (* Rewriting orientation *) @@ -97,22 +98,6 @@ ARGUMENT EXTEND occurrences | [ var(id) ] -> [ ArgVar id ] END -(* For Setoid rewrite *) -let pr_morphism_signature _ _ _ s = - spc () ++ Setoid_replace.pr_morphism_signature s - -ARGUMENT EXTEND morphism_signature - TYPED AS morphism_signature - PRINTED BY pr_morphism_signature - | [ constr(out) ] -> [ [],out ] - | [ constr(c) "++>" morphism_signature(s) ] -> - [ let l,out = s in (Some true,c)::l,out ] - | [ constr(c) "-->" morphism_signature(s) ] -> - [ let l,out = s in (Some false,c)::l,out ] - | [ constr(c) "==>" morphism_signature(s) ] -> - [ let l,out = s in (None,c)::l,out ] -END - let pr_gen prc _prlc _prtac c = prc c let pr_rawc _prc _prlc _prtac raw = Printer.pr_rawconstr raw @@ -288,7 +273,7 @@ let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = Option.map (fun l -> List.map - (fun id -> ( (all_occurrences_expr,trad_id id) ,Tacexpr.InHyp)) + (fun id -> ( (all_occurrences_expr,trad_id id),InHyp)) l ) hyps; diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index 74296ab0..bccb150f 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -6,13 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraargs.mli 10820 2008-04-20 18:18:49Z msozeau $ i*) +(*i $Id: extraargs.mli 11800 2009-01-18 18:34:15Z msozeau $ i*) open Tacexpr open Term open Names open Proof_type open Topconstr +open Termops open Rawterm val rawwit_orient : bool raw_abstract_argument_type @@ -23,13 +24,6 @@ val occurrences : (int list or_var) Pcoq.Gram.Entry.e val rawwit_occurrences : (int list or_var) raw_abstract_argument_type val wit_occurrences : (int list) typed_abstract_argument_type -val rawwit_morphism_signature : - Setoid_replace.morphism_signature raw_abstract_argument_type -val wit_morphism_signature : - Setoid_replace.morphism_signature typed_abstract_argument_type -val morphism_signature : - Setoid_replace.morphism_signature Pcoq.Gram.Entry.e - val rawwit_raw : constr_expr raw_abstract_argument_type val wit_raw : rawconstr typed_abstract_argument_type val raw : constr_expr Pcoq.Gram.Entry.e diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 66716acd..ee01f839 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: extratactics.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: extratactics.ml4 11800 2009-01-18 18:34:15Z msozeau $ *) open Pp open Pcoq @@ -18,6 +18,7 @@ open Mod_subst open Names open Tacexpr open Rawterm +open Tactics (* Equality *) open Equality @@ -133,10 +134,10 @@ let h_injHyp id = h_injection_main (Term.mkVar id,NoBindings) TACTIC EXTEND conditional_rewrite | [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) ] - -> [ conditional_rewrite b (snd tac) c ] + -> [ conditional_rewrite b (snd tac) (inj_open (fst c), snd c) ] | [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) "in" hyp(h) ] - -> [ conditional_rewrite_in b h (snd tac) c ] + -> [ conditional_rewrite_in b h (snd tac) (inj_open (fst c), snd c) ] END TACTIC EXTEND dependent_rewrite @@ -216,87 +217,6 @@ END let refine_tac = h_refine -(* Setoid_replace *) - -open Setoid_replace - -(* TACTIC EXTEND setoid_replace *) -(* [ "setoid_replace" constr(c1) "with" constr(c2) by_arg_tac(tac)] -> *) -(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:[] ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) by_arg_tac(tac)] -> *) -(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:[] ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] -> *) -(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:l ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] -> *) -(* [ setoid_replace (Option.map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:l ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) by_arg_tac(tac) ] -> *) -(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) h None c1 c2 ~new_goals:[] ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) by_arg_tac(tac)] -> *) -(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) h (Some rel) c1 c2 ~new_goals:[] ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac)] -> *) -(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) h None c1 c2 ~new_goals:l ] *) -(* | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac)] -> *) -(* [ setoid_replace_in (Option.map Tacinterp.eval_tactic tac) h (Some rel) c1 c2 ~new_goals:l ] *) -(* END *) - -(* TACTIC EXTEND setoid_rewrite *) -(* [ "setoid_rewrite" orient(b) constr(c) ] *) -(* -> [ general_s_rewrite b c ~new_goals:[] ] *) -(* | [ "setoid_rewrite" orient(b) constr(c) "generate" "side" "conditions" constr_list(l) ] *) -(* -> [ general_s_rewrite b c ~new_goals:l ] *) -(* | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) ] -> *) -(* [ general_s_rewrite_in h b c ~new_goals:[] ] *) -(* | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) "generate" "side" "conditions" constr_list(l) ] -> *) -(* [ general_s_rewrite_in h b c ~new_goals:l ] *) -(* END *) - -(* VERNAC COMMAND EXTEND AddSetoid1 *) -(* [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> *) -(* [ add_setoid n a aeq t ] *) -(* | [ "Add" "Morphism" constr(m) ":" ident(n) ] -> *) -(* [ new_named_morphism n m None ] *) -(* | [ "Add" "Morphism" constr(m) "with" "signature" morphism_signature(s) "as" ident(n) ] -> *) -(* [ new_named_morphism n m (Some s)] *) -(* END *) - -(* VERNAC COMMAND EXTEND AddRelation1 *) -(* [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "as" ident(n) ] -> *) -(* [ add_relation n a aeq (Some t) (Some t') None ] *) -(* | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "as" ident(n) ] -> *) -(* [ add_relation n a aeq (Some t) None None ] *) -(* | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> *) -(* [ add_relation n a aeq None None None ] *) -(* END *) - -(* VERNAC COMMAND EXTEND AddRelation2 *) -(* [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "as" ident(n) ] -> *) -(* [ add_relation n a aeq None (Some t') None ] *) -(* | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'') "as" ident(n) ] -> *) -(* [ add_relation n a aeq None (Some t') (Some t'') ] *) -(* END *) - -(* VERNAC COMMAND EXTEND AddRelation3 *) -(* [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "transitivity" "proved" "by" constr(t') "as" ident(n) ] -> *) -(* [ add_relation n a aeq (Some t) None (Some t') ] *) -(* | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'') "as" ident(n) ] -> *) -(* [ add_relation n a aeq (Some t) (Some t') (Some t'') ] *) -(* | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(t) "as" ident(n) ] -> *) -(* [ add_relation n a aeq None None (Some t) ] *) -(* END *) - -(* TACTIC EXTEND setoid_symmetry *) -(* [ "setoid_symmetry" ] -> [ setoid_symmetry ] *) -(* | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] *) -(* END *) - -(* TACTIC EXTEND setoid_reflexivity *) -(* [ "setoid_reflexivity" ] -> [ setoid_reflexivity ] *) -(* END *) - -(* TACTIC EXTEND setoid_transitivity *) -(* [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ] *) -(* END *) - (* Inversion lemmas (Leminv) *) open Inv @@ -485,17 +405,6 @@ END -TACTIC EXTEND apply_in -| ["apply" ne_constr_with_bindings_list_sep(cl,",") "in" hyp(id) ] -> - [ apply_in false id cl ] -END - - -TACTIC EXTEND eapply_in -| ["eapply" ne_constr_with_bindings_list_sep(cl,",") "in" hyp(id) ] -> - [ apply_in true id cl ] -END - (* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) TACTIC EXTEND generalize_eqs @@ -505,8 +414,8 @@ TACTIC EXTEND generalize_eqs_vars | ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize id ~generalize_vars:true ] END -TACTIC EXTEND conv -| ["conv" constr(x) constr(y) ] -> [ conv x y ] +TACTIC EXTEND dependent_pattern +| ["dependent_pattern" constr(c) ] -> [ dependent_pattern c ] END TACTIC EXTEND resolve_classes diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml index 31c1b02f..b270ba2d 100644 --- a/tactics/hiddentac.ml +++ b/tactics/hiddentac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: hiddentac.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: hiddentac.ml 11671 2008-12-12 12:43:03Z herbelin $ *) open Term open Proof_type @@ -39,9 +39,12 @@ let h_exact_no_check c = abstract_tactic (TacExactNoCheck (inj_open c)) (exact_no_check c) let h_vm_cast_no_check c = abstract_tactic (TacVmCastNoCheck (inj_open c)) (vm_cast_no_check c) -let h_apply simple ev cb = - abstract_tactic (TacApply (simple,ev,List.map inj_open_wb cb)) +let h_apply simple ev cb = + abstract_tactic (TacApply (simple,ev,cb,None)) (apply_with_ebindings_gen simple ev cb) +let h_apply_in simple ev cb (id,ipat as inhyp) = + abstract_tactic (TacApply (simple,ev,cb,Some inhyp)) + (apply_in simple ev id cb ipat) let h_elim ev cb cbo = abstract_tactic (TacElim (ev,inj_open_wb cb,Option.map inj_open_wb cbo)) (elim ev cb cbo) @@ -71,7 +74,7 @@ let h_generalize_dep c = abstract_tactic (TacGeneralizeDep (inj_open c))(generalize_dep c) let h_let_tac b na c cl = let with_eq = if b then None else Some (true,(dummy_loc,IntroAnonymous)) in - abstract_tactic (TacLetTac (na,inj_open c,cl,b)) (letin_tac with_eq na c cl) + abstract_tactic (TacLetTac (na,inj_open c,cl,b)) (letin_tac with_eq na c None cl) let h_instantiate n c ido = (Evar_tactics.instantiate n c ido) (* abstract_tactic (TacInstantiate (n,c,cls)) @@ -131,8 +134,8 @@ let h_symmetry c = abstract_tactic (TacSymmetry c) (intros_symmetry c) let h_transitivity c = abstract_tactic (TacTransitivity (inj_open c)) (intros_transitivity c) -let h_simplest_apply c = h_apply false false [c,NoBindings] -let h_simplest_eapply c = h_apply false true [c,NoBindings] +let h_simplest_apply c = h_apply false false [inj_open c,NoBindings] +let h_simplest_eapply c = h_apply false true [inj_open c,NoBindings] let h_simplest_elim c = h_elim false (c,NoBindings) None let h_simplest_case c = h_case false (c,NoBindings) diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli index 3e636668..0ebb024a 100644 --- a/tactics/hiddentac.mli +++ b/tactics/hiddentac.mli @@ -1,3 +1,4 @@ + (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* tactic val h_vm_cast_no_check : constr -> tactic val h_apply : advanced_flag -> evars_flag -> - constr with_ebindings list -> tactic + open_constr with_bindings list -> tactic +val h_apply_in : advanced_flag -> evars_flag -> + open_constr with_bindings list -> + identifier * intro_pattern_expr located option -> tactic val h_elim : evars_flag -> constr with_ebindings -> constr with_ebindings option -> tactic diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index de500f89..2e83ac70 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -8,13 +8,14 @@ (*i camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*) -(* $Id: hipattern.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: hipattern.ml4 11739 2009-01-02 19:33:19Z herbelin $ *) open Pp open Util open Names open Nameops open Term +open Sign open Termops open Reductionops open Inductiveops @@ -64,43 +65,107 @@ let match_with_non_recursive_type t = let is_non_recursive_type t = op2bool (match_with_non_recursive_type t) -(* A general conjunction type is a non-recursive inductive type with - only one constructor. *) +(* Test dependencies *) -let match_with_conjunction t = - let (hdapp,args) = decompose_app t in - match kind_of_term hdapp with - | Ind ind -> - let (mib,mip) = Global.lookup_inductive ind in - if (Array.length mip.mind_consnames = 1) - && (not (mis_is_recursive (ind,mib,mip))) - && (mip.mind_nrealargs = 0) - then - Some (hdapp,args) - else - None - | _ -> None +let rec has_nodep_prod_after n c = + match kind_of_term c with + | Prod (_,_,b) -> + ( n>0 || not (dependent (mkRel 1) b)) + && (has_nodep_prod_after (n-1) b) + | _ -> true + +let has_nodep_prod = has_nodep_prod_after 0 + +(* A general conjunctive type is a non-recursive with-no-indices inductive + type with only one constructor and no dependencies between argument; + it is strict if it has the form + "Inductive I A1 ... An := C (_:A1) ... (_:An)" *) -let is_conjunction t = op2bool (match_with_conjunction t) - -(* A general disjunction type is a non-recursive inductive type all - whose constructors have a single argument. *) +(* style: None = record; Some false = conjunction; Some true = strict conj *) -let match_with_disjunction t = +let match_with_one_constructor style t = let (hdapp,args) = decompose_app t in match kind_of_term hdapp with - | Ind ind -> - let car = mis_constr_nargs ind in - if array_for_all (fun ar -> ar = 1) car && - (let (mib,mip) = Global.lookup_inductive ind in - not (mis_is_recursive (ind,mib,mip))) - then - Some (hdapp,args) - else - None - | _ -> None + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + if (Array.length mip.mind_consnames = 1) + && (not (mis_is_recursive (ind,mib,mip))) + && (mip.mind_nrealargs = 0) + then + if style = Some true (* strict conjunction *) then + let ctx = + fst (decompose_prod_assum (snd + (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in + if + List.for_all + (fun (_,b,c) -> b=None && c = mkRel mib.mind_nparams) ctx + then + Some (hdapp,args) + else None + else + let ctyp = prod_applist mip.mind_nf_lc.(0) args in + let cargs = List.map pi3 (fst (decompose_prod_assum ctyp)) in + if style <> Some false || has_nodep_prod ctyp then + (* Record or non strict conjunction *) + Some (hdapp,List.rev cargs) + else + None + else + None + | _ -> None + +let match_with_conjunction ?(strict=false) t = + match_with_one_constructor (Some strict) t + +let match_with_record t = + match_with_one_constructor None t + +let is_conjunction ?(strict=false) t = + op2bool (match_with_conjunction ~strict t) + +let is_record t = + op2bool (match_with_record t) + + +(* A general disjunction type is a non-recursive with-no-indices inductive + type with of which all constructors have a single argument; + it is strict if it has the form + "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *) + +let test_strict_disjunction n lc = + array_for_all_i (fun i c -> + match fst (decompose_prod_assum (snd (decompose_prod_n_assum n c))) with + | [_,None,c] -> c = mkRel (n - i) + | _ -> false) 0 lc + +let match_with_disjunction ?(strict=false) t = + let (hdapp,args) = decompose_app t in + match kind_of_term hdapp with + | Ind ind -> + let car = mis_constr_nargs ind in + let (mib,mip) = Global.lookup_inductive ind in + if array_for_all (fun ar -> ar = 1) car && + not (mis_is_recursive (ind,mib,mip)) + then + if strict then + if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then + Some (hdapp,args) + else + None + else + let cargs = + Array.map (fun ar -> pi2 (destProd (prod_applist ar args))) + mip.mind_nf_lc in + Some (hdapp,Array.to_list cargs) + else + None + | _ -> None + +let is_disjunction ?(strict=false) t = + op2bool (match_with_disjunction ~strict t) -let is_disjunction t = op2bool (match_with_disjunction t) +(* An empty type is an inductive type, possible with indices, that has no + constructors *) let match_with_empty_type t = let (hdapp,args) = decompose_app t in @@ -113,22 +178,32 @@ let match_with_empty_type t = let is_empty_type t = op2bool (match_with_empty_type t) -let match_with_unit_type t = +(* This filters inductive types with one constructor with no arguments; + Parameters and indices are allowed *) + +let match_with_unit_or_eq_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in - let zero_args c = - nb_prod c = mib.mind_nparams in - if nconstr = 1 && array_for_all zero_args constr_types then + let zero_args c = nb_prod c = mib.mind_nparams in + if nconstr = 1 && zero_args constr_types.(0) then Some hdapp - else + else None | _ -> None -let is_unit_type t = op2bool (match_with_unit_type t) +let is_unit_or_eq_type t = op2bool (match_with_unit_or_eq_type t) + +(* A unit type is an inductive type with no indices but possibly + (useless) parameters, and that has no constructors *) + +let is_unit_type t = + match match_with_conjunction t with + | Some (_,t) when List.length t = 0 -> true + | _ -> false (* Checks if a given term is an application of an inductive binary relation R, so that R has only one constructor @@ -157,6 +232,19 @@ let match_with_equation t = let is_equation t = op2bool (match_with_equation t) +let match_with_equality_type t = + let (hdapp,args) = decompose_app t in + match (kind_of_term hdapp) with + | Ind ind when args <> [] -> + let (mib,mip) = Global.lookup_inductive ind in + let nconstr = Array.length mip.mind_consnames in + if nconstr = 1 && constructor_nrealargs (Global.env()) (ind,1) = 0 + then + Some (hdapp,args) + else + None + | _ -> None + let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ] let match_arrow_pattern t = @@ -186,15 +274,6 @@ let match_with_imp_term c= let is_imp_term c = op2bool (match_with_imp_term c) -let rec has_nodep_prod_after n c = - match kind_of_term c with - | Prod (_,_,b) -> - ( n>0 || not (dependent (mkRel 1) b)) - && (has_nodep_prod_after (n-1) b) - | _ -> true - -let has_nodep_prod = has_nodep_prod_after 0 - let match_with_nodep_ind t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 86cd191e..3c423202 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: hipattern.mli 8866 2006-05-28 16:21:04Z herbelin $ i*) +(*i $Id: hipattern.mli 11739 2009-01-02 19:33:19Z herbelin $ i*) (*i*) open Util @@ -52,23 +52,31 @@ type testing_function = constr -> bool val match_with_non_recursive_type : (constr * constr list) matching_function val is_non_recursive_type : testing_function -val match_with_disjunction : (constr * constr list) matching_function -val is_disjunction : testing_function +val match_with_disjunction : ?strict:bool -> (constr * constr list) matching_function +val is_disjunction : ?strict:bool -> testing_function -val match_with_conjunction : (constr * constr list) matching_function -val is_conjunction : testing_function +val match_with_conjunction : ?strict:bool -> (constr * constr list) matching_function +val is_conjunction : ?strict:bool -> testing_function + +val match_with_record : (constr * constr list) matching_function +val is_record : testing_function val match_with_empty_type : constr matching_function val is_empty_type : testing_function -val match_with_unit_type : constr matching_function +(* type with only one constructor and no arguments, possibly with indices *) +val match_with_unit_or_eq_type : constr matching_function +val is_unit_or_eq_type : testing_function -(* type with only one constructor and no arguments *) +(* type with only one constructor and no arguments, no indices *) val is_unit_type : testing_function val match_with_equation : (constr * constr list) matching_function val is_equation : testing_function +(* type with only one constructor, no arguments and at least one dependency *) +val match_with_equality_type : (constr * constr list) matching_function + val match_with_nottype : (constr * constr) matching_function val is_nottype : testing_function diff --git a/tactics/inv.ml b/tactics/inv.ml index 68ebfd3c..977b602e 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: inv.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: inv.ml 11784 2009-01-14 11:36:32Z herbelin $ *) open Pp open Util @@ -109,8 +109,8 @@ let make_inv_predicate env sigma indf realargs id status concl = match dflt_concl with | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> - let sort = get_sort_of env sigma concl in - let p = make_arity env true indf sort in + let sort = get_sort_family_of env sigma concl in + let p = make_arity env true indf (new_sort_in_family sort) in Unification.abstract_list_all env (Evd.create_evar_defs sigma) p concl (realargs@[mkVar id]) in let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in @@ -469,7 +469,7 @@ let raw_inversion inv_kind id status names gl = case_nodep_then_using in (tclTHENS - (true_cut Anonymous cut_concl) + (assert_tac Anonymous cut_concl) [case_tac names (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns)) (Some elim_predicate) ([],[]) ind indclause; @@ -482,32 +482,14 @@ let raw_inversion inv_kind id status names gl = gl (* Error messages of the inversion tactics *) -let not_found_message ids = - if List.length ids = 1 then - (str "the variable" ++ spc () ++ str (string_of_id (List.hd ids)) ++ spc () ++ - str" was not found in the current environment") - else - (str "the variables [" ++ - spc () ++ prlist (fun id -> (str (string_of_id id) ++ spc ())) ids ++ - str" ] were not found in the current environment") - -let dep_prop_prop_message id = - errorlabstrm "Inv" - (str "Inversion on " ++ pr_id id ++ - str " would need dependent elimination from Prop to Prop.") - -let not_inductive_here id = - errorlabstrm "mind_specif_of_mind" - (str "Cannot recognize an inductive predicate in " ++ pr_id id ++ - str ". If there is one, may be the structure of the arity or of the type of constructors is hidden by constant definitions.") - -(* Noms d'errreurs obsolètes ?? *) let wrap_inv_error id = function - | UserError ("Case analysis",s) -> errorlabstrm "Inv needs Nodep Prop Set" s - | UserError("mind_specif_of_mind",_) -> not_inductive_here id - | UserError (a,b) -> errorlabstrm "Inv" b - | Invalid_argument "List.fold_left2" -> dep_prop_prop_message id - | Not_found -> errorlabstrm "Inv" (not_found_message [id]) + | Indrec.RecursionSchemeError + (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) -> + errorlabstrm "" + (strbrk "Inversion would require case analysis on sort " ++ + pr_sort k ++ + strbrk " which is not allowed for inductive definition " ++ + pr_inductive (Global.env()) i ++ str ".") | e -> raise e (* The most general inversion tactic *) diff --git a/tactics/refine.ml b/tactics/refine.ml index 7ed58f6f..dff3b003 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: refine.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: refine.ml 11671 2008-12-12 12:43:03Z herbelin $ *) (* JCF -- 6 janvier 1998 EXPERIMENTAL *) @@ -275,7 +275,7 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = | Lambda (Name id,_,m), _ -> assert (isMeta (strip_outer_cast m)); begin match sgp with - | [None] -> introduction id gl + | [None] -> intro_mustbe_force id gl | [Some th] -> tclTHEN (introduction id) (onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)) gl @@ -314,7 +314,7 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = because of evars limitation, use non dependent assert instead *) | LetIn (Name id,c1,t1,c2), _ -> tclTHENS - (assert_tac true (Name id) t1) + (assert_tac (Name id) t1) [(match List.hd sgp with | None -> tclIDTAC | Some th -> onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)); diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml deleted file mode 100644 index 95d56f11..00000000 --- a/tactics/setoid_replace.ml +++ /dev/null @@ -1,2023 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false) -let register_replace f = replace := f - -let general_rewrite = ref (fun _ _ -> assert false) -let register_general_rewrite f = general_rewrite := f - -(* util function; it should be in util.mli *) -let prlist_with_sepi sep elem = - let rec aux n = - function - | [] -> mt () - | [h] -> elem n h - | h::t -> - let e = elem n h and s = sep() and r = aux (n+1) t in - e ++ s ++ r - in - aux 1 - -type relation = - { rel_a: constr ; - rel_aeq: constr; - rel_refl: constr option; - rel_sym: constr option; - rel_trans : constr option; - rel_quantifiers_no: int (* it helps unification *); - rel_X_relation_class: constr; - rel_Xreflexive_relation_class: constr - } - -type 'a relation_class = - Relation of 'a (* the rel_aeq of the relation or the relation *) - | Leibniz of constr option (* the carrier (if eq is partially instantiated) *) - -type 'a morphism = - { args : (bool option * 'a relation_class) list; - output : 'a relation_class; - lem : constr; - morphism_theory : constr - } - -type funct = - { f_args : constr list; - f_output : constr - } - -type morphism_class = - ACMorphism of relation morphism - | ACFunction of funct - -let subst_mps_in_relation_class subst = - function - Relation t -> Relation (subst_mps subst t) - | Leibniz t -> Leibniz (Option.map (subst_mps subst) t) - -let subst_mps_in_argument_class subst (variance,rel) = - variance, subst_mps_in_relation_class subst rel - -let constr_relation_class_of_relation_relation_class = - function - Relation relation -> Relation relation.rel_aeq - | Leibniz t -> Leibniz t - - -let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c - -let constant dir s = Coqlib.gen_constant "Setoid_replace" ("Setoids"::dir) s -let gen_constant dir s = Coqlib.gen_constant "Setoid_replace" dir s -let reference dir s = Coqlib.gen_reference "Setoid_replace" ("Setoids"::dir) s -let eval_reference dir s = EvalConstRef (destConst (constant dir s)) -let eval_init_reference dir s = EvalConstRef (destConst (gen_constant ("Init"::dir) s)) - -let current_constant id = - try - global_reference id - with Not_found -> - anomalylabstrm "" - (str "Setoid: cannot find " ++ pr_id id ++ - str "(if loading Setoid.v under coqtop, use option \"-top Coq.Setoids.Setoid_tac\")") - -(* From Setoid.v *) - -let coq_reflexive = - lazy(gen_constant ["Relations"; "Relation_Definitions"] "reflexive") -let coq_symmetric = - lazy(gen_constant ["Relations"; "Relation_Definitions"] "symmetric") -let coq_transitive = - lazy(gen_constant ["Relations"; "Relation_Definitions"] "transitive") -let coq_relation = - lazy(gen_constant ["Relations"; "Relation_Definitions"] "relation") - -let coq_Relation_Class = lazy(constant ["Setoid_tac"] "Relation_Class") -let coq_Argument_Class = lazy(constant ["Setoid_tac"] "Argument_Class") -let coq_Setoid_Theory = lazy(constant ["Setoid"] "Setoid_Theory") -let coq_Morphism_Theory = lazy(constant ["Setoid_tac"] "Morphism_Theory") -let coq_Build_Morphism_Theory= lazy(constant ["Setoid_tac"] "Build_Morphism_Theory") -let coq_Compat = lazy(constant ["Setoid_tac"] "Compat") - -let coq_AsymmetricReflexive = lazy(constant ["Setoid_tac"] "AsymmetricReflexive") -let coq_SymmetricReflexive = lazy(constant ["Setoid_tac"] "SymmetricReflexive") -let coq_SymmetricAreflexive = lazy(constant ["Setoid_tac"] "SymmetricAreflexive") -let coq_AsymmetricAreflexive = lazy(constant ["Setoid_tac"] "AsymmetricAreflexive") -let coq_Leibniz = lazy(constant ["Setoid_tac"] "Leibniz") - -let coq_RAsymmetric = lazy(constant ["Setoid_tac"] "RAsymmetric") -let coq_RSymmetric = lazy(constant ["Setoid_tac"] "RSymmetric") -let coq_RLeibniz = lazy(constant ["Setoid_tac"] "RLeibniz") - -let coq_ASymmetric = lazy(constant ["Setoid_tac"] "ASymmetric") -let coq_AAsymmetric = lazy(constant ["Setoid_tac"] "AAsymmetric") - -let coq_seq_refl = lazy(constant ["Setoid"] "Seq_refl") -let coq_seq_sym = lazy(constant ["Setoid"] "Seq_sym") -let coq_seq_trans = lazy(constant ["Setoid"] "Seq_trans") - -let coq_variance = lazy(constant ["Setoid_tac"] "variance") -let coq_Covariant = lazy(constant ["Setoid_tac"] "Covariant") -let coq_Contravariant = lazy(constant ["Setoid_tac"] "Contravariant") -let coq_Left2Right = lazy(constant ["Setoid_tac"] "Left2Right") -let coq_Right2Left = lazy(constant ["Setoid_tac"] "Right2Left") -let coq_MSNone = lazy(constant ["Setoid_tac"] "MSNone") -let coq_MSCovariant = lazy(constant ["Setoid_tac"] "MSCovariant") -let coq_MSContravariant = lazy(constant ["Setoid_tac"] "MSContravariant") - -let coq_singl = lazy(constant ["Setoid_tac"] "singl") -let coq_cons = lazy(constant ["Setoid_tac"] "necons") - -let coq_equality_morphism_of_asymmetric_areflexive_transitive_relation = - lazy(constant ["Setoid_tac"] - "equality_morphism_of_asymmetric_areflexive_transitive_relation") -let coq_equality_morphism_of_symmetric_areflexive_transitive_relation = - lazy(constant ["Setoid_tac"] - "equality_morphism_of_symmetric_areflexive_transitive_relation") -let coq_equality_morphism_of_asymmetric_reflexive_transitive_relation = - lazy(constant ["Setoid_tac"] - "equality_morphism_of_asymmetric_reflexive_transitive_relation") -let coq_equality_morphism_of_symmetric_reflexive_transitive_relation = - lazy(constant ["Setoid_tac"] - "equality_morphism_of_symmetric_reflexive_transitive_relation") -let coq_make_compatibility_goal = - lazy(constant ["Setoid_tac"] "make_compatibility_goal") -let coq_make_compatibility_goal_eval_ref = - lazy(eval_reference ["Setoid_tac"] "make_compatibility_goal") -let coq_make_compatibility_goal_aux_eval_ref = - lazy(eval_reference ["Setoid_tac"] "make_compatibility_goal_aux") - -let coq_App = lazy(constant ["Setoid_tac"] "App") -let coq_ToReplace = lazy(constant ["Setoid_tac"] "ToReplace") -let coq_ToKeep = lazy(constant ["Setoid_tac"] "ToKeep") -let coq_ProperElementToKeep = lazy(constant ["Setoid_tac"] "ProperElementToKeep") -let coq_fcl_singl = lazy(constant ["Setoid_tac"] "fcl_singl") -let coq_fcl_cons = lazy(constant ["Setoid_tac"] "fcl_cons") - -let coq_setoid_rewrite = lazy(constant ["Setoid_tac"] "setoid_rewrite") -let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1") -let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2") -let coq_unit = lazy(gen_constant ["Init"; "Datatypes"] "unit") -let coq_tt = lazy(gen_constant ["Init"; "Datatypes"] "tt") -let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq") - -let coq_morphism_theory_of_function = - lazy(constant ["Setoid_tac"] "morphism_theory_of_function") -let coq_morphism_theory_of_predicate = - lazy(constant ["Setoid_tac"] "morphism_theory_of_predicate") -let coq_relation_of_relation_class = - lazy(eval_reference ["Setoid_tac"] "relation_of_relation_class") -let coq_directed_relation_of_relation_class = - lazy(eval_reference ["Setoid_tac"] "directed_relation_of_relation_class") -let coq_interp = lazy(eval_reference ["Setoid_tac"] "interp") -let coq_Morphism_Context_rect2 = - lazy(eval_reference ["Setoid_tac"] "Morphism_Context_rect2") -let coq_iff = lazy(gen_constant ["Init";"Logic"] "iff") -let coq_impl = lazy(constant ["Setoid_tac"] "impl") - - -(************************* Table of declared relations **********************) - - -(* Relations are stored in a table which is synchronised with the - Reset mechanism. The table maps the term denoting the relation to - the data of type relation that characterises the relation *) - -let relation_table = ref Gmap.empty - -let relation_table_add (s,th) = relation_table := Gmap.add s th !relation_table -let relation_table_find s = Gmap.find s !relation_table -let relation_table_mem s = Gmap.mem s !relation_table - -let prrelation s = - str "(" ++ pr_lconstr s.rel_a ++ str "," ++ pr_lconstr s.rel_aeq ++ str ")" - -let prrelation_class = - function - Relation eq -> - (try prrelation (relation_table_find eq) - with Not_found -> - str "[[ Error: " ++ pr_lconstr eq ++ - str " is not registered as a relation ]]") - | Leibniz (Some ty) -> pr_lconstr ty - | Leibniz None -> str "_" - -let prmorphism_argument_gen prrelation (variance,rel) = - prrelation rel ++ - match variance with - None -> str " ==> " - | Some true -> str " ++> " - | Some false -> str " --> " - -let prargument_class = prmorphism_argument_gen prrelation_class - -let pr_morphism_signature (l,c) = - prlist (prmorphism_argument_gen Ppconstr.pr_constr_expr) l ++ - Ppconstr.pr_constr_expr c - -let prmorphism k m = - pr_lconstr k ++ str ": " ++ - prlist prargument_class m.args ++ - prrelation_class m.output - - -(* A function that gives back the only relation_class on a given carrier *) -(*CSC: this implementation is really inefficient. I should define a new - map to make it efficient. However, is this really worth of? *) -let default_relation_for_carrier ?(filter=fun _ -> true) a = - let rng = Gmap.rng !relation_table in - match List.filter (fun ({rel_a=rel_a} as r) -> rel_a = a && filter r) rng with - [] -> Leibniz (Some a) - | relation::tl -> - if tl <> [] then - Flags.if_warn msg_warning - (str "There are several relations on the carrier \"" ++ - pr_lconstr a ++ str "\". The relation " ++ prrelation relation ++ - str " is chosen.") ; - Relation relation - -let find_relation_class rel = - try Relation (relation_table_find rel) - with - Not_found -> - let rel = Reduction.whd_betadeltaiota (Global.env ()) rel in - match kind_of_term rel with - | App (eq,[|ty|]) when eq_constr eq (Lazy.force coq_eq) -> Leibniz (Some ty) - | _ when eq_constr rel (Lazy.force coq_eq) -> Leibniz None - | _ -> raise Not_found - -let coq_iff_relation = lazy (find_relation_class (Lazy.force coq_iff)) -let coq_impl_relation = lazy (find_relation_class (Lazy.force coq_impl)) - -let relation_morphism_of_constr_morphism = - let relation_relation_class_of_constr_relation_class = - function - Leibniz t -> Leibniz t - | Relation aeq -> - Relation (try relation_table_find aeq with Not_found -> assert false) - in - function mor -> - let args' = - List.map - (fun (variance,rel) -> - variance, relation_relation_class_of_constr_relation_class rel - ) mor.args in - let output' = relation_relation_class_of_constr_relation_class mor.output in - {mor with args=args' ; output=output'} - -let subst_relation subst relation = - let rel_a' = subst_mps subst relation.rel_a in - let rel_aeq' = subst_mps subst relation.rel_aeq in - let rel_refl' = Option.map (subst_mps subst) relation.rel_refl in - let rel_sym' = Option.map (subst_mps subst) relation.rel_sym in - let rel_trans' = Option.map (subst_mps subst) relation.rel_trans in - let rel_X_relation_class' = subst_mps subst relation.rel_X_relation_class in - let rel_Xreflexive_relation_class' = - subst_mps subst relation.rel_Xreflexive_relation_class - in - if rel_a' == relation.rel_a - && rel_aeq' == relation.rel_aeq - && rel_refl' == relation.rel_refl - && rel_sym' == relation.rel_sym - && rel_trans' == relation.rel_trans - && rel_X_relation_class' == relation.rel_X_relation_class - && rel_Xreflexive_relation_class'==relation.rel_Xreflexive_relation_class - then - relation - else - { rel_a = rel_a' ; - rel_aeq = rel_aeq' ; - rel_refl = rel_refl' ; - rel_sym = rel_sym'; - rel_trans = rel_trans'; - rel_quantifiers_no = relation.rel_quantifiers_no; - rel_X_relation_class = rel_X_relation_class'; - rel_Xreflexive_relation_class = rel_Xreflexive_relation_class' - } - -let equiv_list () = List.map (fun x -> x.rel_aeq) (Gmap.rng !relation_table) - -let _ = - Summary.declare_summary "relation-table" - { Summary.freeze_function = (fun () -> !relation_table); - Summary.unfreeze_function = (fun t -> relation_table := t); - Summary.init_function = (fun () -> relation_table := Gmap .empty); - Summary.survive_module = false; - Summary.survive_section = false } - -(* Declare a new type of object in the environment : "relation-theory". *) - -let (relation_to_obj, obj_to_relation)= - let cache_set (_,(s, th)) = - let th' = - if relation_table_mem s then - begin - let old_relation = relation_table_find s in - let th' = - {th with rel_sym = - match th.rel_sym with - None -> old_relation.rel_sym - | Some t -> Some t} in - Flags.if_warn msg_warning - (strbrk "The relation " ++ prrelation th' ++ - strbrk " is redeclared. The new declaration" ++ - (match th'.rel_refl with - None -> mt () - | Some t -> strbrk " (reflexivity proved by " ++ pr_lconstr t) ++ - (match th'.rel_sym with - None -> mt () - | Some t -> - (if th'.rel_refl = None then strbrk " (" else strbrk " and ") - ++ strbrk "symmetry proved by " ++ pr_lconstr t) ++ - (if th'.rel_refl <> None && th'.rel_sym <> None then - str ")" else str "") ++ - strbrk " replaces the old declaration" ++ - (match old_relation.rel_refl with - None -> str "" - | Some t -> strbrk " (reflexivity proved by " ++ pr_lconstr t) ++ - (match old_relation.rel_sym with - None -> str "" - | Some t -> - (if old_relation.rel_refl = None then - strbrk " (" else strbrk " and ") ++ - strbrk "symmetry proved by " ++ pr_lconstr t) ++ - (if old_relation.rel_refl <> None && old_relation.rel_sym <> None - then str ")" else str "") ++ - str "."); - th' - end - else - th - in - relation_table_add (s,th') - and subst_set (_,subst,(s,th as obj)) = - let s' = subst_mps subst s in - let th' = subst_relation subst th in - if s' == s && th' == th then obj else - (s',th') - and export_set x = Some x - in - declare_object {(default_object "relation-theory") with - cache_function = cache_set; - load_function = (fun i o -> cache_set o); - subst_function = subst_set; - classify_function = (fun (_,x) -> Substitute x); - export_function = export_set} - -(******************************* Table of declared morphisms ********************) - -(* Setoids are stored in a table which is synchronised with the Reset mechanism. *) - -let morphism_table = ref Gmap.empty - -let morphism_table_find m = Gmap.find m !morphism_table -let morphism_table_add (m,c) = - let old = - try - morphism_table_find m - with - Not_found -> [] - in - try - let old_morph = - List.find - (function mor -> mor.args = c.args && mor.output = c.output) old - in - Flags.if_warn msg_warning - (strbrk "The morphism " ++ prmorphism m old_morph ++ - strbrk " is redeclared. " ++ - strbrk "The new declaration whose compatibility is proved by " ++ - pr_lconstr c.lem ++ strbrk " replaces the old declaration whose" ++ - strbrk " compatibility was proved by " ++ - pr_lconstr old_morph.lem ++ str ".") - with - Not_found -> morphism_table := Gmap.add m (c::old) !morphism_table - -let default_morphism ?(filter=fun _ -> true) m = - match List.filter filter (morphism_table_find m) with - [] -> raise Not_found - | m1::ml -> - if ml <> [] then - Flags.if_warn msg_warning - (strbrk "There are several morphisms associated to \"" ++ - pr_lconstr m ++ strbrk "\". Morphism " ++ prmorphism m m1 ++ - strbrk " is randomly chosen."); - relation_morphism_of_constr_morphism m1 - -let subst_morph subst morph = - let lem' = subst_mps subst morph.lem in - let args' = list_smartmap (subst_mps_in_argument_class subst) morph.args in - let output' = subst_mps_in_relation_class subst morph.output in - let morphism_theory' = subst_mps subst morph.morphism_theory in - if lem' == morph.lem - && args' == morph.args - && output' == morph.output - && morphism_theory' == morph.morphism_theory - then - morph - else - { args = args' ; - output = output' ; - lem = lem' ; - morphism_theory = morphism_theory' - } - - -let _ = - Summary.declare_summary "morphism-table" - { Summary.freeze_function = (fun () -> !morphism_table); - Summary.unfreeze_function = (fun t -> morphism_table := t); - Summary.init_function = (fun () -> morphism_table := Gmap .empty); - Summary.survive_module = false; - Summary.survive_section = false } - -(* Declare a new type of object in the environment : "morphism-definition". *) - -let (morphism_to_obj, obj_to_morphism)= - let cache_set (_,(m, c)) = morphism_table_add (m, c) - and subst_set (_,subst,(m,c as obj)) = - let m' = subst_mps subst m in - let c' = subst_morph subst c in - if m' == m && c' == c then obj else - (m',c') - and export_set x = Some x - in - declare_object {(default_object "morphism-definition") with - cache_function = cache_set; - load_function = (fun i o -> cache_set o); - subst_function = subst_set; - classify_function = (fun (_,x) -> Substitute x); - export_function = export_set} - -(************************** Printing relations and morphisms **********************) - -let print_setoids () = - Gmap.iter - (fun k relation -> - assert (k=relation.rel_aeq) ; - ppnl (str"Relation " ++ prrelation relation ++ str";" ++ - (match relation.rel_refl with - None -> str "" - | Some t -> str" reflexivity proved by " ++ pr_lconstr t) ++ - (match relation.rel_sym with - None -> str "" - | Some t -> str " symmetry proved by " ++ pr_lconstr t) ++ - (match relation.rel_trans with - None -> str "" - | Some t -> str " transitivity proved by " ++ pr_lconstr t))) - !relation_table ; - Gmap.iter - (fun k l -> - List.iter - (fun ({lem=lem} as mor) -> - ppnl (str "Morphism " ++ prmorphism k mor ++ - str ". Compatibility proved by " ++ - pr_lconstr lem ++ str ".")) - l) !morphism_table -;; - -(***************** Adding a morphism to the database ****************************) - -(* We maintain a table of the currently edited proofs of morphism lemma - in order to add them in the morphism_table when the user does Save *) - -let edited = ref Gmap.empty - -let new_edited id m = - edited := Gmap.add id m !edited - -let is_edited id = - Gmap.mem id !edited - -let no_more_edited id = - edited := Gmap.remove id !edited - -let what_edited id = - Gmap.find id !edited - -(* also returns the triple (args_ty_quantifiers_rev,real_args_ty,real_output) - where the args_ty and the output are delifted *) -let check_is_dependent n args_ty output = - let m = List.length args_ty - n in - let args_ty_quantifiers, args_ty = Util.list_chop n args_ty in - let rec aux m t = - match kind_of_term t with - Prod (n,s,t) when m > 0 -> - if not (dependent (mkRel 1) t) then - let args,out = aux (m - 1) (subst1 (mkRel 1) (* dummy *) t) in - s::args,out - else - errorlabstrm "New Morphism" - (str "The morphism is not a quantified non dependent product.") - | _ -> [],t - in - let ty = compose_prod (List.rev args_ty) output in - let args_ty, output = aux m ty in - List.rev args_ty_quantifiers, args_ty, output - -let cic_relation_class_of_X_relation typ value = - function - {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} -> - mkApp ((Lazy.force coq_AsymmetricReflexive), - [| typ ; value ; rel_a ; rel_aeq; refl |]) - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} -> - mkApp ((Lazy.force coq_SymmetricReflexive), - [| typ ; rel_a ; rel_aeq; sym ; refl |]) - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} -> - mkApp ((Lazy.force coq_AsymmetricAreflexive), - [| typ ; value ; rel_a ; rel_aeq |]) - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} -> - mkApp ((Lazy.force coq_SymmetricAreflexive), - [| typ ; rel_a ; rel_aeq; sym |]) - -let cic_relation_class_of_X_relation_class typ value = - function - Relation {rel_X_relation_class=x_relation_class} -> - mkApp (x_relation_class, [| typ ; value |]) - | Leibniz (Some t) -> - mkApp ((Lazy.force coq_Leibniz), [| typ ; t |]) - | Leibniz None -> assert false - - -let cic_precise_relation_class_of_relation = - function - {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} -> - mkApp ((Lazy.force coq_RAsymmetric), [| rel_a ; rel_aeq; refl |]) - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} -> - mkApp ((Lazy.force coq_RSymmetric), [| rel_a ; rel_aeq; sym ; refl |]) - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} -> - mkApp ((Lazy.force coq_AAsymmetric), [| rel_a ; rel_aeq |]) - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} -> - mkApp ((Lazy.force coq_ASymmetric), [| rel_a ; rel_aeq; sym |]) - -let cic_precise_relation_class_of_relation_class = - function - Relation - {rel_aeq=rel_aeq; rel_Xreflexive_relation_class=lem; rel_refl=rel_refl } - -> - rel_aeq,lem,not(rel_refl=None) - | Leibniz (Some t) -> - mkApp ((Lazy.force coq_eq), [| t |]), - mkApp ((Lazy.force coq_RLeibniz), [| t |]), true - | Leibniz None -> assert false - -let cic_relation_class_of_relation_class rel = - cic_relation_class_of_X_relation_class - (Lazy.force coq_unit) (Lazy.force coq_tt) rel - -let cic_argument_class_of_argument_class (variance,arg) = - let coq_variant_value = - match variance with - None -> (Lazy.force coq_Covariant) (* dummy value, it won't be used *) - | Some true -> (Lazy.force coq_Covariant) - | Some false -> (Lazy.force coq_Contravariant) - in - cic_relation_class_of_X_relation_class (Lazy.force coq_variance) - coq_variant_value arg - -let cic_arguments_of_argument_class_list args = - let rec aux = - function - [] -> assert false - | [last] -> - mkApp ((Lazy.force coq_singl), [| Lazy.force coq_Argument_Class; last |]) - | he::tl -> - mkApp ((Lazy.force coq_cons), - [| Lazy.force coq_Argument_Class; he ; aux tl |]) - in - aux (List.map cic_argument_class_of_argument_class args) - -let gen_compat_lemma_statement quantifiers_rev output args m = - let output = cic_relation_class_of_relation_class output in - let args = cic_arguments_of_argument_class_list args in - args, output, - compose_prod quantifiers_rev - (mkApp ((Lazy.force coq_make_compatibility_goal), [| args ; output ; m |])) - -let morphism_theory_id_of_morphism_proof_id id = - id_of_string (string_of_id id ^ "_morphism_theory") - -(* apply_to_rels c [l1 ; ... ; ln] returns (c Rel1 ... reln) *) -let apply_to_rels c l = - if l = [] then c - else - let len = List.length l in - applistc c (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 l) - -let apply_to_relation subst rel = - if Array.length subst = 0 then rel - else - let new_quantifiers_no = rel.rel_quantifiers_no - Array.length subst in - assert (new_quantifiers_no >= 0) ; - { rel_a = mkApp (rel.rel_a, subst) ; - rel_aeq = mkApp (rel.rel_aeq, subst) ; - rel_refl = Option.map (fun c -> mkApp (c,subst)) rel.rel_refl ; - rel_sym = Option.map (fun c -> mkApp (c,subst)) rel.rel_sym; - rel_trans = Option.map (fun c -> mkApp (c,subst)) rel.rel_trans; - rel_quantifiers_no = new_quantifiers_no; - rel_X_relation_class = mkApp (rel.rel_X_relation_class, subst); - rel_Xreflexive_relation_class = - mkApp (rel.rel_Xreflexive_relation_class, subst) } - -let add_morphism lemma_infos mor_name (m,quantifiers_rev,args,output) = - let lem = - match lemma_infos with - None -> - (* the Morphism_Theory object has already been created *) - let applied_args = - let len = List.length quantifiers_rev in - let subst = - Array.of_list - (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 quantifiers_rev) - in - List.map - (fun (v,rel) -> - match rel with - Leibniz (Some t) -> - assert (subst=[||]); - v, Leibniz (Some t) - | Leibniz None -> - assert (Array.length subst = 1); - v, Leibniz (Some (subst.(0))) - | Relation rel -> v, Relation (apply_to_relation subst rel)) args - in - compose_lam quantifiers_rev - (mkApp (Lazy.force coq_Compat, - [| cic_arguments_of_argument_class_list applied_args; - cic_relation_class_of_relation_class output; - apply_to_rels (current_constant mor_name) quantifiers_rev |])) - | Some (lem_name,argsconstr,outputconstr) -> - (* only the compatibility has been proved; we need to declare the - Morphism_Theory object *) - let mext = current_constant lem_name in - ignore ( - Declare.declare_internal_constant mor_name - (DefinitionEntry - {const_entry_body = - compose_lam quantifiers_rev - (mkApp ((Lazy.force coq_Build_Morphism_Theory), - [| argsconstr; outputconstr; apply_to_rels m quantifiers_rev ; - apply_to_rels mext quantifiers_rev |])); - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions()}, - IsDefinition Definition)) ; - mext - in - let mmor = current_constant mor_name in - let args_constr = - List.map - (fun (variance,arg) -> - variance, constr_relation_class_of_relation_relation_class arg) args in - let output_constr = constr_relation_class_of_relation_relation_class output in - Lib.add_anonymous_leaf - (morphism_to_obj (m, - { args = args_constr; - output = output_constr; - lem = lem; - morphism_theory = mmor })); - Flags.if_verbose ppnl (pr_lconstr m ++ str " is registered as a morphism") - -let error_cannot_unify_signature env k t t' = - errorlabstrm "New Morphism" - (str "One morphism argument or its output has type" ++ spc() ++ - pr_lconstr_env env t ++ strbrk " but the signature requires an argument" ++ - (if k = 0 then strbrk " of type " else - strbrk "whose type is an instance of ") ++ pr_lconstr_env env t' ++ - str ".") - -(* first order matching with a bit of conversion *) -let unify_relation_carrier_with_type env rel t = - let args = - match kind_of_term t with - App (he',args') -> - let argsno = Array.length args' - rel.rel_quantifiers_no in - let args1 = Array.sub args' 0 argsno in - let args2 = Array.sub args' argsno rel.rel_quantifiers_no in - if is_conv env Evd.empty rel.rel_a (mkApp (he',args1)) then - args2 - else - error_cannot_unify_signature env rel.rel_quantifiers_no t rel.rel_a - | _ -> - try - let args = - Clenv.clenv_conv_leq env Evd.empty t rel.rel_a rel.rel_quantifiers_no - in - Array.of_list args - with Reduction.NotConvertible -> - error_cannot_unify_signature env rel.rel_quantifiers_no t rel.rel_a - in - apply_to_relation args rel - -let unify_relation_class_carrier_with_type env rel t = - match rel with - Leibniz (Some t') -> - if is_conv env Evd.empty t t' then - rel - else - error_cannot_unify_signature env 0 t t' - | Leibniz None -> Leibniz (Some t) - | Relation rel -> Relation (unify_relation_carrier_with_type env rel t) - -exception Impossible - -(* first order matching with a bit of conversion *) -(* Note: the type checking operations performed by the function could *) -(* be done once and for all abstracting the morphism structure using *) -(* the quantifiers. Would the new structure be more suited than the *) -(* existent one for other tasks to? (e.g. pretty printing would expose *) -(* much more information: is it ok or is it too much information?) *) -let unify_morphism_with_arguments gl (c,av) - {args=args; output=output; lem=lem; morphism_theory=morphism_theory} t -= - let avlen = Array.length av in - let argsno = List.length args in - if avlen < argsno then raise Impossible; (* partial application *) - let al = Array.to_list av in - let quantifiers,al' = Util.list_chop (avlen - argsno) al in - let quantifiersv = Array.of_list quantifiers in - let c' = mkApp (c,quantifiersv) in - if dependent t c' then raise Impossible; - (* these are pf_type_of we could avoid *) - let al'_type = List.map (Tacmach.pf_type_of gl) al' in - let args' = - List.map2 - (fun (var,rel) ty -> - var,unify_relation_class_carrier_with_type (pf_env gl) rel ty) - args al'_type in - (* this is another pf_type_of we could avoid *) - let ty = Tacmach.pf_type_of gl (mkApp (c,av)) in - let output' = unify_relation_class_carrier_with_type (pf_env gl) output ty in - let lem' = mkApp (lem,quantifiersv) in - let morphism_theory' = mkApp (morphism_theory,quantifiersv) in - ({args=args'; output=output'; lem=lem'; morphism_theory=morphism_theory'}, - c',Array.of_list al') - -let new_morphism m signature id hook = - if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then - errorlabstrm "New Morphism" (pr_id id ++ str " already exists") - else - let env = Global.env() in - let typeofm = Typing.type_of env Evd.empty m in - let typ = clos_norm_flags Closure.betaiotazeta empty_env Evd.empty typeofm in - let argsrev, output = - match signature with - None -> decompose_prod typ - | Some (_,output') -> - (* the carrier of the relation output' can be a Prod ==> - we must uncurry on the fly output. - E.g: A -> B -> C vs A -> (B -> C) - args output args output - *) - let rel = - try find_relation_class output' - with Not_found -> errorlabstrm "Add Morphism" - (str "Not a valid signature: " ++ pr_lconstr output' ++ - str " is neither a registered relation nor the Leibniz " ++ - str " equality.") in - let rel_a,rel_quantifiers_no = - match rel with - Relation rel -> rel.rel_a, rel.rel_quantifiers_no - | Leibniz (Some t) -> t, 0 - | Leibniz None -> let _,t = decompose_prod typ in t, 0 in - let rel_a_n = - clos_norm_flags Closure.betaiotazeta empty_env Evd.empty rel_a - in - try - let _,output_rel_a_n = decompose_lam_n rel_quantifiers_no rel_a_n in - let argsrev,_ = decompose_prod output_rel_a_n in - let n = List.length argsrev in - let argsrev',_ = decompose_prod typ in - let m = List.length argsrev' in - decompose_prod_n (m - n) typ - with UserError(_,_) -> - (* decompose_lam_n failed. This may happen when rel_a is an axiom, - a constructor, an inductive type, etc. *) - decompose_prod typ - in - let args_ty = List.rev argsrev in - let args_ty_len = List.length (args_ty) in - let args_ty_quantifiers_rev,args,args_instance,output,output_instance = - match signature with - None -> - if args_ty = [] then - errorlabstrm "New Morphism" - (str "The term " ++ pr_lconstr m ++ str " has type " ++ - pr_lconstr typeofm ++ str " that is not a product.") ; - ignore (check_is_dependent 0 args_ty output) ; - let args = - List.map - (fun (_,ty) -> None,default_relation_for_carrier ty) args_ty in - let output = default_relation_for_carrier output in - [],args,args,output,output - | Some (args,output') -> - assert (args <> []); - let number_of_arguments = List.length args in - let number_of_quantifiers = args_ty_len - number_of_arguments in - if number_of_quantifiers < 0 then - errorlabstrm "New Morphism" - (str "The morphism " ++ pr_lconstr m ++ str " has type " ++ - pr_lconstr typeofm ++ str " that expects at most " ++ int args_ty_len ++ - str " arguments. The signature that you specified requires " ++ - int number_of_arguments ++ str " arguments.") - else - begin - (* the real_args_ty returned are already delifted *) - let args_ty_quantifiers_rev, real_args_ty, real_output = - check_is_dependent number_of_quantifiers args_ty output in - let quantifiers_rel_context = - List.map (fun (n,t) -> n,None,t) args_ty_quantifiers_rev in - let env = push_rel_context quantifiers_rel_context env in - let find_relation_class t real_t = - try - let rel = find_relation_class t in - rel, unify_relation_class_carrier_with_type env rel real_t - with Not_found -> - errorlabstrm "Add Morphism" - (str "Not a valid signature: " ++ pr_lconstr t ++ - str " is neither a registered relation nor the Leibniz " ++ - str " equality.") - in - let find_relation_class_v (variance,t) real_t = - let relation,relation_instance = find_relation_class t real_t in - match relation, variance with - Leibniz _, None - | Relation {rel_sym = Some _}, None - | Relation {rel_sym = None}, Some _ -> - (variance, relation), (variance, relation_instance) - | Relation {rel_sym = None},None -> - errorlabstrm "Add Morphism" - (str "You must specify the variance in each argument " ++ - str "whose relation is asymmetric.") - | Leibniz _, Some _ - | Relation {rel_sym = Some _}, Some _ -> - errorlabstrm "Add Morphism" - (str "You cannot specify the variance of an argument " ++ - str "whose relation is symmetric.") - in - let args, args_instance = - List.split - (List.map2 find_relation_class_v args real_args_ty) in - let output,output_instance= find_relation_class output' real_output in - args_ty_quantifiers_rev, args, args_instance, output, output_instance - end - in - let argsconstr,outputconstr,lem = - gen_compat_lemma_statement args_ty_quantifiers_rev output_instance - args_instance (apply_to_rels m args_ty_quantifiers_rev) in - (* "unfold make_compatibility_goal" *) - let lem = - Reductionops.clos_norm_flags - (Closure.unfold_red (Lazy.force coq_make_compatibility_goal_eval_ref)) - env Evd.empty lem in - (* "unfold make_compatibility_goal_aux" *) - let lem = - Reductionops.clos_norm_flags - (Closure.unfold_red(Lazy.force coq_make_compatibility_goal_aux_eval_ref)) - env Evd.empty lem in - (* "simpl" *) - let lem = Tacred.simpl env Evd.empty lem in - if Lib.is_modtype () then - begin - ignore - (Declare.declare_internal_constant id - (ParameterEntry (lem,false), IsAssumption Logical)) ; - let mor_name = morphism_theory_id_of_morphism_proof_id id in - let lemma_infos = Some (id,argsconstr,outputconstr) in - add_morphism lemma_infos mor_name - (m,args_ty_quantifiers_rev,args,output) - end - else - begin - new_edited id - (m,args_ty_quantifiers_rev,args,argsconstr,output,outputconstr); - Pfedit.start_proof id (Global, Proof Lemma) - (Decls.clear_proofs (Global.named_context ())) - lem hook; - Flags.if_verbose msg (Printer.pr_open_subgoals ()); - end - -let morphism_hook _ ref = - let pf_id = id_of_global ref in - let mor_id = morphism_theory_id_of_morphism_proof_id pf_id in - let (m,quantifiers_rev,args,argsconstr,output,outputconstr) = - what_edited pf_id in - if (is_edited pf_id) - then - begin - add_morphism (Some (pf_id,argsconstr,outputconstr)) mor_id - (m,quantifiers_rev,args,output) ; - no_more_edited pf_id - end - -type morphism_signature = - (bool option * Topconstr.constr_expr) list * Topconstr.constr_expr - -let new_named_morphism id m sign = - Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"]; - let sign = - match sign with - None -> None - | Some (args,out) -> - if args = [] then - error "Morphism signature expects at least one argument."; - Some - (List.map (fun (variance,ty) -> variance, constr_of ty) args, - constr_of out) - in - new_morphism (constr_of m) sign id morphism_hook - -(************************** Adding a relation to the database *********************) - -let check_a env a = - let typ = Typing.type_of env Evd.empty a in - let a_quantifiers_rev,_ = Reduction.dest_arity env typ in - a_quantifiers_rev - -let check_eq env a_quantifiers_rev a aeq = - let typ = - Sign.it_mkProd_or_LetIn - (mkApp ((Lazy.force coq_relation),[| apply_to_rels a a_quantifiers_rev |])) - a_quantifiers_rev in - if - not - (is_conv env Evd.empty (Typing.type_of env Evd.empty aeq) typ) - then - errorlabstrm "Add Relation Class" - (pr_lconstr aeq ++ str " should have type (" ++ pr_lconstr typ ++ str ")") - -let check_property env a_quantifiers_rev a aeq strprop coq_prop t = - if - not - (is_conv env Evd.empty (Typing.type_of env Evd.empty t) - (Sign.it_mkProd_or_LetIn - (mkApp ((Lazy.force coq_prop), - [| apply_to_rels a a_quantifiers_rev ; - apply_to_rels aeq a_quantifiers_rev |])) a_quantifiers_rev)) - then - errorlabstrm "Add Relation Class" - (str "Not a valid proof of " ++ str strprop ++ str ".") - -let check_refl env a_quantifiers_rev a aeq refl = - check_property env a_quantifiers_rev a aeq "reflexivity" coq_reflexive refl - -let check_sym env a_quantifiers_rev a aeq sym = - check_property env a_quantifiers_rev a aeq "symmetry" coq_symmetric sym - -let check_trans env a_quantifiers_rev a aeq trans = - check_property env a_quantifiers_rev a aeq "transitivity" coq_transitive trans - -let check_setoid_theory env a_quantifiers_rev a aeq th = - if - not - (is_conv env Evd.empty (Typing.type_of env Evd.empty th) - (Sign.it_mkProd_or_LetIn - (mkApp ((Lazy.force coq_Setoid_Theory), - [| apply_to_rels a a_quantifiers_rev ; - apply_to_rels aeq a_quantifiers_rev |])) a_quantifiers_rev)) - then - errorlabstrm "Add Relation Class" - (str "Not a valid proof of symmetry") - -let int_add_relation id a aeq refl sym trans = - let env = Global.env () in - let a_quantifiers_rev = check_a env a in - check_eq env a_quantifiers_rev a aeq ; - Option.iter (check_refl env a_quantifiers_rev a aeq) refl ; - Option.iter (check_sym env a_quantifiers_rev a aeq) sym ; - Option.iter (check_trans env a_quantifiers_rev a aeq) trans ; - let quantifiers_no = List.length a_quantifiers_rev in - let aeq_rel = - { rel_a = a; - rel_aeq = aeq; - rel_refl = refl; - rel_sym = sym; - rel_trans = trans; - rel_quantifiers_no = quantifiers_no; - rel_X_relation_class = mkProp; (* dummy value, overwritten below *) - rel_Xreflexive_relation_class = mkProp (* dummy value, overwritten below *) - } in - let x_relation_class = - let subst = - let len = List.length a_quantifiers_rev in - Array.of_list - (Util.list_map_i (fun i _ -> mkRel (len - i + 2)) 0 a_quantifiers_rev) in - cic_relation_class_of_X_relation - (mkRel 2) (mkRel 1) (apply_to_relation subst aeq_rel) in - let _ = - Declare.declare_internal_constant id - (DefinitionEntry - {const_entry_body = - Sign.it_mkLambda_or_LetIn x_relation_class - ([ Name (id_of_string "v"),None,mkRel 1; - Name (id_of_string "X"),None,mkType (Termops.new_univ ())] @ - a_quantifiers_rev); - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions()}, - IsDefinition Definition) in - let id_precise = id_of_string (string_of_id id ^ "_precise_relation_class") in - let xreflexive_relation_class = - let subst = - let len = List.length a_quantifiers_rev in - Array.of_list - (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 a_quantifiers_rev) - in - cic_precise_relation_class_of_relation (apply_to_relation subst aeq_rel) in - let _ = - Declare.declare_internal_constant id_precise - (DefinitionEntry - {const_entry_body = - Sign.it_mkLambda_or_LetIn xreflexive_relation_class a_quantifiers_rev; - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() }, - IsDefinition Definition) in - let aeq_rel = - { aeq_rel with - rel_X_relation_class = current_constant id; - rel_Xreflexive_relation_class = current_constant id_precise } in - Lib.add_anonymous_leaf (relation_to_obj (aeq, aeq_rel)) ; - Flags.if_verbose ppnl (pr_lconstr aeq ++ str " is registered as a relation"); - match trans with - None -> () - | Some trans -> - let mor_name = id_of_string (string_of_id id ^ "_morphism") in - let a_instance = apply_to_rels a a_quantifiers_rev in - let aeq_instance = apply_to_rels aeq a_quantifiers_rev in - let sym_instance = - Option.map (fun x -> apply_to_rels x a_quantifiers_rev) sym in - let refl_instance = - Option.map (fun x -> apply_to_rels x a_quantifiers_rev) refl in - let trans_instance = apply_to_rels trans a_quantifiers_rev in - let aeq_rel_class_and_var1, aeq_rel_class_and_var2, lemma, output = - match sym_instance, refl_instance with - None, None -> - (Some false, Relation aeq_rel), - (Some true, Relation aeq_rel), - mkApp - ((Lazy.force - coq_equality_morphism_of_asymmetric_areflexive_transitive_relation), - [| a_instance ; aeq_instance ; trans_instance |]), - Lazy.force coq_impl_relation - | None, Some refl_instance -> - (Some false, Relation aeq_rel), - (Some true, Relation aeq_rel), - mkApp - ((Lazy.force - coq_equality_morphism_of_asymmetric_reflexive_transitive_relation), - [| a_instance ; aeq_instance ; refl_instance ; trans_instance |]), - Lazy.force coq_impl_relation - | Some sym_instance, None -> - (None, Relation aeq_rel), - (None, Relation aeq_rel), - mkApp - ((Lazy.force - coq_equality_morphism_of_symmetric_areflexive_transitive_relation), - [| a_instance ; aeq_instance ; sym_instance ; trans_instance |]), - Lazy.force coq_iff_relation - | Some sym_instance, Some refl_instance -> - (None, Relation aeq_rel), - (None, Relation aeq_rel), - mkApp - ((Lazy.force - coq_equality_morphism_of_symmetric_reflexive_transitive_relation), - [| a_instance ; aeq_instance ; refl_instance ; sym_instance ; - trans_instance |]), - Lazy.force coq_iff_relation in - let _ = - Declare.declare_internal_constant mor_name - (DefinitionEntry - {const_entry_body = Sign.it_mkLambda_or_LetIn lemma a_quantifiers_rev; - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions()}, - IsDefinition Definition) - in - let a_quantifiers_rev = - List.map (fun (n,b,t) -> assert (b = None); n,t) a_quantifiers_rev in - add_morphism None mor_name - (aeq,a_quantifiers_rev,[aeq_rel_class_and_var1; aeq_rel_class_and_var2], - output) - -(* The vernac command "Add Relation ..." *) -let add_relation id a aeq refl sym trans = - Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"]; - int_add_relation id (constr_of a) (constr_of aeq) (Option.map constr_of refl) - (Option.map constr_of sym) (Option.map constr_of trans) - -(************************ Add Setoid ******************************************) - -(* The vernac command "Add Setoid" *) -let add_setoid id a aeq th = - Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"]; - let a = constr_of a in - let aeq = constr_of aeq in - let th = constr_of th in - let env = Global.env () in - let a_quantifiers_rev = check_a env a in - check_eq env a_quantifiers_rev a aeq ; - check_setoid_theory env a_quantifiers_rev a aeq th ; - let a_instance = apply_to_rels a a_quantifiers_rev in - let aeq_instance = apply_to_rels aeq a_quantifiers_rev in - let th_instance = apply_to_rels th a_quantifiers_rev in - let refl = - Sign.it_mkLambda_or_LetIn - (mkApp ((Lazy.force coq_seq_refl), - [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in - let sym = - Sign.it_mkLambda_or_LetIn - (mkApp ((Lazy.force coq_seq_sym), - [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in - let trans = - Sign.it_mkLambda_or_LetIn - (mkApp ((Lazy.force coq_seq_trans), - [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in - int_add_relation id a aeq (Some refl) (Some sym) (Some trans) - - -(****************************** The tactic itself *******************************) - -type direction = - Left2Right - | Right2Left - -let prdirection = - function - Left2Right -> str "->" - | Right2Left -> str "<-" - -type constr_with_marks = - | MApp of constr * morphism_class * constr_with_marks array * direction - | ToReplace - | ToKeep of constr * relation relation_class * direction - -let is_to_replace = function - | ToKeep _ -> false - | ToReplace -> true - | MApp _ -> true - -let get_mark a = - Array.fold_left (||) false (Array.map is_to_replace a) - -let cic_direction_of_direction = - function - Left2Right -> Lazy.force coq_Left2Right - | Right2Left -> Lazy.force coq_Right2Left - -let opposite_direction = - function - Left2Right -> Right2Left - | Right2Left -> Left2Right - -let direction_of_constr_with_marks hole_direction = - function - MApp (_,_,_,dir) -> cic_direction_of_direction dir - | ToReplace -> hole_direction - | ToKeep (_,_,dir) -> cic_direction_of_direction dir - -type argument = - Toapply of constr (* apply the function to the argument *) - | Toexpand of name * types (* beta-expand the function w.r.t. an argument - of this type *) -let beta_expand c args_rev = - let rec to_expand = - function - [] -> [] - | (Toapply _)::tl -> to_expand tl - | (Toexpand (name,s))::tl -> (name,s)::(to_expand tl) in - let rec aux n = - function - [] -> [] - | (Toapply arg)::tl -> arg::(aux n tl) - | (Toexpand _)::tl -> (mkRel n)::(aux (n + 1) tl) - in - compose_lam (to_expand args_rev) - (mkApp (c, Array.of_list (List.rev (aux 1 args_rev)))) - -exception Optimize (* used to fall-back on the tactic for Leibniz equality *) - -let relation_class_that_matches_a_constr caller_name new_goals hypt = - let (heq, hargs) = decompose_app hypt in - let rec get_all_but_last_two = - function - [] - | [_] -> - errorlabstrm caller_name (pr_lconstr hypt ++ - str " is not a registered relation.") - | [_;_] -> [] - | he::tl -> he::(get_all_but_last_two tl) in - let all_aeq_args = get_all_but_last_two hargs in - let rec find_relation l subst = - let aeq = mkApp (heq,(Array.of_list l)) in - try - let rel = find_relation_class aeq in - match rel,new_goals with - Leibniz _,[] -> - assert (subst = []); - raise Optimize (* let's optimize the proof term size *) - | Leibniz (Some _), _ -> - assert (subst = []); - rel - | Leibniz None, _ -> - (* for well-typedness reasons it should have been catched by the - previous guard in the previous iteration. *) - assert false - | Relation rel,_ -> Relation (apply_to_relation (Array.of_list subst) rel) - with Not_found -> - if l = [] then - errorlabstrm caller_name - (pr_lconstr (mkApp (aeq, Array.of_list all_aeq_args)) ++ - str " is not a registered relation.") - else - let last,others = Util.list_sep_last l in - find_relation others (last::subst) - in - find_relation all_aeq_args [] - -(* rel1 is a subrelation of rel2 whenever - forall x1 x2, rel1 x1 x2 -> rel2 x1 x2 - The Coq part of the tactic, however, needs rel1 == rel2. - Hence the third case commented out. - Note: accepting user-defined subrelations seems to be the last - useful generalization that does not go against the original spirit of - the tactic. -*) -let subrelation gl rel1 rel2 = - match rel1,rel2 with - Relation {rel_aeq=rel_aeq1}, Relation {rel_aeq=rel_aeq2} -> - Tacmach.pf_conv_x gl rel_aeq1 rel_aeq2 - | Leibniz (Some t1), Leibniz (Some t2) -> - Tacmach.pf_conv_x gl t1 t2 - | Leibniz None, _ - | _, Leibniz None -> assert false -(* This is the commented out case (see comment above) - | Leibniz (Some t1), Relation {rel_a=t2; rel_refl = Some _} -> - Tacmach.pf_conv_x gl t1 t2 -*) - | _,_ -> false - -(* this function returns the list of new goals opened by a constr_with_marks *) -let rec collect_new_goals = - function - MApp (_,_,a,_) -> List.concat (List.map collect_new_goals (Array.to_list a)) - | ToReplace - | ToKeep (_,Leibniz _,_) - | ToKeep (_,Relation {rel_refl=Some _},_) -> [] - | ToKeep (c,Relation {rel_aeq=aeq; rel_refl=None},_) -> [mkApp(aeq,[|c ; c|])] - -(* two marked_constr are equivalent if they produce the same set of new goals *) -let marked_constr_equiv_or_more_complex to_marked_constr gl c1 c2 = - let glc1 = collect_new_goals (to_marked_constr c1) in - let glc2 = collect_new_goals (to_marked_constr c2) in - List.for_all (fun c -> List.exists (fun c' -> pf_conv_x gl c c') glc1) glc2 - -let pr_new_goals i c = - let glc = collect_new_goals c in - str " " ++ int i ++ str ") side conditions:" ++ - (if glc = [] then str " no side conditions" - else - (pr_fnl () ++ str " " ++ - prlist_with_sep (fun () -> str "\n ") - (fun c -> str " ... |- " ++ pr_lconstr c) glc)) - -(* given a list of constr_with_marks, it returns the list where - constr_with_marks than open more goals than simpler ones in the list - are got rid of *) -let elim_duplicates gl to_marked_constr = - let rec aux = - function - [] -> [] - | he:: tl -> - if List.exists - (marked_constr_equiv_or_more_complex to_marked_constr gl he) tl - then aux tl - else he::aux tl - in - aux - -let filter_superset_of_new_goals gl new_goals l = - List.filter - (fun (_,_,c) -> - List.for_all - (fun g -> List.exists (pf_conv_x gl g) (collect_new_goals c)) new_goals) l - -(* given the array of lists [| l1 ; ... ; ln |] it returns the list of arrays - [ c1 ; ... ; cn ] that is the cartesian product of the sets l1, ..., ln *) -let cartesian_product gl a = - let rec aux = - function - [] -> assert false - | [he] -> List.map (fun e -> [e]) he - | he::tl -> - let tl' = aux tl in - List.flatten - (List.map (function e -> List.map (function l -> e :: l) tl') he) - in - List.map Array.of_list - (aux (List.map (elim_duplicates gl identity) (Array.to_list a))) - -let mark_occur gl ~new_goals t in_c input_relation input_direction = - let rec aux output_relation output_directions in_c = - if eq_constr t in_c then - if List.mem input_direction output_directions - && subrelation gl input_relation output_relation then - [ToReplace] - else [] - else - match kind_of_term in_c with - | App (c,al) -> - let mors_and_cs_and_als = - let mors_and_cs_and_als = - let morphism_table_find c = - try morphism_table_find c with Not_found -> [] in - let rec aux acc = - function - [] -> - let c' = mkApp (c, Array.of_list acc) in - let al' = [||] in - List.map (fun m -> m,c',al') (morphism_table_find c') - | (he::tl) as l -> - let c' = mkApp (c, Array.of_list acc) in - let al' = Array.of_list l in - let acc' = acc @ [he] in - (List.map (fun m -> m,c',al') (morphism_table_find c')) @ - (aux acc' tl) - in - aux [] (Array.to_list al) in - let mors_and_cs_and_als = - List.map - (function (m,c,al) -> - relation_morphism_of_constr_morphism m, c, al) - mors_and_cs_and_als in - let mors_and_cs_and_als = - List.fold_left - (fun l (m,c,al) -> - try (unify_morphism_with_arguments gl (c,al) m t) :: l - with Impossible -> l - ) [] mors_and_cs_and_als - in - List.filter - (fun (mor,_,_) -> subrelation gl mor.output output_relation) - mors_and_cs_and_als - in - (* First we look for well typed morphisms *) - let res_mors = - List.fold_left - (fun res (mor,c,al) -> - let a = - let arguments = Array.of_list mor.args in - let apply_variance_to_direction = - function - None -> [Left2Right;Right2Left] - | Some true -> output_directions - | Some false -> List.map opposite_direction output_directions - in - Util.array_map2 - (fun a (variance,relation) -> - (aux relation (apply_variance_to_direction variance) a) - ) al arguments - in - let a' = cartesian_product gl a in - List.flatten (List.map (fun output_direction -> - (List.map - (function a -> - if not (get_mark a) then - ToKeep (in_c,output_relation,output_direction) - else - MApp (c,ACMorphism mor,a,output_direction)) a')) - output_directions) @ res - ) [] mors_and_cs_and_als in - (* Then we look for well typed functions *) - let res_functions = - (* the tactic works only if the function type is - made of non-dependent products only. However, here we - can cheat a bit by partially instantiating c to match - the requirement when the arguments to be replaced are - bound by non-dependent products only. *) - let typeofc = Tacmach.pf_type_of gl c in - let typ = nf_betaiota typeofc in - let rec find_non_dependent_function env c c_args_rev typ f_args_rev - a_rev - = - function - [] -> - if a_rev = [] then - List.map (fun output_direction -> - ToKeep (in_c,output_relation,output_direction)) - output_directions - else - let a' = - cartesian_product gl (Array.of_list (List.rev a_rev)) - in - List.fold_left - (fun res a -> - if not (get_mark a) then - List.map (fun output_direction -> - (ToKeep (in_c,output_relation,output_direction))) - output_directions @ res - else - let err = - match output_relation with - Leibniz (Some typ') when pf_conv_x gl typ typ' -> - false - | Leibniz None -> assert false - | _ when output_relation = Lazy.force coq_iff_relation - -> false - | _ -> true - in - if err then res - else - let mor = - ACFunction{f_args=List.rev f_args_rev;f_output=typ} in - let func = beta_expand c c_args_rev in - List.map (fun output_direction -> - (MApp (func,mor,a,output_direction))) - output_directions @ res - ) [] a' - | (he::tl) -> - let typnf = Reduction.whd_betadeltaiota env typ in - match kind_of_term typnf with - | Prod (name,s,t) -> - let env' = push_rel (name,None,s) env in - let he = - (aux (Leibniz (Some s)) [Left2Right;Right2Left] he) in - if he = [] then [] - else - let he0 = List.hd he in - begin - match noccurn 1 t, he0 with - _, ToKeep (arg,_,_) -> - (* invariant: if he0 = ToKeep (t,_,_) then every - element in he is = ToKeep (t,_,_) *) - assert - (List.for_all - (function - ToKeep(arg',_,_) when pf_conv_x gl arg arg' -> - true - | _ -> false) he) ; - (* generic product, to keep *) - find_non_dependent_function - env' c ((Toapply arg)::c_args_rev) - (subst1 arg t) f_args_rev a_rev tl - | true, _ -> - (* non-dependent product, to replace *) - find_non_dependent_function - env' c ((Toexpand (name,s))::c_args_rev) - (lift 1 t) (s::f_args_rev) (he::a_rev) tl - | false, _ -> - (* dependent product, to replace *) - (* This limitation is due to the reflexive - implementation and it is hard to lift *) - errorlabstrm "Setoid_replace" - (str "Cannot rewrite in the argument of a " ++ - str "dependent product. If you need this " ++ - str "feature, please report to the author.") - end - | _ -> assert false - in - find_non_dependent_function (Tacmach.pf_env gl) c [] typ [] [] - (Array.to_list al) - in - elim_duplicates gl identity (res_functions @ res_mors) - | Prod (_, c1, c2) -> - if (dependent (mkRel 1) c2) - then - if (occur_term t c2) - then errorlabstrm "Setoid_replace" - (str "Cannot rewrite in the type of a variable bound " ++ - str "in a dependent product.") - else - List.map (fun output_direction -> - ToKeep (in_c,output_relation,output_direction)) - output_directions - else - let typeofc1 = Tacmach.pf_type_of gl c1 in - if not (Tacmach.pf_conv_x gl typeofc1 mkProp) then - (* to avoid this error we should introduce an impl relation - whose first argument is Type instead of Prop. However, - the type of the new impl would be Type -> Prop -> Prop - that is no longer a Relation_Definitions.relation. Thus - the Coq part of the tactic should be heavily modified. *) - errorlabstrm "Setoid_replace" - (str "Rewriting in a product A -> B is possible only when A " ++ - str "is a proposition (i.e. A is of type Prop). The type " ++ - pr_lconstr c1 ++ str " has type " ++ pr_lconstr typeofc1 ++ - str " that is not convertible to Prop.") - else - aux output_relation output_directions - (mkApp ((Lazy.force coq_impl), - [| c1 ; subst1 (mkRel 1 (*dummy*)) c2 |])) - | _ -> - if occur_term t in_c then - errorlabstrm "Setoid_replace" - (str "Trying to replace " ++ pr_lconstr t ++ str " in " ++ pr_lconstr in_c ++ - str " that is not an applicative context.") - else - List.map (fun output_direction -> - ToKeep (in_c,output_relation,output_direction)) - output_directions - in - let aux2 output_relation output_direction = - List.map - (fun res -> output_relation,output_direction,res) - (aux output_relation [output_direction] in_c) in - let res = - (aux2 (Lazy.force coq_iff_relation) Right2Left) @ - (* [Left2Right] is the case of a prop of signature A ++> iff or B --> iff *) - (aux2 (Lazy.force coq_iff_relation) Left2Right) @ - (aux2 (Lazy.force coq_impl_relation) Right2Left) in - let res = elim_duplicates gl (function (_,_,t) -> t) res in - let res' = filter_superset_of_new_goals gl new_goals res in - match res' with - [] when res = [] -> - errorlabstrm "Setoid_rewrite" - (strbrk "Either the term " ++ pr_lconstr t ++ strbrk " that must be " ++ - strbrk "rewritten occurs in a covariant position or the goal is not" ++ - strbrk " made of morphism applications only. You can replace only " ++ - strbrk "occurrences that are in a contravariant position and such " ++ - strbrk "that the context obtained by abstracting them is made of " ++ - strbrk "morphism applications only.") - | [] -> - errorlabstrm "Setoid_rewrite" - (str "No generated set of side conditions is a superset of those " ++ - str "requested by the user. The generated sets of side conditions " ++ - str "are: " ++ - pr_fnl () ++ - prlist_with_sepi pr_fnl - (fun i (_,_,mc) -> pr_new_goals i mc) res) - | [he] -> he - | he::_ -> - Flags.if_warn msg_warning - (strbrk "The application of the tactic is subject to one of " ++ - strbrk "the following set of side conditions that the user needs " ++ - strbrk "to prove:" ++ - pr_fnl () ++ - prlist_with_sepi pr_fnl - (fun i (_,_,mc) -> pr_new_goals i mc) res' ++ pr_fnl () ++ - strbrk "The first set is randomly chosen. Use the syntax " ++ - strbrk "\"setoid_rewrite ... generate side conditions ...\" to choose " ++ - strbrk "a different set.") ; - he - -let cic_morphism_context_list_of_list hole_relation hole_direction out_direction -= - let check = - function - (None,dir,dir') -> - mkApp ((Lazy.force coq_MSNone), [| dir ; dir' |]) - | (Some true,dir,dir') -> - assert (dir = dir'); - mkApp ((Lazy.force coq_MSCovariant), [| dir |]) - | (Some false,dir,dir') -> - assert (dir <> dir'); - mkApp ((Lazy.force coq_MSContravariant), [| dir |]) in - let rec aux = - function - [] -> assert false - | [(variance,out),(value,direction)] -> - mkApp ((Lazy.force coq_singl), [| Lazy.force coq_Argument_Class ; out |]), - mkApp ((Lazy.force coq_fcl_singl), - [| hole_relation; hole_direction ; out ; - direction ; out_direction ; - check (variance,direction,out_direction) ; value |]) - | ((variance,out),(value,direction))::tl -> - let outtl, valuetl = aux tl in - mkApp ((Lazy.force coq_cons), - [| Lazy.force coq_Argument_Class ; out ; outtl |]), - mkApp ((Lazy.force coq_fcl_cons), - [| hole_relation ; hole_direction ; out ; outtl ; - direction ; out_direction ; - check (variance,direction,out_direction) ; - value ; valuetl |]) - in aux - -let rec cic_type_nelist_of_list = - function - [] -> assert false - | [value] -> - mkApp ((Lazy.force coq_singl), [| mkType (Termops.new_univ ()) ; value |]) - | value::tl -> - mkApp ((Lazy.force coq_cons), - [| mkType (Termops.new_univ ()); value; cic_type_nelist_of_list tl |]) - -let syntactic_but_representation_of_marked_but hole_relation hole_direction = - let rec aux out (rel_out,precise_out,is_reflexive) = - function - MApp (f, m, args, direction) -> - let direction = cic_direction_of_direction direction in - let morphism_theory, relations = - match m with - ACMorphism { args = args ; morphism_theory = morphism_theory } -> - morphism_theory,args - | ACFunction { f_args = f_args ; f_output = f_output } -> - let mt = - if eq_constr out (cic_relation_class_of_relation_class - (Lazy.force coq_iff_relation)) - then - mkApp ((Lazy.force coq_morphism_theory_of_predicate), - [| cic_type_nelist_of_list f_args; f|]) - else - mkApp ((Lazy.force coq_morphism_theory_of_function), - [| cic_type_nelist_of_list f_args; f_output; f|]) - in - mt,List.map (fun x -> None,Leibniz (Some x)) f_args in - let cic_relations = - List.map - (fun (variance,r) -> - variance, - r, - cic_relation_class_of_relation_class r, - cic_precise_relation_class_of_relation_class r - ) relations in - let cic_args_relations,argst = - cic_morphism_context_list_of_list hole_relation hole_direction direction - (List.map2 - (fun (variance,trel,t,precise_t) v -> - (variance,cic_argument_class_of_argument_class (variance,trel)), - (aux t precise_t v, - direction_of_constr_with_marks hole_direction v) - ) cic_relations (Array.to_list args)) - in - mkApp ((Lazy.force coq_App), - [|hole_relation ; hole_direction ; - cic_args_relations ; out ; direction ; - morphism_theory ; argst|]) - | ToReplace -> - mkApp ((Lazy.force coq_ToReplace), [| hole_relation ; hole_direction |]) - | ToKeep (c,_,direction) -> - let direction = cic_direction_of_direction direction in - if is_reflexive then - mkApp ((Lazy.force coq_ToKeep), - [| hole_relation ; hole_direction ; precise_out ; direction ; c |]) - else - let c_is_proper = - let typ = mkApp (rel_out, [| c ; c |]) in - mkCast (Evarutil.mk_new_meta (),DEFAULTcast, typ) - in - mkApp ((Lazy.force coq_ProperElementToKeep), - [| hole_relation ; hole_direction; precise_out ; - direction; c ; c_is_proper |]) - in aux - -let apply_coq_setoid_rewrite hole_relation prop_relation c1 c2 (direction,h) - prop_direction m -= - let hole_relation = cic_relation_class_of_relation_class hole_relation in - let hyp,hole_direction = h,cic_direction_of_direction direction in - let cic_prop_relation = cic_relation_class_of_relation_class prop_relation in - let precise_prop_relation = - cic_precise_relation_class_of_relation_class prop_relation - in - mkApp ((Lazy.force coq_setoid_rewrite), - [| hole_relation ; hole_direction ; cic_prop_relation ; - prop_direction ; c1 ; c2 ; - syntactic_but_representation_of_marked_but hole_relation hole_direction - cic_prop_relation precise_prop_relation m ; hyp |]) - -let check_evar_map_of_evars_defs evd = - let metas = Evd.meta_list evd in - let check_freemetas_is_empty rebus = - Evd.Metaset.iter - (fun m -> - if Evd.meta_defined evd m then () else - raise (Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m]))) - in - List.iter - (fun (_,binding) -> - match binding with - Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> - check_freemetas_is_empty rebus freemetas - | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_), - {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> - check_freemetas_is_empty rebus1 freemetas1 ; - check_freemetas_is_empty rebus2 freemetas2 - ) metas - -(* For a correct meta-aware "rewrite in", we split unification - apart from the actual rewriting (Pierre L, 05/04/06) *) - -(* [unification_rewrite] searchs a match for [c1] in [but] and then - returns the modified objects (in particular [c1] and [c2]) *) - -let rewrite_unif_flags = { - modulo_conv_on_closed_terms = None; - use_metas_eagerly = true; - modulo_delta = empty_transparent_state; -} - -let rewrite2_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly = true; - modulo_delta = empty_transparent_state; -} - -let unification_rewrite c1 c2 cl but gl = - let (env',c1) = - try - (* ~flags:(false,true) to allow to mark occurences that must not be - rewritten simply by replacing them with let-defined definitions - in the context *) - w_unify_to_subterm ~flags:rewrite_unif_flags (pf_env gl) (c1,but) cl.evd - with - Pretype_errors.PretypeError _ -> - (* ~flags:(true,true) to make Ring work (since it really - exploits conversion) *) - w_unify_to_subterm ~flags:rewrite2_unif_flags - (pf_env gl) (c1,but) cl.evd - in - let cl' = {cl with evd = env' } in - let c2 = Clenv.clenv_nf_meta cl' c2 in - check_evar_map_of_evars_defs env' ; - env',Clenv.clenv_value cl', c1, c2 - -(* no unification is performed in this function. [sigma] is the - substitution obtained from an earlier unification. *) - -let relation_rewrite_no_unif c1 c2 hyp ~new_goals sigma gl = - let but = pf_concl gl in - try - let input_relation = - relation_class_that_matches_a_constr "Setoid_rewrite" - new_goals (Typing.mtype_of (pf_env gl) sigma (snd hyp)) in - let output_relation,output_direction,marked_but = - mark_occur gl ~new_goals c1 but input_relation (fst hyp) in - let cic_output_direction = cic_direction_of_direction output_direction in - let if_output_relation_is_iff gl = - let th = - apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp - cic_output_direction marked_but - in - let new_but = Termops.replace_term c1 c2 but in - let hyp1,hyp2,proj = - match output_direction with - Right2Left -> new_but, but, Lazy.force coq_proj1 - | Left2Right -> but, new_but, Lazy.force coq_proj2 - in - let impl1 = mkProd (Anonymous, hyp2, lift 1 hyp1) in - let impl2 = mkProd (Anonymous, hyp1, lift 1 hyp2) in - let th' = mkApp (proj, [|impl2; impl1; th|]) in - Tactics.refine - (mkApp (th',[|mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)|])) - gl in - let if_output_relation_is_if gl = - let th = - apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp - cic_output_direction marked_but - in - let new_but = Termops.replace_term c1 c2 but in - Tactics.refine - (mkApp (th, [|mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)|])) - gl in - if output_relation = (Lazy.force coq_iff_relation) then - if_output_relation_is_iff gl - else - if_output_relation_is_if gl - with - Optimize -> - !general_rewrite (fst hyp = Left2Right) all_occurrences (snd hyp) gl - -let relation_rewrite c1 c2 (input_direction,cl) ~new_goals gl = - let (sigma,cl,c1,c2) = unification_rewrite c1 c2 cl (pf_concl gl) gl in - relation_rewrite_no_unif c1 c2 (input_direction,cl) ~new_goals sigma gl - -let analyse_hypothesis gl c = - let ctype = pf_type_of gl c in - let eqclause = Clenv.make_clenv_binding gl (c,ctype) Rawterm.NoBindings in - let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in - let rec split_last_two = function - | [c1;c2] -> [],(c1, c2) - | x::y::z -> - let l,res = split_last_two (y::z) in x::l, res - | _ -> error "The term provided is not an equivalence" in - let others,(c1,c2) = split_last_two args in - eqclause,mkApp (equiv, Array.of_list others),c1,c2 - -let general_s_rewrite lft2rgt occs c ~new_goals gl = - if occs <> all_occurrences then - warning "Rewriting at selected occurrences not supported"; - let eqclause,_,c1,c2 = analyse_hypothesis gl c in - if lft2rgt then - relation_rewrite c1 c2 (Left2Right,eqclause) ~new_goals gl - else - relation_rewrite c2 c1 (Right2Left,eqclause) ~new_goals gl - -let relation_rewrite_in id c1 c2 (direction,eqclause) ~new_goals gl = - let hyp = pf_type_of gl (mkVar id) in - (* first, we find a match for c1 in the hyp *) - let (sigma,cl,c1,c2) = unification_rewrite c1 c2 eqclause hyp gl in - (* since we will actually rewrite in the opposite direction, we also need - to replace every occurrence of c2 (resp. c1) in hyp with something that - is convertible but not syntactically equal. To this aim we introduce a - let-in and then we will use the intro tactic to get rid of it. - Quite tricky to do properly since c1 can occur in c2 or vice-versa ! *) - let mangled_new_hyp = - let hyp = lift 2 hyp in - (* first, we backup every occurences of c1 in newly allocated (Rel 1) *) - let hyp = Termops.replace_term (lift 2 c1) (mkRel 1) hyp in - (* then, we factorize every occurences of c2 into (Rel 2) *) - let hyp = Termops.replace_term (lift 2 c2) (mkRel 2) hyp in - (* Now we substitute (Rel 1) (i.e. c1) for c2 *) - let hyp = subst1 (lift 1 c2) hyp in - (* Since subst1 has killed Rel 1 and decreased the other Rels, - Rel 1 is now coding for c2, we can build the let-in factorizing c2 *) - mkLetIn (Anonymous,c2,pf_type_of gl c2,hyp) - in - let new_hyp = Termops.replace_term c1 c2 hyp in - let oppdir = opposite_direction direction in - cut_replacing id new_hyp - (tclTHENLAST - (tclTHEN (change_in_concl None mangled_new_hyp) - (tclTHEN intro - (relation_rewrite_no_unif c2 c1 (oppdir,cl) ~new_goals sigma)))) - gl - -let general_s_rewrite_in id lft2rgt occs c ~new_goals gl = - if occs <> all_occurrences then - warning "Rewriting at selected occurrences not supported"; - let eqclause,_,c1,c2 = analyse_hypothesis gl c in - if lft2rgt then - relation_rewrite_in id c1 c2 (Left2Right,eqclause) ~new_goals gl - else - relation_rewrite_in id c2 c1 (Right2Left,eqclause) ~new_goals gl - - -(* - [general_setoid_replace rewrite_tac try_prove_eq_tac_opt relation c1 c2 ~new_goals ] - common part of [setoid_replace] and [setoid_replace_in] (distinction is done using rewrite_tac). - - Algorith sketch: - 1- find the (setoid) relation [rel] between [c1] and [c2] using [relation] - 2- assert [H:rel c2 c1] - 3- replace [c1] with [c2] using [rewrite_tac] (should be [general_s_rewrite] if we want to replace in the - goal, and [general_s_rewrite_in id] if we want to replace in the hypothesis [id]). Possibly generate - new_goals if asked (cf general_s_rewrite) - 4- if [try_prove_eq_tac_opt] is [Some tac] try to complete [rel c2 c1] using tac and do nothing if - [try_prove_eq_tac_opt] is [None] -*) -let general_setoid_replace rewrite_tac try_prove_eq_tac_opt relation c1 c2 ~new_goals gl = - let try_prove_eq_tac = - match try_prove_eq_tac_opt with - | None -> Tacticals.tclIDTAC - | Some tac -> Tacticals.tclTRY (Tacticals.tclCOMPLETE tac ) - in - try - let carrier,args = decompose_app (pf_type_of gl c1) in - let relation = - match relation with - Some rel -> - (try - match find_relation_class rel with - Relation sa -> if not (eq_constr carrier sa.rel_a) then - errorlabstrm "Setoid_rewrite" - (str "the carrier of " ++ pr_lconstr rel ++ - str " does not match the type of " ++ pr_lconstr c1); - sa - | Leibniz _ -> raise Optimize - with - Not_found -> - errorlabstrm "Setoid_rewrite" - (pr_lconstr rel ++ str " is not a registered relation.")) - | None -> - match default_relation_for_carrier (pf_type_of gl c1) with - Relation sa -> sa - | Leibniz _ -> raise Optimize - in - let eq_left_to_right = mkApp (relation.rel_aeq, Array.of_list (List.append args [ c1 ; c2 ])) in - let eq_right_to_left = mkApp (relation.rel_aeq, Array.of_list (List.append args [ c2 ; c1 ])) in - let replace dir eq = - tclTHENS (assert_tac false Anonymous eq) - [onLastHyp (fun id -> - tclTHEN - (rewrite_tac dir all_occurrences (mkVar id) ~new_goals) - (clear [id])); - try_prove_eq_tac] - in - tclORELSE - (replace true eq_left_to_right) (replace false eq_right_to_left) gl - with - Optimize -> (* (!replace tac_opt c1 c2) gl *) - let eq = mkApp (Lazy.force coq_eq, [| pf_type_of gl c1;c2 ; c1 |]) in - tclTHENS (assert_tac false Anonymous eq) - [onLastHyp (fun id -> - tclTHEN - (rewrite_tac false all_occurrences (mkVar id) ~new_goals) - (clear [id])); - try_prove_eq_tac] gl - -let setoid_replace = general_setoid_replace general_s_rewrite -let setoid_replace_in tac_opt id relation c1 c2 ~new_goals gl = - general_setoid_replace (general_s_rewrite_in id) tac_opt relation c1 c2 ~new_goals gl - -(* [setoid_]{reflexivity,symmetry,transitivity} tactics *) - -let setoid_reflexivity gl = - try - let relation_class = - relation_class_that_matches_a_constr "Setoid_reflexivity" - [] (pf_concl gl) in - match relation_class with - Leibniz _ -> assert false (* since [] is empty *) - | Relation rel -> - match rel.rel_refl with - None -> - errorlabstrm "Setoid_reflexivity" - (str "The relation " ++ prrelation rel ++ str " is not reflexive.") - | Some refl -> apply refl gl - with - Optimize -> reflexivity_red true gl - -let setoid_symmetry gl = - try - let relation_class = - relation_class_that_matches_a_constr "Setoid_symmetry" - [] (pf_concl gl) in - match relation_class with - Leibniz _ -> assert false (* since [] is empty *) - | Relation rel -> - match rel.rel_sym with - None -> - errorlabstrm "Setoid_symmetry" - (str "The relation " ++ prrelation rel ++ str " is not symmetric.") - | Some sym -> apply sym gl - with - Optimize -> symmetry_red true gl - -let setoid_symmetry_in id gl = - let ctype = pf_type_of gl (mkVar id) in - let binders,concl = Sign.decompose_prod_assum ctype in - let (equiv, args) = decompose_app concl in - let rec split_last_two = function - | [c1;c2] -> [],(c1, c2) - | x::y::z -> let l,res = split_last_two (y::z) in x::l, res - | _ -> error "The term provided is not an equivalence" - in - let others,(c1,c2) = split_last_two args in - let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in - let new_hyp' = mkApp (he, [| c2 ; c1 |]) in - let new_hyp = it_mkProd_or_LetIn new_hyp' binders in - tclTHENS (cut new_hyp) - [ intro_replacing id; - tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); assumption ] ] - gl - -let setoid_transitivity c gl = - try - let relation_class = - relation_class_that_matches_a_constr "Setoid_transitivity" - [] (pf_concl gl) in - match relation_class with - Leibniz _ -> assert false (* since [] is empty *) - | Relation rel -> - let ctyp = pf_type_of gl c in - let rel' = unify_relation_carrier_with_type (pf_env gl) rel ctyp in - match rel'.rel_trans with - None -> - errorlabstrm "Setoid_transitivity" - (str "The relation " ++ prrelation rel ++ str " is not transitive.") - | Some trans -> - let transty = nf_betaiota (pf_type_of gl trans) in - let argsrev, _ = - Reductionops.decomp_n_prod (pf_env gl) Evd.empty 2 transty in - let binder = - match List.rev argsrev with - _::(Name n2,None,_)::_ -> Rawterm.NamedHyp n2 - | _ -> assert false - in - apply_with_bindings - (trans, Rawterm.ExplicitBindings [ dummy_loc, binder, c ]) gl - with - Optimize -> transitivity_red true c gl -;; - diff --git a/tactics/setoid_replace.mli b/tactics/setoid_replace.mli deleted file mode 100644 index 6d736a0a..00000000 --- a/tactics/setoid_replace.mli +++ /dev/null @@ -1,85 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds - -val register_replace : (tactic option -> constr -> constr -> tactic) -> unit -val register_general_rewrite : (bool -> occurrences -> constr -> tactic) -> unit - -val print_setoids : unit -> unit - -val equiv_list : unit -> constr list -val default_relation_for_carrier : - ?filter:(relation -> bool) -> types -> relation relation_class -(* [default_morphism] raises [Not_found] *) -val default_morphism : - ?filter:(constr morphism -> bool) -> constr -> relation morphism - -val setoid_replace : - tactic option -> constr option -> constr -> constr -> new_goals:constr list -> tactic -val setoid_replace_in : - tactic option -> - identifier -> constr option -> constr -> constr -> new_goals:constr list -> - tactic - -val general_s_rewrite : - bool -> occurrences -> constr -> new_goals:constr list -> tactic -val general_s_rewrite_in : - identifier -> bool -> occurrences -> constr -> new_goals:constr list -> tactic - -val setoid_reflexivity : tactic -val setoid_symmetry : tactic -val setoid_symmetry_in : identifier -> tactic -val setoid_transitivity : constr -> tactic - -val add_relation : - Names.identifier -> constr_expr -> constr_expr -> constr_expr option -> - constr_expr option -> constr_expr option -> unit - -val add_setoid : - Names.identifier -> constr_expr -> constr_expr -> constr_expr -> unit - -val new_named_morphism : - Names.identifier -> constr_expr -> morphism_signature option -> unit - -val relation_table_find : constr -> relation -val relation_table_mem : constr -> bool - -val prrelation : relation -> Pp.std_ppcmds diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 3f8eb0ca..d9026a6d 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacinterp.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: tacinterp.ml 11745 2009-01-04 18:43:08Z herbelin $ *) open Constrintern open Closure @@ -96,7 +96,7 @@ let catch_error call_trace tac g = let (loc',c),tail = list_sep_last call_trace in let loc,e' = match e with Stdpp.Exc_located(loc,e) -> loc,e | _ ->dloc,e in if tail = [] then - let loc = if loc' = dloc then loc else loc' in + let loc = if loc = dloc then loc' else loc in raise (Stdpp.Exc_located(loc,e')) else raise (Stdpp.Exc_located(loc',LtacLocated((c,tail,loc),e'))) @@ -135,9 +135,6 @@ let rec pr_value env = function | VList (a::_) -> str "a list (first element is " ++ pr_value env a ++ str")" -(* Transforms a named_context into a (string * constr) list *) -let make_hyps = List.map (fun (id,_,typ) -> (id, typ)) - (* Transforms an id into a constr if possible, or fails *) let constr_of_id env id = construct_reference (Environ.named_context env) id @@ -375,15 +372,15 @@ let intern_or_var ist = function let loc_of_by_notation f = function | AN c -> f c - | ByNotation (loc,s) -> loc + | ByNotation (loc,s,_) -> loc let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" let intern_inductive_or_by_notation = function | AN r -> Nametab.inductive_of_reference r - | ByNotation (loc,ntn) -> + | ByNotation (loc,ntn,sc) -> destIndRef (Notation.interp_notation_as_global_reference loc - (function IndRef ind -> true | _ -> false) ntn) + (function IndRef ind -> true | _ -> false) ntn sc) let intern_inductive ist = function | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id) @@ -565,10 +562,10 @@ let interp_global_reference r = let intern_evaluable_reference_or_by_notation = function | AN r -> evaluable_of_global_reference (interp_global_reference r) - | ByNotation (loc,ntn) -> + | ByNotation (loc,ntn,sc) -> evaluable_of_global_reference (Notation.interp_notation_as_global_reference loc - (function ConstRef _ | VarRef _ -> true | _ -> false) ntn) + (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) (* Globalizes a reduction expression *) let intern_evaluable ist = function @@ -597,33 +594,34 @@ let intern_red_expr ist = function | Simpl o -> Simpl (Option.map (intern_constr_with_occurrences ist) o) | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r ) -> r +let intern_in_hyp_as ist lf (id,ipat) = + (intern_hyp_or_metaid ist id, Option.map (intern_intro_pattern lf ist) ipat) + +let intern_hyp_list ist = List.map (intern_hyp_or_metaid ist) let intern_inversion_strength lf ist = function | NonDepInversion (k,idl,ids) -> - NonDepInversion (k,List.map (intern_hyp_or_metaid ist) idl, + NonDepInversion (k,intern_hyp_list ist idl, Option.map (intern_intro_pattern lf ist) ids) | DepInversion (k,copt,ids) -> DepInversion (k, Option.map (intern_constr ist) copt, Option.map (intern_intro_pattern lf ist) ids) | InversionUsing (c,idl) -> - InversionUsing (intern_constr ist c, List.map (intern_hyp_or_metaid ist) idl) + InversionUsing (intern_constr ist c, intern_hyp_list ist idl) (* Interprets an hypothesis name *) let intern_hyp_location ist (((b,occs),id),hl) = - (((b,List.map (intern_or_var ist) occs),intern_hyp ist (skip_metaid id)), hl) - -let interp_constrpattern_gen sigma env ?(as_type=false) ltacvar c = - let c = intern_gen as_type ~allow_patvar:true ~ltacvars:(ltacvar,[]) - sigma env c in - pattern_of_rawconstr c + (((b,List.map (intern_or_var ist) occs),intern_hyp_or_metaid ist id), hl) (* Reads a pattern *) let intern_pattern sigma env ?(as_type=false) lfun = function - | Subterm (ido,pc) -> - let (metas,pat) = interp_constrpattern_gen sigma env lfun pc in - ido, metas, Subterm (ido,pat) + | Subterm (b,ido,pc) -> + let ltacvars = (lfun,[]) in + let (metas,pat) = intern_constr_pattern sigma env ~ltacvars pc in + ido, metas, Subterm (b,ido,pat) | Term pc -> - let (metas,pat) = interp_constrpattern_gen sigma env ~as_type lfun pc in + let ltacvars = (lfun,[]) in + let (metas,pat) = intern_constr_pattern sigma env ~as_type ~ltacvars pc in None, metas, Term pat let intern_constr_may_eval ist = function @@ -658,6 +656,12 @@ let rec intern_match_goal_hyps sigma env lfun = function let lfun, metas2, hyps = intern_match_goal_hyps sigma env lfun tl in let lfun' = name_cons na (Option.List.cons ido lfun) in lfun', metas1@metas2, Hyp (locna,pat)::hyps + | (Def ((_,na) as locna,mv,mp))::tl -> + let ido, metas1, patv = intern_pattern sigma env ~as_type:false lfun mv in + let ido', metas2, patt = intern_pattern sigma env ~as_type:true lfun mp in + let lfun, metas3, hyps = intern_match_goal_hyps sigma env lfun tl in + let lfun' = name_cons na (Option.List.cons ido' (Option.List.cons ido lfun)) in + lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps | [] -> lfun, [], [] (* Utilities *) @@ -690,8 +694,9 @@ let rec intern_atomic lf ist x = | TacExact c -> TacExact (intern_constr ist c) | TacExactNoCheck c -> TacExactNoCheck (intern_constr ist c) | TacVmCastNoCheck c -> TacVmCastNoCheck (intern_constr ist c) - | TacApply (a,ev,cb) -> - TacApply (a,ev,List.map (intern_constr_with_bindings ist) cb) + | TacApply (a,ev,cb,inhyp) -> + TacApply (a,ev,List.map (intern_constr_with_bindings ist) cb, + Option.map (intern_in_hyp_as ist lf) inhyp) | TacElim (ev,cb,cbo) -> TacElim (ev,intern_constr_with_bindings ist cb, Option.map (intern_constr_with_bindings ist) cbo) @@ -709,7 +714,7 @@ let rec intern_atomic lf ist x = | TacCut c -> TacCut (intern_type ist c) | TacAssert (otac,ipat,c) -> TacAssert (Option.map (intern_tactic ist) otac, - intern_intro_pattern lf ist ipat, + Option.map (intern_intro_pattern lf ist) ipat, intern_constr_gen (otac<>None) ist c) | TacGeneralize cl -> TacGeneralize (List.map (fun (c,na) -> @@ -923,9 +928,10 @@ and intern_genarg ist x = (* how to know which names are bound by the intropattern *) in_gen globwit_intro_pattern (intern_intro_pattern lf ist (out_gen rawwit_intro_pattern x)) - | IdentArgType -> + | IdentArgType b -> let lf = ref ([],[]) in - in_gen globwit_ident(intern_ident lf ist (out_gen rawwit_ident x)) + in_gen (globwit_ident_gen b) + (intern_ident lf ist (out_gen (rawwit_ident_gen b) x)) | VarArgType -> in_gen globwit_var (intern_hyp ist (out_gen rawwit_var x)) | RefArgType -> @@ -994,9 +1000,18 @@ let eval_pattern lfun c = instantiate_pattern lvar c let read_pattern lfun = function - | Subterm (ido,pc) -> Subterm (ido,eval_pattern lfun pc) + | Subterm (b,ido,pc) -> Subterm (b,ido,eval_pattern lfun pc) | Term pc -> Term (eval_pattern lfun pc) +let value_of_ident id = VIntroPattern (IntroIdentifier id) + +let extend_values_with_bindings (ln,lm) lfun = + let lnames = List.map (fun (id,id') ->(id,value_of_ident id')) ln in + let lmatch = List.map (fun (id,c) -> (id,VConstr c)) lm in + (* For compatibility, bound variables are visible only if no other + binding of the same name exists *) + lmatch@lfun@lnames + (* Reads the hypotheses of a Match Context rule *) let cons_and_check_name id l = if List.mem id l then @@ -1010,6 +1025,10 @@ let rec read_match_goal_hyps lfun lidh = function let lidh' = name_fold cons_and_check_name na lidh in Hyp (locna,read_pattern lfun mp):: (read_match_goal_hyps lfun lidh' tl) + | (Def ((loc,na) as locna,mv,mp))::tl -> + let lidh' = name_fold cons_and_check_name na lidh in + Def (locna,read_pattern lfun mv, read_pattern lfun mp):: + (read_match_goal_hyps lfun lidh' tl) | [] -> [] (* Reads the rules of a Match Context or a Match *) @@ -1029,45 +1048,79 @@ let is_match_catchable = function | e -> Logic.catchable_exception e (* Verifies if the matched list is coherent with respect to lcm *) -let rec verify_metas_coherence gl lcm = function +(* While non-linear matching is modulo eq_constr in matches, merge of *) +(* different instances of the same metavars is here modulo conversion... *) +let verify_metas_coherence gl (ln1,lcm) (ln,lm) = + let rec aux = function | (num,csr)::tl -> if (List.for_all (fun (a,b) -> a<>num or pf_conv_x gl b csr) lcm) then - (num,csr)::(verify_metas_coherence gl lcm tl) + (num,csr)::aux tl else raise Not_coherent_metas - | [] -> [] + | [] -> lcm in + (ln@ln1,aux lm) (* Tries to match one hypothesis pattern with a list of hypotheses *) -let apply_one_mhyp_context ist env gl lmatch (hypname,pat) (lhyps,nocc) = +let apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps = let get_id_couple id = function | Name idpat -> [idpat,VConstr (mkVar id)] | Anonymous -> [] in - let rec apply_one_mhyp_context_rec nocc = function - | (id,hyp)::tl as hyps -> - (match pat with - | Term t -> - (try - let lmeta = verify_metas_coherence gl lmatch (matches t hyp) in - (get_id_couple id hypname,lmeta,(id,hyp),(tl,0)) - with - | PatternMatchingFailure | Not_coherent_metas -> - apply_one_mhyp_context_rec 0 tl) - | Subterm (ic,t) -> + let match_pat lmatch hyp pat = + match pat with + | Term t -> + let lmeta = extended_matches t hyp in (try - let (lm,ctxt) = match_subterm nocc t hyp in - let lmeta = verify_metas_coherence gl lmatch lm in - ((get_id_couple id hypname)@(give_context ctxt ic), - lmeta,(id,hyp),(hyps,nocc + 1)) - with - | PatternMatchingFailure -> - apply_one_mhyp_context_rec 0 tl - | Not_coherent_metas -> - apply_one_mhyp_context_rec (nocc + 1) hyps)) + let lmeta = verify_metas_coherence gl lmatch lmeta in + ([],lmeta,(fun () -> raise PatternMatchingFailure)) + with + | Not_coherent_metas -> raise PatternMatchingFailure); + | Subterm (b,ic,t) -> + let rec match_next_pattern find_next () = + let (lmeta,ctxt,find_next') = find_next () in + try + let lmeta = verify_metas_coherence gl lmatch lmeta in + (give_context ctxt ic,lmeta,match_next_pattern find_next') + with + | Not_coherent_metas -> match_next_pattern find_next' () in + match_next_pattern(fun () -> match_subterm_gen b t hyp) () in + let rec apply_one_mhyp_context_rec = function + | (id,b,hyp as hd)::tl -> + (match patv with + | None -> + let rec match_next_pattern find_next () = + try + let (ids, lmeta, find_next') = find_next () in + (get_id_couple id hypname@ids, lmeta, hd, + match_next_pattern find_next') + with + | PatternMatchingFailure -> apply_one_mhyp_context_rec tl in + match_next_pattern (fun () -> match_pat lmatch hyp pat) () + | Some patv -> + match b with + | Some body -> + let rec match_next_pattern_in_body next_in_body () = + try + let (ids,lmeta,next_in_body') = next_in_body() in + let rec match_next_pattern_in_typ next_in_typ () = + try + let (ids',lmeta',next_in_typ') = next_in_typ() in + (get_id_couple id hypname@ids@ids', lmeta', hd, + match_next_pattern_in_typ next_in_typ') + with + | PatternMatchingFailure -> + match_next_pattern_in_body next_in_body' () in + match_next_pattern_in_typ + (fun () -> match_pat lmeta hyp pat) () + with PatternMatchingFailure -> apply_one_mhyp_context_rec tl + in + match_next_pattern_in_body + (fun () -> match_pat lmatch body patv) () + | None -> apply_one_mhyp_context_rec tl) | [] -> db_hyp_pattern_failure ist.debug env (hypname,pat); raise PatternMatchingFailure - in - apply_one_mhyp_context_rec nocc lhyps + in + apply_one_mhyp_context_rec lhyps let constr_to_id loc = function | VConstr c when isVar c -> destVar c @@ -1361,7 +1414,7 @@ let solvable_by_tactic env evi (ev,args) src = begin try by (tclCOMPLETE tac); - let _,(const,_,_) = cook_proof ignore in + let _,(const,_,_,_) = cook_proof ignore in delete_current_proof (); const.const_entry_body with e when Logic.catchable_exception e -> delete_current_proof(); @@ -1385,7 +1438,7 @@ let solve_remaining_evars env initial_sigma evd c = Pretype_errors.error_unsolvable_implicit loc env sigma evi src None) | _ -> map_constr proc_rec c in - proc_rec c + proc_rec (Evarutil.nf_isevar !evdref c) let interp_gen kind ist sigma env (c,ce) = let (ltacvars,unbndltacvars as vars) = constr_list ist env in @@ -1413,6 +1466,10 @@ let interp_open_constr ccl ist sigma env cc = let evd,c = interp_gen (OfType ccl) ist sigma env cc in (evars_of evd,c) +let interp_open_type ccl ist sigma env cc = + let evd,c = interp_gen IsType ist sigma env cc in + (evars_of evd,c) + let interp_constr = interp_econstr (OfType None) let interp_type = interp_econstr IsType @@ -1600,6 +1657,9 @@ let rec interp_intro_pattern ist gl = function and interp_or_and_intro_pattern ist gl = List.map (List.map (interp_intro_pattern ist gl)) +let interp_in_hyp_as ist gl (id,ipat) = + (interp_hyp ist gl id,Option.map (interp_intro_pattern ist gl) ipat) + (* Quantified named or numbered hypothesis or hypothesis in context *) (* (as in Inversion) *) let coerce_to_quantified_hypothesis = function @@ -1840,13 +1900,18 @@ and interp_letin ist gl llc u = val_interp ist gl u (* Interprets the Match Context expressions *) -and interp_match_goal ist g lz lr lmr = - let rec apply_goal_sub ist env goal nocc (id,c) csr mt mhyps hyps = - let (lgoal,ctxt) = match_subterm nocc c csr in - let lctxt = give_context ctxt id in +and interp_match_goal ist goal lz lr lmr = + let hyps = pf_hyps goal in + let hyps = if lr then List.rev hyps else hyps in + let concl = pf_concl goal in + let env = pf_env goal in + let rec apply_goal_sub app ist (id,c) csr mt mhyps hyps = + let rec match_next_pattern find_next () = + let (lgoal,ctxt,find_next') = find_next () in + let lctxt = give_context ctxt id in try apply_hyps_context ist env lz goal mt lctxt lgoal mhyps hyps - with e when is_match_catchable e -> - apply_goal_sub ist env goal (nocc + 1) (id,c) csr mt mhyps hyps in + 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_goal ist env goal nrs lex lpt = begin if lex<>[] then db_pattern_rule ist.debug nrs (List.hd lex); @@ -1859,27 +1924,24 @@ and interp_match_goal ist g lz lr lmr = apply_match_goal ist env goal (nrs+1) (List.tl lex) tl end | (Pat (mhyps,mgoal,mt))::tl -> - let hyps = make_hyps (pf_hyps goal) in - let hyps = if lr then List.rev hyps else hyps in - let mhyps = List.rev mhyps (* Sens naturel *) in - let concl = pf_concl goal in - (match mgoal with - | Term mg -> - (try - let lgoal = matches mg concl in - db_matched_concl ist.debug (pf_env goal) concl; - apply_hyps_context ist env lz goal mt [] lgoal mhyps hyps - with e when is_match_catchable e -> - (match e with - | PatternMatchingFailure -> db_matching_failure ist.debug - | Eval_fail s -> db_eval_failure ist.debug s - | _ -> db_logic_failure ist.debug e); - apply_match_goal ist env goal (nrs+1) (List.tl lex) tl) - | Subterm (id,mg) -> - (try apply_goal_sub ist env goal 0 (id,mg) concl mt mhyps hyps - with - | PatternMatchingFailure -> - apply_match_goal ist env goal (nrs+1) (List.tl lex) tl)) + let mhyps = List.rev mhyps (* Sens naturel *) in + (match mgoal with + | Term mg -> + (try + let lmatch = extended_matches mg concl in + db_matched_concl ist.debug env concl; + apply_hyps_context ist env lz goal mt [] lmatch mhyps hyps + with e when is_match_catchable e -> + (match e with + | PatternMatchingFailure -> db_matching_failure ist.debug + | Eval_fail s -> db_eval_failure ist.debug s + | _ -> db_logic_failure ist.debug e); + apply_match_goal ist env goal (nrs+1) (List.tl lex) tl) + | Subterm (b,id,mg) -> + (try apply_goal_sub b ist (id,mg) concl mt mhyps hyps + with + | PatternMatchingFailure -> + apply_match_goal ist env goal (nrs+1) (List.tl lex) tl)) | _ -> errorlabstrm "Tacinterp.apply_match_goal" (v 0 (str "No matching clauses for match goal" ++ @@ -1887,31 +1949,36 @@ and interp_match_goal ist g lz lr lmr = fnl() ++ str "(use \"Set Ltac Debug\" for more info)" else mt()) ++ str".")) end in - let env = pf_env g in - apply_match_goal ist env g 0 lmr + apply_match_goal ist env goal 0 lmr (read_match_rule (fst (constr_list ist env)) lmr) (* Tries to match the hypotheses in a Match Context *) and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps = - let rec apply_hyps_context_rec lfun lmatch lhyps_rest current = function - | Hyp ((_,hypname),mhyp)::tl as mhyps -> - let (lids,lm,hyp_match,next) = - apply_one_mhyp_context ist env goal lmatch (hypname,mhyp) current in - db_matched_hyp ist.debug (pf_env goal) hyp_match hypname; - begin + let rec apply_hyps_context_rec lfun lmatch lhyps_rest = function + | hyp_pat::tl -> + let (hypname, _, _ as hyp_pat) = + match hyp_pat with + | Hyp ((_,hypname),mhyp) -> hypname, None, mhyp + | Def ((_,hypname),mbod,mhyp) -> hypname, Some mbod, mhyp + in + let rec match_next_pattern find_next = + let (lids,lm,hyp_match,find_next') = find_next () in + db_matched_hyp ist.debug (pf_env goal) hyp_match hypname; try - let nextlhyps = list_except hyp_match lhyps_rest in - apply_hyps_context_rec (lfun@lids) (lmatch@lm) nextlhyps - (nextlhyps,0) tl + let id_match = pi1 hyp_match in + let nextlhyps = list_remove_assoc_in_triple id_match lhyps_rest in + apply_hyps_context_rec (lfun@lids) lm nextlhyps tl with e when is_match_catchable e -> - apply_hyps_context_rec lfun lmatch lhyps_rest next mhyps - end + match_next_pattern find_next' in + let init_match_pattern () = + apply_one_mhyp_context ist env goal lmatch hyp_pat lhyps_rest in + match_next_pattern init_match_pattern | [] -> - let lmatch = List.map (fun (id,c) -> (id,VConstr c)) lmatch in + let lfun = extend_values_with_bindings lmatch (lfun@ist.lfun) in db_mc_pattern_success ist.debug; - eval_with_fail {ist with lfun=lmatch@lfun@ist.lfun} lz goal mt + eval_with_fail {ist with lfun=lfun} lz goal mt in - apply_hyps_context_rec lctxt lgmatch hyps (hyps,0) mhyps + apply_hyps_context_rec lctxt lgmatch hyps mhyps and interp_external loc ist gl com req la = let f ch = extern_request ch req gl la in @@ -1933,9 +2000,9 @@ and interp_genarg ist gl x = | IntroPatternArgType -> in_gen wit_intro_pattern (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)) - | IdentArgType -> - in_gen wit_ident - (interp_fresh_ident ist gl (out_gen globwit_ident x)) + | IdentArgType b -> + in_gen (wit_ident_gen b) + (interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x)) | VarArgType -> in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x)) | RefArgType -> @@ -2003,30 +2070,31 @@ and interp_genarg_var_list1 ist gl x = (* Interprets the Match expressions *) and interp_match ist g lz constr lmr = - let rec apply_match_subterm ist nocc (id,c) csr mt = - let (lm,ctxt) = match_subterm nocc c csr in - let lctxt = give_context ctxt id in - let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in - try eval_with_fail {ist with lfun=lm@lctxt@ist.lfun} lz g mt - with e when is_match_catchable e -> - apply_match_subterm ist (nocc + 1) (id,c) csr mt - in + let rec apply_match_subterm app ist (id,c) csr mt = + let rec match_next_pattern find_next () = + let (lmatch,ctxt,find_next') = find_next () in + let lctxt = give_context ctxt id in + let lfun = extend_values_with_bindings lmatch (lctxt@ist.lfun) in + try eval_with_fail {ist with lfun=lfun} lz g mt + 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 | (All t)::_ -> (try eval_with_fail ist lz g t with e when is_match_catchable e -> apply_match ist csr []) | (Pat ([],Term c,mt))::tl -> (try - let lm = - try matches c csr + let lmatch = + try extended_matches c csr with e -> debugging_exception_step ist false e (fun () -> str "matching with pattern" ++ fnl () ++ pr_constr_pattern_env (pf_env g) c); raise e in try - let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in - eval_with_fail { ist with lfun=lm@ist.lfun } lz g mt + let lfun = extend_values_with_bindings lmatch ist.lfun in + eval_with_fail { ist with lfun=lfun } lz g mt with e -> debugging_exception_step ist false e (fun () -> str "rule body for pattern" ++ @@ -2036,8 +2104,8 @@ and interp_match ist g lz constr lmr = debugging_step ist (fun () -> str "switching to the next rule"); apply_match ist csr tl) - | (Pat ([],Subterm (id,c),mt))::tl -> - (try apply_match_subterm ist 0 (id,c) csr mt + | (Pat ([],Subterm (b,id,c),mt))::tl -> + (try apply_match_subterm b ist (id,c) csr mt with PatternMatchingFailure -> apply_match ist csr tl) | _ -> errorlabstrm "Tacinterp.apply_match" (str @@ -2119,8 +2187,11 @@ and interp_atomic ist gl = function | 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) - | TacApply (a,ev,cb) -> - h_apply a ev (List.map (interp_constr_with_bindings ist gl) cb) + | TacApply (a,ev,cb,None) -> + h_apply a ev (List.map (interp_open_constr_with_bindings ist gl) cb) + | TacApply (a,ev,cb,Some cl) -> + h_apply_in a ev (List.map (interp_open_constr_with_bindings ist gl) cb) + (interp_in_hyp_as ist gl cl) | TacElim (ev,cb,cbo) -> h_elim ev (interp_constr_with_bindings ist gl cb) (Option.map (interp_constr_with_bindings ist gl) cbo) @@ -2137,10 +2208,10 @@ and interp_atomic ist gl = function h_mutual_cofix b (interp_fresh_ident ist gl id) (List.map f l) | TacCut c -> h_cut (pf_interp_type ist gl c) | TacAssert (t,ipat,c) -> - let c = (if t=None then pf_interp_constr else pf_interp_type) ist gl c in + let c = (if t=None then interp_constr else interp_type) ist (project gl) (pf_env gl) c in abstract_tactic (TacAssert (t,ipat,inj_open c)) (Tactics.forward (Option.map (interp_tactic ist) t) - (interp_intro_pattern ist gl ipat) c) + (Option.map (interp_intro_pattern ist gl) ipat) c) | TacGeneralize cl -> h_generalize_gen (pf_interp_constr_with_occurrences_and_name_as_list ist gl cl) @@ -2230,7 +2301,7 @@ and interp_atomic ist gl = function (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> Equality.general_multi_multi_rewrite ev - (List.map (fun (b,m,c) -> (b,m,interp_constr_with_bindings ist gl c)) l) + (List.map (fun (b,m,c) -> (b,m,interp_open_constr_with_bindings ist gl c)) l) (interp_clause ist gl cl) (Option.map (interp_tactic ist) by) | TacInversion (DepInversion (k,c,ids),hyp) -> @@ -2263,10 +2334,10 @@ and interp_atomic ist gl = function | IntroPatternArgType -> VIntroPattern (snd (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))) - | IdentArgType -> + | IdentArgType b -> VIntroPattern (IntroIdentifier - (interp_fresh_ident ist gl (out_gen globwit_ident x))) + (interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x))) | VarArgType -> mk_hyp_value ist gl (out_gen globwit_var x) | RefArgType -> @@ -2437,13 +2508,16 @@ let subst_raw_may_eval subst = function | ConstrTerm c -> ConstrTerm (subst_rawconstr subst c) let subst_match_pattern subst = function - | Subterm (ido,pc) -> Subterm (ido,subst_pattern subst pc) + | Subterm (b,ido,pc) -> Subterm (b,ido,subst_pattern subst pc) | Term pc -> Term (subst_pattern subst pc) let rec subst_match_goal_hyps subst = function | Hyp (locs,mp) :: tl -> Hyp (locs,subst_match_pattern subst mp) :: subst_match_goal_hyps subst tl + | Def (locs,mv,mp) :: tl -> + Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp) + :: subst_match_goal_hyps subst tl | [] -> [] let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with @@ -2453,8 +2527,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacExact c -> TacExact (subst_rawconstr subst c) | TacExactNoCheck c -> TacExactNoCheck (subst_rawconstr subst c) | TacVmCastNoCheck c -> TacVmCastNoCheck (subst_rawconstr subst c) - | TacApply (a,ev,cb) -> - TacApply (a,ev,List.map (subst_raw_with_bindings subst) cb) + | TacApply (a,ev,cb,cl) -> + TacApply (a,ev,List.map (subst_raw_with_bindings subst) cb,cl) | TacElim (ev,cb,cbo) -> TacElim (ev,subst_raw_with_bindings subst cb, Option.map (subst_raw_with_bindings subst) cbo) @@ -2611,7 +2685,8 @@ and subst_genarg subst (x:glob_generic_argument) = | PreIdentArgType -> in_gen globwit_pre_ident (out_gen globwit_pre_ident x) | IntroPatternArgType -> in_gen globwit_intro_pattern (out_gen globwit_intro_pattern x) - | IdentArgType -> in_gen globwit_ident (out_gen globwit_ident x) + | IdentArgType b -> + in_gen (globwit_ident_gen b) (out_gen (globwit_ident_gen b) x) | VarArgType -> in_gen globwit_var (out_gen globwit_var x) | RefArgType -> in_gen globwit_ref (subst_global_reference subst diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 928e5914..add57cb5 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tacinterp.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: tacinterp.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) (*i*) open Dyn @@ -48,6 +48,9 @@ and interp_sign = val constr_of_id : Environ.env -> identifier -> constr (* To embed several objects in Coqast.t *) +val tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t +val tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr) + val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr val valueIn : value -> raw_tactic_arg @@ -99,6 +102,10 @@ val intern_tactic : val intern_constr : glob_sign -> constr_expr -> rawconstr_and_expr +val intern_constr_with_bindings : + glob_sign -> constr_expr * constr_expr Rawterm.bindings -> + rawconstr_and_expr * rawconstr_and_expr Rawterm.bindings + val intern_hyp : glob_sign -> identifier Util.located -> identifier Util.located @@ -124,6 +131,9 @@ val interp_tac_gen : (identifier * value) list -> identifier list -> val interp_hyp : interp_sign -> goal sigma -> identifier located -> identifier +val interp_bindings : interp_sign -> goal sigma -> rawconstr_and_expr Rawterm.bindings -> + Evd.open_constr Rawterm.bindings + (* Initial call for interpretation *) val glob_tactic : raw_tactic_expr -> glob_tactic_expr diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 3b13d1a0..28e987fa 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacticals.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: tacticals.ml 11735 2009-01-02 17:22:31Z herbelin $ *) open Pp open Util @@ -41,6 +41,7 @@ open Tacexpr let tclNORMEVAR = tclNORMEVAR let tclIDTAC = tclIDTAC let tclIDTAC_MESSAGE = tclIDTAC_MESSAGE +let tclORELSE0 = tclORELSE0 let tclORELSE = tclORELSE let tclTHEN = tclTHEN let tclTHENLIST = tclTHENLIST @@ -75,7 +76,7 @@ let tclIFTHENTRYELSEMUST = tclIFTHENTRYELSEMUST let unTAC = unTAC (* [rclTHENSEQ [t1;..;tn] is equivalent to t1;..;tn *) -let tclTHENSEQ = List.fold_left tclTHEN tclIDTAC +let tclTHENSEQ = tclTHENLIST (* map_tactical f [x1..xn] = (f x1);(f x2);...(f xn) *) (* tclMAP f [x1..xn] = (f x1);(f x2);...(f xn) *) @@ -88,10 +89,16 @@ let tclNTH_HYP m (tac : constr->tactic) gl = tac (try mkVar(let (id,_,_) = List.nth (pf_hyps gl) (m-1) in id) with Failure _ -> error "No such assumption.") gl +let tclNTH_DECL m tac gl = + tac (try List.nth (pf_hyps gl) (m-1) + with Failure _ -> error "No such assumption.") gl + (* apply a tactic to the last element of the signature *) let tclLAST_HYP = tclNTH_HYP 1 +let tclLAST_DECL = tclNTH_DECL 1 + let tclLAST_NHYPS n tac gl = tac (try list_firstn n (pf_ids_of_hyps gl) with Failure _ -> error "No such assumptions.") gl @@ -206,7 +213,7 @@ let onHyps find tac gl = tac (find gl) gl after id *) let afterHyp id gl = - fst (list_splitby (fun (hyp,_,_) -> hyp = id) (pf_hyps gl)) + fst (list_split_at (fun (hyp,_,_) -> hyp = id) (pf_hyps gl)) (* Create a singleton clause list with the last hypothesis from then context *) @@ -276,6 +283,13 @@ type branch_assumptions = { ba : branch_args; (* the branch args *) assums : named_context} (* the list of assumptions introduced *) +let fix_empty_or_and_pattern nv l = + (* 1- The syntax does not distinguish between "[ ]" for one clause with no + names and "[ ]" for no clause at all *) + (* 2- More generally, we admit "[ ]" for any disjunctive pattern of + arbitrary length *) + if l = [[]] then list_make nv [] else l + let check_or_and_pattern_size loc names n = if List.length names <> n then if n = 1 then @@ -288,10 +302,11 @@ let compute_induction_names n = function | None -> Array.make n [] | Some (loc,IntroOrAndPattern names) -> + let names = fix_empty_or_and_pattern n names in check_or_and_pattern_size loc names n; Array.of_list names - | _ -> - error "Unexpected introduction pattern." + | Some (loc,_) -> + user_err_loc (loc,"",str "Disjunctive/conjunctive introduction pattern expected.") let compute_construtor_signatures isrec (_,k as ity) = let rec analrec c recargs = @@ -313,23 +328,14 @@ let compute_construtor_signatures isrec (_,k as ity) = array_map2 analrec lc lrecargs let elimination_sort_of_goal gl = - match kind_of_term (hnf_type_of gl (pf_concl gl)) with - | Sort s -> - (match s with - | Prop Null -> InProp - | Prop Pos -> InSet - | Type _ -> InType) - | _ -> anomaly "goal should be a type" + pf_apply Retyping.get_sort_family_of gl (pf_concl gl) let elimination_sort_of_hyp id gl = - match kind_of_term (hnf_type_of gl (pf_get_hyp_typ gl id)) with - | Sort s -> - (match s with - | Prop Null -> InProp - | Prop Pos -> InSet - | Type _ -> InType) - | _ -> anomaly "goal should be a type" + pf_apply Retyping.get_sort_family_of gl (pf_get_hyp_typ gl id) +let elimination_sort_of_clause = function + | None -> elimination_sort_of_goal + | Some id -> elimination_sort_of_hyp id (* Find the right elimination suffix corresponding to the sort of the goal *) (* c should be of type A1->.. An->B with B an inductive definition *) diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 6826977b..25a0d897 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tacticals.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: tacticals.mli 11735 2009-01-02 17:22:31Z herbelin $ i*) (*i*) open Pp @@ -28,6 +28,7 @@ open Tacexpr val tclNORMEVAR : tactic val tclIDTAC : tactic val tclIDTAC_MESSAGE : std_ppcmds -> tactic +val tclORELSE0 : tactic -> tactic -> tactic val tclORELSE : tactic -> tactic -> tactic val tclTHEN : tactic -> tactic -> tactic val tclTHENSEQ : tactic list -> tactic @@ -57,8 +58,10 @@ val tclNOTSAMEGOAL : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic val tclNTH_HYP : int -> (constr -> tactic) -> tactic +val tclNTH_DECL : int -> (named_declaration -> tactic) -> tactic val tclMAP : ('a -> tactic) -> 'a list -> tactic val tclLAST_HYP : (constr -> tactic) -> tactic +val tclLAST_DECL : (named_declaration -> tactic) -> tactic val tclLAST_NHYPS : int -> (identifier list -> tactic) -> tactic val tclTRY_sign : (constr -> tactic) -> named_context -> tactic val tclTRY_HYPS : (constr -> tactic) -> tactic @@ -136,6 +139,10 @@ type branch_assumptions = { val check_or_and_pattern_size : Util.loc -> or_and_intro_pattern_expr -> int -> unit +(* Tolerate "[]" to mean a disjunctive pattern of any length *) +val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr -> + or_and_intro_pattern_expr + (* Useful for [as intro_pattern] modifier *) val compute_induction_names : int -> intro_pattern_expr located option -> @@ -143,6 +150,7 @@ val compute_induction_names : val elimination_sort_of_goal : goal sigma -> sorts_family val elimination_sort_of_hyp : identifier -> goal sigma -> sorts_family +val elimination_sort_of_clause : identifier option -> goal sigma -> sorts_family val general_elim_then_using : (inductive -> goal sigma -> constr) -> rec_flag -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b02e84e7..5af5c0d5 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tactics.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: tactics.ml 11745 2009-01-04 18:43:08Z herbelin $ *) open Pp open Util @@ -85,15 +85,6 @@ let dloc = dummy_loc (* General functions *) (****************************************) -(* -let get_pairs_from_bindings = - let pair_from_binding = function - | [(Bindings binds)] -> binds - | _ -> error "not a binding list!" - in - List.map pair_from_binding -*) - let string_of_inductive c = try match kind_of_term c with | Ind ind_sp -> @@ -102,26 +93,16 @@ let string_of_inductive c = | _ -> raise Bound with Bound -> error "Bound head variable." -let rec head_constr_bound t l = - let t = strip_outer_cast(collapse_appl t) in - match kind_of_term t with - | Prod (_,_,c2) -> head_constr_bound c2 l - | LetIn (_,_,_,c2) -> head_constr_bound c2 l - | App (f,args) -> - head_constr_bound f (Array.fold_right (fun a l -> a::l) args l) - | Const _ -> t::l - | Ind _ -> t::l - | Construct _ -> t::l - | Var _ -> t::l - | _ -> raise Bound +let rec head_constr_bound t = + let t = strip_outer_cast t in + let _,ccl = decompose_prod_assum t in + let hd,args = decompose_app ccl in + match kind_of_term hd with + | Const _ | Ind _ | Construct _ | Var _ -> (hd,args) + | _ -> raise Bound let head_constr c = - try head_constr_bound c [] with Bound -> error "Bound head variable." - -(* -let bad_tactic_args s l = - raise (RefinerError (BadTacticArgs (s,l))) -*) + try head_constr_bound c with Bound -> error "Bound head variable." (******************************************) (* Primitive tactics *) @@ -169,6 +150,8 @@ let internal_cut_rev_replace = internal_cut_rev_gen true (* Moving hypotheses *) let move_hyp = Tacmach.move_hyp +let order_hyps = Tacmach.order_hyps + (* Renaming hypotheses *) let rename_hyp = Tacmach.rename_hyp @@ -192,25 +175,28 @@ let cofix = function type tactic_reduction = env -> evar_map -> constr -> constr -(* The following two tactics apply an arbitrary - reduction function either to the conclusion or to a - certain hypothesis *) - -let reduct_in_concl (redfun,sty) gl = - convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty gl - -let reduct_in_hyp redfun ((_,id),where) gl = - let (_,c, ty) = pf_get_hyp gl id in +let pf_reduce_decl redfun where (id,c,ty) gl = let redfun' = pf_reduce redfun gl in match c with | None -> if where = InHypValueOnly then errorlabstrm "" (pr_id id ++ str "has no value."); - convert_hyp_no_check (id,None,redfun' ty) gl + (id,None,redfun' ty) | Some b -> let b' = if where <> InHypTypeOnly then redfun' b else b in let ty' = if where <> InHypValueOnly then redfun' ty else ty in - convert_hyp_no_check (id,Some b',ty') gl + (id,Some b',ty') + +(* The following two tactics apply an arbitrary + reduction function either to the conclusion or to a + certain hypothesis *) + +let reduct_in_concl (redfun,sty) gl = + convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty gl + +let reduct_in_hyp redfun ((_,id),where) gl = + convert_hyp_no_check + (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl let reduct_option redfun = function | Some id -> reduct_in_hyp (fst redfun) id @@ -238,8 +224,8 @@ let change_on_subterm cv_pb t = function let change_in_concl occl t = reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast) -let change_in_hyp occl t = - reduct_in_hyp (change_on_subterm Reduction.CONV t occl) +let change_in_hyp occl t id = + with_check (reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id) let change_option occl t = function Some id -> change_in_hyp occl t id @@ -276,16 +262,18 @@ let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast) (* A function which reduces accordingly to a reduction expression, as the command Eval does. *) -let needs_check = function +let checking_fun = function (* Expansion is not necessarily well-typed: e.g. expansion of t into x is not well-typed in [H:(P t); x:=t |- G] because x is defined after H *) - | Fold _ -> true - | _ -> false + | Fold _ -> with_check + | Pattern _ -> with_check + | _ -> (fun x -> x) let reduce redexp cl goal = - (if needs_check redexp then with_check else (fun x -> x)) - (redin_combinator (Redexpr.reduction_of_red_expr redexp) cl) - goal + let red = Redexpr.reduction_of_red_expr redexp in + match redexp with + (Fold _|Pattern _) -> with_check (redin_combinator red cl) goal + | _ -> redin_combinator red cl goal (* Unfolding occurrences of a constant *) @@ -402,9 +390,26 @@ let rec get_next_hyp_position id = function else get_next_hyp_position id right +let thin_for_replacing l gl = + try Tacmach.thin l gl + with Evarutil.ClearDependencyError (id,err) -> match err with + | Evarutil.OccurHypInSimpleClause None -> + errorlabstrm "" + (str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion.") + | Evarutil.OccurHypInSimpleClause (Some id') -> + errorlabstrm "" + (str "Cannot change " ++ pr_id id ++ + strbrk ", it is used in hypothesis " ++ pr_id id' ++ str".") + | Evarutil.EvarTypingBreak ev -> + errorlabstrm "" + (str "Cannot change " ++ pr_id id ++ + strbrk " without breaking the typing of " ++ + Printer.pr_existential (pf_env gl) ev ++ str".") + let intro_replacing id gl = let next_hyp = get_next_hyp_position id (pf_hyps gl) in - tclTHENLIST [thin [id]; introduction id; move_hyp true id next_hyp] gl + tclTHENLIST + [thin_for_replacing [id]; introduction id; move_hyp true id next_hyp] gl let intros_replacing ids gl = let rec introrec = function @@ -518,6 +523,13 @@ let bring_hyps hyps = let f = mkCast (Evarutil.mk_new_meta(),DEFAULTcast, newcl) in refine_no_check (mkApp (f, instance_from_named_context hyps)) gl) +let resolve_classes gl = + let env = pf_env gl and evd = project gl in + if evd = Evd.empty then tclIDTAC gl + else + let evd' = Typeclasses.resolve_typeclasses env (Evd.create_evar_defs evd) in + (tclTHEN (tclEVARS (Evd.evars_of evd')) tclNORMEVAR) gl + (**************************) (* Cut tactics *) (**************************) @@ -535,17 +547,11 @@ let cut c gl = let cut_intro t = tclTHENFIRST (cut t) intro -(* let cut_replacing id t tac = - tclTHENS (cut t) - [tclORELSE - (intro_replacing id) - (tclORELSE (intro_erasing id) (intro_using id)); - tac (refine_no_check (mkVar id)) ] *) - (* cut_replacing échoue si l'hypothèse à remplacer apparaît dans le but, ou dans une autre hypothèse *) let cut_replacing id t tac = - tclTHENS (cut t) [ intro_replacing id; tac (refine_no_check (mkVar id)) ] + tclTHENLAST (internal_cut_rev_replace id t) + (tac (refine_no_check (mkVar id))) let cut_in_parallel l = let rec prec = function @@ -704,72 +710,88 @@ let general_case_analysis with_evars (c,lbindc as cx) = let simplest_case c = general_case_analysis false (c,NoBindings) +(* Apply a tactic below the products of the conclusion of a lemma *) + +let descend_in_conjunctions with_evars tac exit c gl = + try + let (mind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + match match_with_record (snd (decompose_prod t)) with + | Some _ -> + let n = (mis_constr_nargs mind).(0) in + let sort = elimination_sort_of_goal gl in + let elim = pf_apply make_case_gen gl mind sort in + tclTHENLAST + (general_elim with_evars (c,NoBindings) (elim,NoBindings)) + (tclTHENLIST [ + tclDO n intro; + tclLAST_NHYPS n (fun l -> + tclFIRST + (List.map (fun id -> tclTHEN (tac (mkVar id)) (thin l)) l))]) + gl + | None -> + raise Exit + with RefinerError _|UserError _|Exit -> exit () + (****************************************************) (* Resolution tactics *) (****************************************************) -let resolve_classes gl = - let env = pf_env gl and evd = project gl in - if evd = Evd.empty then tclIDTAC gl - else - let evd' = Typeclasses.resolve_typeclasses env (Evd.create_evar_defs evd) in - (tclTHEN (tclEVARS (Evd.evars_of evd')) tclNORMEVAR) gl - (* Resolution with missing arguments *) -let general_apply with_delta with_destruct with_evars (c,lbind) gl = +let check_evars sigma evm gl = + let origsigma = gl.sigma in + let rest = + Evd.fold (fun ev evi acc -> + if not (Evd.mem origsigma ev) && not (Evd.is_defined sigma ev) + then Evd.add acc ev evi else acc) + evm Evd.empty + in + if rest <> Evd.empty then + errorlabstrm "apply" (str"Uninstantiated existential variables: " ++ + fnl () ++ pr_evar_map rest) + +let general_apply with_delta with_destruct with_evars (c,lbind) gl0 = let flags = if with_delta then default_unify_flags else default_no_delta_unify_flags in (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) - let concl_nprod = nb_prod (pf_concl gl) in + let concl_nprod = nb_prod (pf_concl gl0) in + let evm, c = c in let rec try_main_apply c gl = - let thm_ty0 = nf_betaiota (pf_type_of gl c) in - let try_apply thm_ty nprod = - let n = nb_prod thm_ty - nprod in - if n<0 then error "Applied theorem has not enough premisses."; - let clause = make_clenv_binding_apply gl (Some n) (c,thm_ty) lbind in - Clenvtac.res_pf clause ~with_evars:with_evars ~flags:flags gl in - try try_apply thm_ty0 concl_nprod - with PretypeError _|RefinerError _|UserError _|Failure _ as exn -> - let rec try_red_apply thm_ty = - try - (* Try to head-reduce the conclusion of the theorem *) - let red_thm = try_red_product (pf_env gl) (project gl) thm_ty in - try try_apply red_thm concl_nprod - with PretypeError _|RefinerError _|UserError _|Failure _ -> - try_red_apply red_thm - with Redelimination -> - (* Last chance: if the head is a variable, apply may try - second order unification *) - try if concl_nprod <> 0 then try_apply thm_ty 0 else raise Exit - with PretypeError _|RefinerError _|UserError _|Failure _|Exit -> - if with_destruct then - try - let (mind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in - match match_with_conjunction (snd (decompose_prod t)) with - | Some _ -> - let n = (mis_constr_nargs mind).(0) in - let sort = elimination_sort_of_goal gl in - let elim = pf_apply make_case_gen gl mind sort in - tclTHENLAST - (general_elim with_evars (c,NoBindings) (elim,NoBindings)) - (tclTHENLIST [ - tclDO n intro; - tclLAST_NHYPS n (fun l -> - tclFIRST - (List.map (fun id -> - tclTHEN (try_main_apply (mkVar id)) (thin l)) l)) - ]) gl - | None -> - raise Exit - with RefinerError _|UserError _|Exit -> raise exn - else - raise exn - in - try_red_apply thm_ty0 in - try_main_apply c gl + let thm_ty0 = nf_betaiota (pf_type_of gl c) in + let try_apply thm_ty nprod = + let n = nb_prod thm_ty - nprod in + if n<0 then error "Applied theorem has not enough premisses."; + let clause = make_clenv_binding_apply gl (Some n) (c,thm_ty) lbind in + let res = Clenvtac.res_pf clause ~with_evars:with_evars ~flags:flags gl in + if not with_evars then check_evars (fst res).sigma evm gl0; + res + in + try try_apply thm_ty0 concl_nprod + with PretypeError _|RefinerError _|UserError _|Failure _ as exn -> + let rec try_red_apply thm_ty = + try + (* Try to head-reduce the conclusion of the theorem *) + let red_thm = try_red_product (pf_env gl) (project gl) thm_ty in + try try_apply red_thm concl_nprod + with PretypeError _|RefinerError _|UserError _|Failure _ -> + try_red_apply red_thm + with Redelimination -> + (* Last chance: if the head is a variable, apply may try + second order unification *) + try if concl_nprod <> 0 then try_apply thm_ty 0 else raise Exit + with PretypeError _|RefinerError _|UserError _|Failure _|Exit -> + if with_destruct then + descend_in_conjunctions with_evars + try_main_apply (fun _ -> raise exn) c gl + else + raise exn + in try_red_apply thm_ty0 + in + if evm = Evd.empty then try_main_apply c gl0 + else + tclTHEN (tclEVARS (Evd.merge gl0.sigma evm)) (try_main_apply c) gl0 let rec apply_with_ebindings_gen b e = function | [] -> @@ -783,13 +805,13 @@ let apply_with_ebindings cb = apply_with_ebindings_gen false false [cb] let eapply_with_ebindings cb = apply_with_ebindings_gen false true [cb] let apply_with_bindings (c,bl) = - apply_with_ebindings (c,inj_ebindings bl) + apply_with_ebindings (inj_open c,inj_ebindings bl) let eapply_with_bindings (c,bl) = - apply_with_ebindings_gen false true [c,inj_ebindings bl] + apply_with_ebindings_gen false true [inj_open c,inj_ebindings bl] let apply c = - apply_with_ebindings (c,NoBindings) + apply_with_ebindings (inj_open c,NoBindings) let apply_list = function | c::l -> apply_with_bindings (c,ImplicitBindings l) @@ -819,27 +841,43 @@ let find_matching_clause unifier clause = with NotExtensibleClause -> failwith "Cannot apply" in find clause -let progress_with_clause innerclause clause = +let progress_with_clause flags innerclause clause = let ordered_metas = List.rev (clenv_independent clause) in if ordered_metas = [] then error "Statement without assumptions."; - let f mv = find_matching_clause (clenv_fchain mv clause) innerclause in + let f mv = + find_matching_clause (clenv_fchain mv ~flags clause) innerclause in try list_try_find f ordered_metas with Failure _ -> error "Unable to unify." -let apply_in_once gl innerclause (d,lbind) = +let apply_in_once_main flags innerclause (d,lbind) gl = let thm = nf_betaiota (pf_type_of gl d) in let rec aux clause = - try progress_with_clause innerclause clause + try progress_with_clause flags innerclause clause with err -> try aux (clenv_push_prod clause) - with NotExtensibleClause -> raise err - in aux (make_clenv_binding gl (d,thm) lbind) + with NotExtensibleClause -> raise err in + aux (make_clenv_binding gl (d,thm) lbind) + +let apply_in_once with_delta with_destruct with_evars id ((sigma,d),lbind) gl0 = + let flags = + if with_delta then default_unify_flags else default_no_delta_unify_flags in + let t' = pf_get_hyp_typ gl0 id in + let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in + let rec aux c gl = + try + let clause = apply_in_once_main flags innerclause (c,lbind) gl in + let res = clenv_refine_in with_evars id clause gl in + if not with_evars then check_evars (fst res).sigma sigma gl0; + res + with exn when with_destruct -> + descend_in_conjunctions true aux (fun _ -> raise exn) c gl + in + if sigma = Evd.empty then aux d gl0 + else + tclTHEN (tclEVARS (Evd.merge gl0.sigma sigma)) (aux d) gl0 + + -let apply_in with_evars id lemmas gl = - let t' = pf_get_hyp_typ gl id in - let innermostclause = mk_clenv_from_n gl (Some 0) (mkVar id,t') in - let clause = List.fold_left (apply_in_once gl) innermostclause lemmas in - clenv_refine_in with_evars id clause gl (* A useful resolution tactic which, if c:A->B, transforms |- C into |- B -> C and |- A @@ -1013,7 +1051,7 @@ let constructor_tac with_evars expctdnumopt i lbind gl = Array.length (snd (Global.lookup_inductive mind)).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; let cons = mkConstruct (ith_constructor_of_inductive mind i) in - let apply_tac = general_apply true false with_evars (cons,lbind) in + let apply_tac = general_apply true false with_evars (inj_open cons,lbind) in (tclTHENLIST [convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl @@ -1062,11 +1100,6 @@ let register_general_multi_rewrite f = let clear_last = tclLAST_HYP (fun c -> (clear [destVar c])) let case_last = tclLAST_HYP simplest_case -let fix_empty_case nv l = - (* The syntax does not distinguish between "[ ]" for one clause with no names - and "[ ]" for no clause at all; so we are a bit liberal here *) - if Array.length nv = 0 & l = [[]] then [] else l - let error_unexpected_extra_pattern loc nb pat = let s1,s2,s3 = match pat with | IntroIdentifier _ -> "name", (plural nb " introduction pattern"), "no" @@ -1089,7 +1122,7 @@ let intro_or_and_pattern loc b ll l' tac = if bracketed then error_unexpected_extra_pattern loc' nb pat; l | ip :: l -> ip :: adjust_names_length nb (n-1) l in - let ll = fix_empty_case nv ll in + let ll = fix_empty_or_and_pattern (Array.length nv) ll in check_or_and_pattern_size loc ll (Array.length nv); tclTHENLASTn (tclTHEN case_last clear_last) @@ -1097,12 +1130,29 @@ let intro_or_and_pattern loc b ll l' tac = nv (Array.of_list ll)) gl) -let clear_if_atomic l2r id gl = - let eq = pf_type_of gl (mkVar id) in - let (_,lhs,rhs) = snd (find_eq_data_decompose eq) in - if l2r & isVar lhs then tclTRY (clear [destVar lhs;id]) gl - else if not l2r & isVar rhs then tclTRY (clear [destVar rhs;id]) gl - else tclIDTAC gl +let rewrite_hyp l2r id gl = + let rew_on l2r = + !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) in + let clear_var_and_eq c = + tclTRY (tclTHEN (clear [id]) (tclTRY (clear [destVar c]))) in + let t = pf_whd_betadeltaiota gl (pf_type_of gl (mkVar id)) in + (* TODO: detect setoid equality? better detect the different equalities *) + match match_with_equality_type t with + | Some (hdcncl,[_;lhs;rhs]) -> + if l2r & isVar lhs & not (occur_var (pf_env gl) (destVar lhs) rhs) then + tclTHEN (rew_on l2r allClauses) (clear_var_and_eq lhs) gl + else if not l2r & isVar rhs & not (occur_var (pf_env gl) (destVar rhs) lhs) then + tclTHEN (rew_on l2r allClauses) (clear_var_and_eq rhs) gl + else + tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl + | Some (hdcncl,[c]) -> + let l2r = not l2r in (* equality of the form eq_true *) + if isVar c then + tclTHEN (rew_on l2r allClauses) (clear_var_and_eq c) gl + else + tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl + | _ -> + error "Cannot find a known equation." let rec explicit_intro_names = function | (_, IntroIdentifier id) :: l -> @@ -1149,11 +1199,9 @@ let rec intros_patterns b avoid thin destopt = function tclTHEN (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true) (onLastHyp (fun id -> - tclTHENLIST [ - !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) - allClauses; - clear_if_atomic l2r id; - intros_patterns b avoid thin destopt l ])) + tclTHEN + (rewrite_hyp l2r id) + (intros_patterns b avoid thin destopt l))) | [] -> clear_wildcards thin let intros_pattern = intros_patterns false [] [] @@ -1170,23 +1218,25 @@ let intro_patterns = function let make_id s = fresh_id [] (default_id_of_sort s) -let prepare_intros s (loc,ipat) gl = match ipat with +let prepare_intros s ipat gl = match ipat with + | None -> make_id s gl, tclIDTAC + | Some (loc,ipat) -> match ipat with | IntroIdentifier id -> id, tclIDTAC | IntroAnonymous -> make_id s gl, tclIDTAC | IntroFresh id -> fresh_id [] id gl, tclIDTAC | IntroWildcard -> let id = make_id s gl in id, clear_wildcards [dloc,id] | IntroRewrite l2r -> let id = make_id s gl in - id, !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allClauses + id, !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) allClauses | IntroOrAndPattern ll -> make_id s gl, intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move) let ipat_of_name = function - | Anonymous -> IntroAnonymous - | Name id -> IntroIdentifier id + | Anonymous -> None + | Name id -> Some (dloc, IntroIdentifier id) let allow_replace c gl = function (* A rather arbitrary condition... *) - | _, IntroIdentifier id -> + | Some (_, IntroIdentifier id) -> fst (decompose_app (snd (decompose_lam_assum c))) = mkVar id | _ -> false @@ -1201,15 +1251,37 @@ let assert_as first ipat c gl = (if first then [tclIDTAC; tac] else [tac; tclIDTAC]) gl | _ -> error "Not a proposition or a type." -let assert_tac first na = assert_as first (dloc,ipat_of_name na) -let true_cut = assert_tac true +let assert_tac na = assert_as true (ipat_of_name na) + +(* apply in as *) + +let as_tac id ipat = match ipat with + | Some (loc,IntroRewrite l2r) -> + !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) allClauses + | Some (loc,IntroOrAndPattern ll) -> + intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move) + | Some (loc, + (IntroIdentifier _ | IntroAnonymous | IntroFresh _ | IntroWildcard)) -> + user_err_loc (loc,"", str "Disjunctive/conjunctive pattern expected") + | None -> tclIDTAC + +let general_apply_in with_delta with_destruct with_evars id lemmas ipat gl = + tclTHEN + (tclMAP (apply_in_once with_delta with_destruct with_evars id) lemmas) + (as_tac id ipat) + gl + +let apply_in simple with_evars = general_apply_in simple simple with_evars (**************************) (* Generalize tactics *) (**************************) -let generalized_name c t cl = function - | Name id as na -> na +let generalized_name c t ids cl = function + | Name id as na -> + if List.mem id ids then + errorlabstrm "" (pr_id id ++ str " is already used"); + na | Anonymous -> match kind_of_term c with | Var id -> @@ -1228,7 +1300,7 @@ let generalize_goal gl i ((occs,c),na) cl = let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in let cl' = subst_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in - let na = generalized_name c t cl' na in + let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in mkProd (na,t,cl') let generalize_dep c gl = @@ -1313,10 +1385,10 @@ let out_arg = function let occurrences_of_hyp id cls = let rec hyp_occ = function [] -> None - | (((b,occs),id'),hl)::_ when id=id' -> Some (b,List.map out_arg occs) + | (((b,occs),id'),hl)::_ when id=id' -> Some ((b,List.map out_arg occs),hl) | _::l -> hyp_occ l in match cls.onhyps with - None -> Some (all_occurrences) + None -> Some (all_occurrences,InHyp) | Some l -> hyp_occ l let occurrences_of_goal cls = @@ -1383,15 +1455,15 @@ let letin_tac with_eq name c occs gl = (* Implementation without generalisation: abbrev will be lost in hyps in *) (* in the extracted proof *) -let letin_abstract id c occs gl = +let letin_abstract id c (occs,check_occs) gl = let env = pf_env gl in let compute_dependency _ (hyp,_,_ as d) depdecls = match occurrences_of_hyp hyp occs with | None -> depdecls | Some occ -> let newdecl = subst_term_occ_decl occ c d in - if occ = all_occurrences & d = newdecl then - if not (in_every_hyp occs) + if occ = (all_occurrences,InHyp) & d = newdecl then + if check_occs & not (in_every_hyp occs) then raise (RefinerError (DoesNotOccurIn (c,hyp))) else depdecls else @@ -1404,14 +1476,14 @@ let letin_abstract id c occs gl = if depdecls = [] then no_move else MoveAfter(pi1(list_last depdecls)) in (depdecls,lastlhyp,ccl) -let letin_tac with_eq name c occs gl = +let letin_tac_gen with_eq name c ty occs gl = let id = let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in if name = Anonymous then fresh_id [] x gl else if not (mem_named_context x (pf_hyps gl)) then x else error ("The variable "^(string_of_id x)^" is already declared.") in let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in - let t = pf_type_of gl c in + let t = match ty with Some t -> t | None -> pf_type_of gl c in let newcl,eq_tac = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with @@ -1434,7 +1506,10 @@ let letin_tac with_eq name c occs gl = intro_gen dloc (IntroMustBe id) lastlhyp true; eq_tac; tclMAP convert_hyp_no_check depdecls ] gl - + +let letin_tac with_eq name c ty occs = + letin_tac_gen with_eq name c ty (occs,true) + (* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *) let forward usetac ipat c gl = match usetac with @@ -1444,6 +1519,9 @@ let forward usetac ipat c gl = | Some tac -> tclTHENFIRST (assert_as true ipat c) tac gl +let pose_proof na c = forward None (ipat_of_name na) c +let assert_by na t tac = forward (Some tac) (ipat_of_name na) t + (*****************************) (* Ad hoc unfold *) (*****************************) @@ -1523,7 +1601,7 @@ let rec first_name_buggy avoid gl (loc,pat) = match pat with | IntroWildcard -> no_move | IntroRewrite _ -> no_move | IntroIdentifier id -> MoveAfter id - | IntroAnonymous | IntroFresh _ -> assert false + | IntroAnonymous | IntroFresh _ -> (* buggy *) no_move let consume_pattern avoid id gl = function | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), []) @@ -1618,14 +1696,14 @@ let atomize_param_of_ind (indref,nparams) hyp0 gl = | Var id -> let x = fresh_id [] id gl in tclTHEN - (letin_tac None (Name x) (mkVar id) allClauses) + (letin_tac None (Name x) (mkVar id) None allClauses) (atomize_one (i-1) ((mkVar x)::avoid)) gl | _ -> let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in let x = fresh_id [] id gl in tclTHEN - (letin_tac None (Name x) c allClauses) + (letin_tac None (Name x) c None allClauses) (atomize_one (i-1) ((mkVar x)::avoid)) gl else tclIDTAC gl @@ -1712,11 +1790,11 @@ let find_atomic_param_of_ind nparams indtyp = exception Shunt of identifier move_location -let cook_sign hyp0_opt indvars_init env = - let hyp0,indvars = - match hyp0_opt with - | None -> List.hd (List.rev indvars_init) , indvars_init - | Some h -> h,indvars_init in +let cook_sign hyp0_opt indvars env = + let hyp0,inhyps = + match hyp0_opt with + | None -> List.hd (List.rev indvars), [] + | Some (hyp0,at_least_in_hyps) -> hyp0, at_least_in_hyps in (* First phase from L to R: get [indhyps], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) let allindhyps = hyp0::indvars in @@ -1739,9 +1817,9 @@ let cook_sign hyp0_opt indvars_init env = indhyps := hyp::!indhyps; rhyp end else - if (List.exists (fun id -> occur_var_in_decl env id decl) allindhyps - or List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) - !decldeps) + if inhyps <> [] && List.mem hyp inhyps || inhyps = [] && + (List.exists (fun id -> occur_var_in_decl env id decl) allindhyps || + List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) !decldeps) then begin decldeps := decl::!decldeps; if !before then @@ -1909,14 +1987,26 @@ let mkEq t x y = let mkRefl t x = mkApp ((build_coq_eq_data ()).refl, [| t; x |]) -let mkHEq t x u y = +let mkHEq t x u y = mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq", [| t; x; u; y |]) -let mkHRefl t x = +let mkHRefl t x = mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl", [| t; x |]) +(* let id = lazy (coq_constant "mkHEq" ["Init";"Datatypes"] "id") *) + +(* let mkHEq t x u y = *) +(* let ty = new_Type () in *) +(* mkApp (coq_constant "mkHEq" ["Logic";"EqdepFacts"] "eq_dep", *) +(* [| ty; mkApp (Lazy.force id, [|ty|]); t; x; u; y |]) *) + +(* let mkHRefl t x = *) +(* let ty = new_Type () in *) +(* mkApp (coq_constant "mkHEq" ["Logic";"EqdepFacts"] "eq_dep_intro", *) +(* [| ty; mkApp (Lazy.force id, [|ty|]); t; x |]) *) + let mkCoe a x p px y eq = mkApp (Option.get (build_coq_eq_data ()).rect, [| a; x; p; px; y; eq |]) @@ -1936,40 +2026,46 @@ let ids_of_constr vars c = let rec aux vars c = match kind_of_term c with | Var id -> if List.mem id vars then vars else id :: vars + | App (f, args) -> + (match kind_of_term f with + | Construct (ind,_) + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + array_fold_left_from mib.Declarations.mind_nparams + aux vars args + | _ -> fold_constr aux vars c) | _ -> fold_constr aux vars c in aux vars c let make_abstract_generalize gl id concl dep ctx c eqs args refls = let meta = Evarutil.new_meta() in - let cstr = + let term, typ = mkVar id, pf_get_hyp_typ gl id in + let eqslen = List.length eqs in + (* Abstract by the "generalized" hypothesis equality proof if necessary. *) + let abshypeq = + if dep then + mkProd (Anonymous, mkHEq (lift 1 c) (mkRel 1) typ term, lift 1 concl) + else concl + in (* Abstract by equalitites *) - let eqs = lift_togethern 1 eqs in - let abseqs = it_mkProd_or_LetIn ~init:concl (List.map (fun x -> (Anonymous, None, x)) eqs) in - (* Abstract by the "generalized" hypothesis and its equality proof *) - let term, typ = mkVar id, pf_get_hyp_typ gl id in - let abshyp = - let abshypeq = - if dep then - mkProd (Anonymous, mkHEq (lift 1 c) (mkRel 1) typ term, lift 1 abseqs) - else abseqs - in - mkProd (Name id, c, abshypeq) - in - (* Abstract by the extension of the context *) - let genctyp = it_mkProd_or_LetIn ~init:abshyp ctx in - (* The goal will become this product. *) - let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in - (* Apply the old arguments giving the proper instantiation of the hyp *) - let instc = mkApp (genc, Array.of_list args) in - (* Then apply to the original instanciated hyp. *) - let newc = mkApp (instc, [| mkVar id |]) in - (* Apply the reflexivity proof for the original hyp. *) - let newc = if dep then mkApp (newc, [| mkHRefl typ term |]) else newc in - (* Finaly, apply the remaining reflexivity proofs on the index, to get a term of type gl again *) - let appeqs = mkApp (newc, Array.of_list refls) in - appeqs - in cstr - + let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) + let abseqs = it_mkProd_or_LetIn ~init:(lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in + (* Abstract by the "generalized" hypothesis. *) + let genarg = mkProd (Name id, c, abseqs) in + (* Abstract by the extension of the context *) + let genctyp = it_mkProd_or_LetIn ~init:genarg ctx in + (* The goal will become this product. *) + let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in + (* Apply the old arguments giving the proper instantiation of the hyp *) + let instc = mkApp (genc, Array.of_list args) in + (* Then apply to the original instanciated hyp. *) + let instc = mkApp (instc, [| mkVar id |]) in + (* Apply the reflexivity proofs on the indices. *) + let appeqs = mkApp (instc, Array.of_list refls) in + (* Finaly, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) + let newc = if dep then mkApp (appeqs, [| mkHRefl typ term |]) else appeqs in + newc + let abstract_args gl id = let c = pf_get_hyp_typ gl id in let sigma = project gl in @@ -1998,26 +2094,36 @@ let abstract_args gl id = let liftargty = lift (List.length ctx) argty in let convertible = Reductionops.is_conv_leq ctxenv sigma liftargty ty in match kind_of_term arg with - | Var _ | Rel _ | Ind _ when convertible -> - (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, vars, env) - | _ -> - let name = get_id name in - let decl = (Name name, None, ty) in - let ctx = decl :: ctx in - let c' = mkApp (lift 1 c, [|mkRel 1|]) in - let args = arg :: args in - let liftarg = lift (List.length ctx) arg in - let eq, refl = - if convertible then - mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl argty arg - else - mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg - in - let eqs = eq :: lift_list eqs in - let refls = refl :: refls in - let vars = ids_of_constr vars arg in - (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, vars, env) + | Var _ | Rel _ | Ind _ when convertible -> + (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, vars, env) + | _ -> + let name = get_id name in + let decl = (Name name, None, ty) in + let ctx = decl :: ctx in + let c' = mkApp (lift 1 c, [|mkRel 1|]) in + let args = arg :: args in + let liftarg = lift (List.length ctx) arg in + let eq, refl = + if convertible then + mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl argty arg + else + mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg + in + let eqs = eq :: lift_list eqs in + let refls = refl :: refls in + let vars = ids_of_constr vars arg in + (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, vars, env) in + let f, args = + match kind_of_term f with + | Construct (ind,_) + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + let first = mib.Declarations.mind_nparams in + let pars, args = array_chop first args in + mkApp (f, pars), args + | _ -> f, args + in let arity, ctx, ctxenv, c', args, eqs, refls, vars, env = Array.fold_left aux (pf_type_of gl f,[],env,f,[],[],[],[],env) args in @@ -2040,10 +2146,31 @@ let abstract_generalize id ?(generalize_vars=true) gl = else tclTHENLIST [refine newc; clear [id]; tclDO n intro] in - if generalize_vars then - tclTHEN tac (tclMAP (fun id -> tclTRY (generalize_dep (mkVar id))) vars) gl + if generalize_vars then tclTHEN tac + (tclFIRST [revert (List.rev vars) ; + tclMAP (fun id -> tclTRY (generalize_dep (mkVar id))) vars]) gl else tac gl - + +let dependent_pattern c gl = + let cty = pf_type_of gl c in + let deps = + match kind_of_term cty with + | App (f, args) -> Array.to_list args + | _ -> [] + in + let varname c = match kind_of_term c with + | Var id -> id + | _ -> id_of_string (hdchar (pf_env gl) c) + in + let mklambda ty (c, id, cty) = + let conclvar = subst_term_occ all_occurrences c ty in + mkNamedLambda id cty conclvar + in + let subst = (c, varname c, cty) :: List.map (fun c -> (c, varname c, pf_type_of gl c)) deps in + let concllda = List.fold_left mklambda (pf_concl gl) subst in + let conclapp = applistc concllda (List.rev_map pi1 subst) in + convert_concl_no_check conclapp DEFAULTcast gl + let occur_rel n c = let res = not (noccurn n c) in res @@ -2466,7 +2593,8 @@ let induction_from_context_l isrec with_evars elim_info lid names gl = apply_induction_in_context isrec None indsign (hyp0::indvars) names induct_tac gl -let induction_from_context isrec with_evars elim_info (hyp0,lbind) names gl = +let induction_from_context isrec with_evars elim_info (hyp0,lbind) names + inhyps gl = let indsign,scheme = elim_info in let indref = match scheme.indref with | None -> assert false | Some x -> x in let tmptyp0 = pf_get_hyp_typ gl hyp0 in @@ -2479,12 +2607,11 @@ let induction_from_context isrec with_evars elim_info (hyp0,lbind) names gl = thin [hyp0] ] in apply_induction_in_context isrec - (Some hyp0) indsign indvars names induct_tac gl - + (Some (hyp0,inhyps)) indsign indvars names induct_tac gl exception TryNewInduct of exn -let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) gl = +let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) inhyps gl = let (indsign,scheme as elim_info) = find_elim_signature isrec elim hyp0 gl in if scheme.indarg = None then (* This is not a standard induction scheme (the argument is probably a parameter) So try the @@ -2494,7 +2621,8 @@ let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbin let indref = match scheme.indref with | None -> assert false | Some x -> x in tclTHEN (atomize_param_of_ind (indref,scheme.nparams) hyp0) - (induction_from_context isrec with_evars elim_info (hyp0,lbind) names) gl + (induction_from_context isrec with_evars elim_info + (hyp0,lbind) names inhyps) gl (* Induction on a list of induction arguments. Analyse the elim scheme (which is mandatory for multiple ind args), check that all @@ -2512,26 +2640,66 @@ let induction_without_atomization isrec with_evars elim names lid gl = then error "Not the right number of induction arguments." else induction_from_context_l isrec with_evars elim_info lid names gl +let enforce_eq_name id gl = function + | (b,(loc,IntroAnonymous)) -> + (b,(loc,IntroIdentifier (fresh_id [id] (add_prefix "Heq" id) gl))) + | (b,(loc,IntroFresh heq_base)) -> + (b,(loc,IntroIdentifier (fresh_id [id] heq_base gl))) + | x -> + x + +let has_selected_occurrences = function + | None -> false + | Some cls -> + cls.concl_occs <> all_occurrences_expr || + cls.onhyps <> None && List.exists (fun ((occs,_),hl) -> + occs <> all_occurrences_expr || hl <> InHyp) (Option.get cls.onhyps) + +(* assume that no occurrences are selected *) +let clear_unselected_context id inhyps cls gl = + match cls with + | None -> tclIDTAC gl + | Some cls -> + if occur_var (pf_env gl) id (pf_concl gl) && + cls.concl_occs = no_occurrences_expr + then errorlabstrm "" + (str "Conclusion must be mentioned: it depends on " ++ pr_id id + ++ str "."); + match cls.onhyps with + | Some hyps -> + let to_erase (id',_,_ as d) = + if List.mem id' inhyps then (* if selected, do not erase *) None + else + (* erase if not selected and dependent on id or selected hyps *) + let test id = occur_var_in_decl (pf_env gl) id d in + if List.exists test (id::inhyps) then Some id' else None in + let ids = list_map_filter to_erase (pf_hyps gl) in + thin ids gl + | None -> tclIDTAC gl + let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl = + let inhyps = match cls with + | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps + | _ -> [] in match kind_of_term c with | Var id when not (mem_named_context id (Global.named_context())) - & lbind = NoBindings & not with_evars & cls = None - & eqname = None -> - induction_with_atomization_of_ind_arg - isrec with_evars elim names (id,lbind) gl + & lbind = NoBindings & not with_evars & eqname = None + & not (has_selected_occurrences cls) -> + tclTHEN + (clear_unselected_context id inhyps cls) + (induction_with_atomization_of_ind_arg + isrec with_evars elim names (id,lbind) inhyps) gl | _ -> let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in let id = fresh_id [] x gl in - let with_eq = - match eqname with - | Some eq -> Some (false,eq) - | _ -> - if cls <> None then Some (false,(dloc,IntroAnonymous)) else None in + (* We need the equality name now *) + let with_eq = Option.map (fun eq -> (false,eq)) eqname in + (* TODO: if ind has predicate parameters, use JMeq instead of eq *) tclTHEN - (letin_tac with_eq (Name id) c (Option.default allClauses cls)) + (letin_tac_gen with_eq (Name id) c None (Option.default allClauses cls,false)) (induction_with_atomization_of_ind_arg - isrec with_evars elim names (id,lbind)) gl + isrec with_evars elim names (id,lbind) inhyps) gl (* Induction on a list of arguments. First make induction arguments atomic (using letins), then do induction. The specificity here is @@ -2563,7 +2731,7 @@ let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl = let _ = newlc:=id::!newlc in let _ = letids:=id::!letids in tclTHEN - (letin_tac None (Name id) c allClauses) + (letin_tac None (Name id) c None allClauses) (atomize_list newl') gl in tclTHENLIST [ @@ -2763,12 +2931,15 @@ let reflexivity_red allowred gl = let concl = if not allowred then pf_concl gl else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) in - match match_with_equation concl with - | None -> !setoid_reflexivity gl - | Some _ -> one_constructor 1 NoBindings gl - -let reflexivity gl = reflexivity_red false gl - + match match_with_equality_type concl with + | None -> None + | Some _ -> Some (one_constructor 1 NoBindings) + +let reflexivity gl = + match reflexivity_red false gl with + | None -> !setoid_reflexivity gl + | Some tac -> tac gl + let intros_reflexivity = (tclTHEN intros reflexivity) (* Symmetry tactics *) @@ -2788,13 +2959,15 @@ let symmetry_red allowred gl = let concl = if not allowred then pf_concl gl else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) in - match match_with_equation concl with - | None -> !setoid_symmetry gl - | Some (hdcncl,args) -> + match match_with_equation concl with + | None -> None + | Some (hdcncl,args) -> Some (fun gl -> let hdcncls = string_of_inductive hdcncl in begin try - (apply (pf_parse_const gl ("sym_"^hdcncls)) gl) + tclTHEN + (convert_concl_no_check concl DEFAULTcast) + (apply (pf_parse_const gl ("sym_"^hdcncls))) gl with _ -> let symc = match args with | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) @@ -2808,9 +2981,12 @@ let symmetry_red allowred gl = tclLAST_HYP simplest_case; one_constructor 1 NoBindings ]) gl - end + end) -let symmetry gl = symmetry_red false gl +let symmetry gl = + match symmetry_red false gl with + | None -> !setoid_symmetry gl + | Some tac -> tac gl let setoid_symmetry_in = ref (fun _ _ -> assert false) let register_setoid_symmetry_in f = setoid_symmetry_in := f @@ -2860,8 +3036,8 @@ let transitivity_red allowred t gl = else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) in match match_with_equation concl with - | None -> !setoid_transitivity t gl - | Some (hdcncl,args) -> + | None -> None + | Some (hdcncl,args) -> Some (fun gl -> let hdcncls = string_of_inductive hdcncl in begin try @@ -2885,10 +3061,13 @@ let transitivity_red allowred t gl = [ tclDO 2 intro; tclLAST_HYP simplest_case; assumption ])) gl - end - -let transitivity t gl = transitivity_red false t gl + end) +let transitivity t gl = + match transitivity_red false t gl with + | None -> !setoid_transitivity t gl + | Some tac -> tac gl + let intros_transitivity n = tclTHEN intros (transitivity n) (* tactical to save as name a subproof such that the generalisation of @@ -2917,7 +3096,7 @@ let abstract_subproof name tac gl = error "\"abstract\" cannot handle existentials."; let lemme = start_proof na (Global, Proof Lemma) secsign concl (fun _ _ -> ()); - let _,(const,kind,_) = + let _,(const,_,kind,_) = try by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)); let r = cook_proof ignore in @@ -2968,7 +3147,14 @@ let admit_as_an_axiom gl = List.rev (Array.to_list (instance_from_named_context sign)))) gl -let conv x y gl = - try let evd = Evarconv.the_conv_x_leq (pf_env gl) x y (Evd.create_evar_defs (project gl)) in - tclEVARS (Evd.evars_of evd) gl - with _ -> tclFAIL 0 (str"Not convertible") gl +let unify ?(state=full_transparent_state) x y gl = + try + let flags = + {default_unify_flags with + modulo_delta = state; + modulo_conv_on_closed_terms = Some state} + in + let evd = w_unify false (pf_env gl) Reduction.CONV + ~flags x y (Evd.create_evar_defs (project gl)) + in tclEVARS (Evd.evars_of evd) gl + with _ -> tclFAIL 0 (str"Not unifiable") gl diff --git a/tactics/tactics.mli b/tactics/tactics.mli index d39433d0..fb5c0efd 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tactics.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: tactics.mli 11735 2009-01-02 17:22:31Z herbelin $ i*) (*i*) open Util @@ -42,8 +42,8 @@ val type_clenv_binding : goal sigma -> constr * constr -> open_constr bindings -> constr val string_of_inductive : constr -> string -val head_constr : constr -> constr list -val head_constr_bound : constr -> constr list -> constr list +val head_constr : constr -> constr * constr list +val head_constr_bound : constr -> constr * constr list val is_quantified_hypothesis : identifier -> goal sigma -> bool exception Bound @@ -184,19 +184,22 @@ val bring_hyps : named_context -> tactic val apply : constr -> tactic val apply_without_reduce : constr -> tactic val apply_list : constr list -> tactic - + val apply_with_ebindings_gen : - advanced_flag -> evars_flag -> constr with_ebindings list -> tactic + advanced_flag -> evars_flag -> open_constr with_ebindings list -> tactic val apply_with_bindings : constr with_bindings -> tactic val eapply_with_bindings : constr with_bindings -> tactic -val apply_with_ebindings : constr with_ebindings -> tactic -val eapply_with_ebindings : constr with_ebindings -> tactic +val apply_with_ebindings : open_constr with_ebindings -> tactic +val eapply_with_ebindings : open_constr with_ebindings -> tactic val cut_and_apply : constr -> tactic -val apply_in : evars_flag -> identifier -> constr with_ebindings list -> tactic +val apply_in : + advanced_flag -> evars_flag -> identifier -> + open_constr with_ebindings list -> + intro_pattern_expr located option -> tactic (*s Elimination tactics. *) @@ -324,19 +327,19 @@ val simplest_split : tactic (*s Logical connective tactics. *) val register_setoid_reflexivity : tactic -> unit -val reflexivity_red : bool -> tactic +val reflexivity_red : bool -> goal sigma -> tactic option val reflexivity : tactic val intros_reflexivity : tactic val register_setoid_symmetry : tactic -> unit -val symmetry_red : bool -> tactic +val symmetry_red : bool -> goal sigma -> tactic option val symmetry : tactic val register_setoid_symmetry_in : (identifier -> tactic) -> unit val symmetry_in : identifier -> tactic val intros_symmetry : clause -> tactic val register_setoid_transitivity : (constr -> tactic) -> unit -val transitivity_red : bool -> constr -> tactic +val transitivity_red : bool -> constr -> goal sigma -> tactic option val transitivity : constr -> tactic val intros_transitivity : constr -> tactic @@ -346,17 +349,19 @@ val cut_replacing : identifier -> constr -> (tactic -> tactic) -> tactic val cut_in_parallel : constr list -> tactic -val assert_as : bool -> intro_pattern_expr located -> constr -> tactic -val forward : tactic option -> intro_pattern_expr located -> constr -> tactic +val assert_as : bool -> intro_pattern_expr located option -> constr -> tactic +val forward : tactic option -> intro_pattern_expr located option -> constr -> tactic val letin_tac : (bool * intro_pattern_expr located) option -> name -> - constr -> clause -> tactic -val true_cut : name -> constr -> tactic -val assert_tac : bool -> name -> constr -> tactic + constr -> types option -> clause -> tactic +val assert_tac : name -> types -> tactic +val assert_by : name -> types -> tactic -> tactic +val pose_proof : name -> constr -> tactic + val generalize : constr list -> tactic val generalize_gen : ((occurrences * constr) * name) list -> tactic val generalize_dep : constr -> tactic -val conv : constr -> constr -> tactic +val unify : ?state:Names.transparent_state -> constr -> constr -> tactic val resolve_classes : tactic val tclABSTRACT : identifier option -> tactic -> tactic @@ -365,5 +370,7 @@ val admit_as_an_axiom : tactic val abstract_generalize : identifier -> ?generalize_vars:bool -> tactic +val dependent_pattern : constr -> tactic + val register_general_multi_rewrite : - (bool -> evars_flag -> constr with_ebindings -> clause -> tactic) -> unit + (bool -> evars_flag -> open_constr with_bindings -> clause -> tactic) -> unit diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 17ea121f..1729695d 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id: tauto.ml4 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: tauto.ml4 11739 2009-01-02 19:33:19Z herbelin $ i*) open Term open Hipattern @@ -21,19 +21,44 @@ open Tacinterp open Tactics open Util -let assoc_last ist = - match List.assoc (Names.id_of_string "X1") ist.lfun with +let assoc_var s ist = + match List.assoc (Names.id_of_string s) ist.lfun with | VConstr c -> c | _ -> failwith "tauto: anomaly" +(** Parametrization of tauto *) + +(* Whether conjunction and disjunction are restricted to binary connectives *) +(* (this is the compatibility mode) *) +let binary_mode = true + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* contravariant position in an hypothesis (this is the compatibility mode) *) +let strict_in_contravariant_hyp = true + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* an hypothesis and in the conclusion *) +let strict_in_hyp_and_ccl = false + +(* Whether unit type includes equality types *) +let strict_unit = false + + +(** Test *) + let is_empty ist = - if is_empty_type (assoc_last ist) then + if is_empty_type (assoc_var "X1" ist) then <:tactic> else <:tactic> -let is_unit ist = - if is_unit_type (assoc_last ist) then +(* Strictly speaking, this exceeds the propositional fragment as it + matches also equality types (and solves them if a reflexivity) *) +let is_unit_or_eq ist = + let test = if strict_unit then is_unit_type else is_unit_or_eq_type in + if test (assoc_var "X1" ist) then <:tactic> else <:tactic> @@ -47,93 +72,138 @@ let is_record t = | _ -> false let is_binary t = + isApp t && let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in mib.Declarations.mind_nparams = 2 | _ -> false - + +let iter_tac tacl = + List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl + +(** Dealing with conjunction *) + let is_conj ist = - let ind = assoc_last ist in - if (is_conjunction ind) && (is_nodep_ind ind) (* && not (is_record ind) *) - && is_binary ind (* for compatibility, as (?X _ _) matches - applications with 2 or more arguments. *) + let ind = assoc_var "X1" ist in + if (not binary_mode || is_binary ind) (* && not (is_record ind) *) + && is_conjunction ~strict:strict_in_hyp_and_ccl ind then <:tactic> else <:tactic> +let flatten_contravariant_conj ist = + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + match match_with_conjunction ~strict:strict_in_contravariant_hyp typ with + | Some (_,args) -> + let i = List.length args in + if not binary_mode || i = 2 then + let newtyp = valueIn (VConstr (List.fold_right mkArrow args c)) in + let intros = + iter_tac (List.map (fun _ -> <:tactic< intro >>) args) + <:tactic< idtac >> in + <:tactic< + let newtyp := $newtyp in + assert newtyp by ($intros; apply id; split; assumption); + clear id + >> + else + <:tactic> + | _ -> + <:tactic> + +(** Dealing with disjunction *) + let is_disj ist = - if is_disjunction (assoc_last ist) && is_binary (assoc_last ist) then + let t = assoc_var "X1" ist in + if (not binary_mode || is_binary t) && + is_disjunction ~strict:strict_in_hyp_and_ccl t + then <:tactic> else <:tactic> +let flatten_contravariant_disj ist = + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + match match_with_disjunction ~strict:strict_in_contravariant_hyp typ with + | Some (_,args) -> + let i = List.length args in + if not binary_mode || i = 2 then + iter_tac (list_map_i (fun i arg -> + let typ = valueIn (VConstr (mkArrow arg c)) in + <:tactic< + let typ := $typ in + assert typ by (intro; apply id; constructor $i; assumption) + >>) 1 args) <:tactic< clear id >> + else + <:tactic> + | _ -> + <:tactic> + + +(** Main tactic *) + let not_dep_intros ist = <:tactic< repeat match goal with | |- (?X1 -> ?X2) => intro - | |- (Coq.Init.Logic.iff _ _) => unfold Coq.Init.Logic.iff - | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not - | H:(Coq.Init.Logic.iff _ _)|- _ => unfold Coq.Init.Logic.iff in H - | H:(Coq.Init.Logic.not _)|-_ => unfold Coq.Init.Logic.not in H - | H:(Coq.Init.Logic.iff _ _)->_|- _ => unfold Coq.Init.Logic.iff in H - | H:(Coq.Init.Logic.not _)->_|-_ => unfold Coq.Init.Logic.not in H + | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1 + | H:(Coq.Init.Logic.not _)|-_ => unfold Coq.Init.Logic.not at 1 in H + | H:(Coq.Init.Logic.not _)->_|-_ => unfold Coq.Init.Logic.not at 1 in H end >> let axioms ist = - let t_is_unit = tacticIn is_unit + let t_is_unit_or_eq = tacticIn is_unit_or_eq and t_is_empty = tacticIn is_empty in <:tactic< match reverse goal with - | |- ?X1 => $t_is_unit; constructor 1 + | |- ?X1 => $t_is_unit_or_eq; constructor 1 | _:?X1 |- _ => $t_is_empty; elimtype X1; assumption | _:?X1 |- ?X1 => assumption end >> let simplif ist = - let t_is_unit = tacticIn is_unit + let t_is_unit_or_eq = tacticIn is_unit_or_eq and t_is_conj = tacticIn is_conj + and t_flatten_contravariant_conj = tacticIn flatten_contravariant_conj + and t_flatten_contravariant_disj = tacticIn flatten_contravariant_disj and t_is_disj = tacticIn is_disj and t_not_dep_intros = tacticIn not_dep_intros in <:tactic< $t_not_dep_intros; repeat (match reverse goal with - | id: (?X1 _ _) |- _ => - $t_is_conj; elim id; do 2 intro; clear id - | id: (?X1 _ _) |- _ => $t_is_disj; elim id; intro; clear id + | id: ?X1 |- _ => $t_is_conj; elim id; do 2 intro; clear id + | id: (Coq.Init.Logic.iff _ _) |- _ => elim id; do 2 intro; clear id + | id: ?X1 |- _ => $t_is_disj; elim id; intro; clear id | id0: ?X1-> ?X2, id1: ?X1|- _ => (* generalize (id0 id1); intro; clear id0 does not work (see Marco Maggiesi's bug PR#301) so we instead use Assert and exact. *) assert X2; [exact (id0 id1) | clear id0] | id: ?X1 -> ?X2|- _ => - $t_is_unit; cut X2; + $t_is_unit_or_eq; cut X2; [ intro; clear id | (* id : ?X1 -> ?X2 |- ?X2 *) cut X1; [exact id| constructor 1; fail] ] - | id: (?X1 ?X2 ?X3) -> ?X4|- _ => - $t_is_conj; cut (X2-> X3-> X4); - [ intro; clear id - | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X2 -> ?X3 -> ?X4 *) - intro; intro; cut (X1 X2 X3); [exact id| split; assumption] - ] - | id: (?X1 ?X2 ?X3) -> ?X4|- _ => - $t_is_disj; - cut (X3-> X4); - [cut (X2-> X4); - [intro; intro; clear id - | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X2 -> ?X4 *) - intro; cut (X1 X2 X3); [exact id| left; assumption] - ] - | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X3 -> ?X4 *) - intro; cut (X1 X2 X3); [exact id| right; assumption] - ] - | |- (?X1 _ _) => $t_is_conj; split + | id: ?X1 -> ?X2|- _ => + $t_flatten_contravariant_conj + (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *) + | id: (Coq.Init.Logic.iff ?X1 ?X2) -> ?X3|- _ => + assert ((X1 -> X2) -> (X2 -> X1) -> X3) + by (do 2 intro; apply id; split; assumption); + clear id + | id: ?X1 -> ?X2|- _ => + $t_flatten_contravariant_disj + (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2|-" and "?B->?X2|-" *) + | |- ?X1 => $t_is_conj; split + | |- (Coq.Init.Logic.iff _ _) => split end; $t_not_dep_intros) >> @@ -153,7 +223,7 @@ let rec tauto_intuit t_reduce solver ist = [ exact id | generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id; solve [ $t_tauto_intuit ]]] - | |- (?X1 _ _) => + | |- ?X1 => $t_is_disj; solve [left;$t_tauto_intuit | right;$t_tauto_intuit] end || @@ -164,13 +234,9 @@ let rec tauto_intuit t_reduce solver ist = || $t_solver ) >> - + let reduction_not_iff _ist = - <:tactic progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff - | H:_ |- _ => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in H - end >> + <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >> let t_reduction_not_iff = tacticIn reduction_not_iff diff --git a/test-suite/bugs/closed/shouldfail/1898.v b/test-suite/bugs/closed/shouldfail/1898.v new file mode 100644 index 00000000..92490eb9 --- /dev/null +++ b/test-suite/bugs/closed/shouldfail/1898.v @@ -0,0 +1,5 @@ +(* folding should not allow circular dependencies *) + +Lemma bug_fold_unfold : True. + set (h := 1). + fold h in h. diff --git a/test-suite/bugs/closed/shouldsucceed/121.v b/test-suite/bugs/closed/shouldsucceed/121.v index d193aa73..8c5a3885 100644 --- a/test-suite/bugs/closed/shouldsucceed/121.v +++ b/test-suite/bugs/closed/shouldsucceed/121.v @@ -4,7 +4,7 @@ Section Setoid_Bug. Variable X:Type -> Type. Variable Xeq : forall A, (X A) -> (X A) -> Prop. -Hypothesis Xst : forall A, Equivalence (X A) (Xeq A). +Hypothesis Xst : forall A, Equivalence (Xeq A). Variable map : forall A B, (A -> B) -> X A -> X B. diff --git a/test-suite/bugs/closed/shouldsucceed/1791.v b/test-suite/bugs/closed/shouldsucceed/1791.v new file mode 100644 index 00000000..694f056e --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1791.v @@ -0,0 +1,38 @@ +(* simpl performs eta expansion *) + +Set Implicit Arguments. +Require Import List. + +Definition k0 := Set. +Definition k1 := k0 -> k0. + +(** iterating X n times *) +Fixpoint Pow (X:k1)(k:nat){struct k}:k1:= + match k with 0 => fun X => X + | S k' => fun A => X (Pow X k' A) + end. + +Parameter Bush: k1. +Parameter BushToList: forall (A:k0), Bush A -> list A. + +Definition BushnToList (n:nat)(A:k0)(t:Pow Bush n A): list A. +Proof. + intros. + induction n. + exact (t::nil). + simpl in t. + exact (flat_map IHn (BushToList t)). +Defined. + +Parameter bnil : forall (A:k0), Bush A. +Axiom BushToList_bnil: forall (A:k0), BushToList (bnil A) = nil(A:=A). + +Lemma BushnToList_bnil (n:nat)(A:k0): + BushnToList (S n) A (bnil (Pow Bush n A)) = nil. +Proof. + intros. + simpl. + rewrite BushToList_bnil. + simpl. + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1891.v b/test-suite/bugs/closed/shouldsucceed/1891.v new file mode 100644 index 00000000..11124cdd --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1891.v @@ -0,0 +1,13 @@ +(* Check evar-evar unification *) + Inductive T (A: Set): Set := mkT: unit -> T A. + + Definition f (A: Set) (l: T A): unit := tt. + + Implicit Arguments f [A]. + + Lemma L (x: T unit): (unit -> T unit) -> unit. + Proof. + refine (fun x => match x return _ with mkT n => fun g => f (g _) end). + trivial. + Qed. + diff --git a/test-suite/bugs/closed/shouldsucceed/1900.v b/test-suite/bugs/closed/shouldsucceed/1900.v new file mode 100644 index 00000000..cf03efda --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1900.v @@ -0,0 +1,8 @@ +Parameter A : Type . + +Definition eq_A := @eq A. + +Goal forall x, eq_A x x. +intros. +reflexivity. +Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1901.v b/test-suite/bugs/closed/shouldsucceed/1901.v new file mode 100644 index 00000000..598db366 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1901.v @@ -0,0 +1,11 @@ +Require Import Relations. + +Record Poset{A:Type}(Le : relation A) : Type := + Build_Poset + { + Le_refl : forall x : A, Le x x; + Le_trans : forall x y z : A, Le x y -> Le y z -> Le x z; + Le_antisym : forall x y : A, Le x y -> Le y x -> x = y }. + +Definition nat_Poset : Poset Peano.le. +Admitted. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1907.v b/test-suite/bugs/closed/shouldsucceed/1907.v new file mode 100644 index 00000000..55fc8231 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1907.v @@ -0,0 +1,7 @@ +(* An example of type inference *) + +Axiom A : Type. +Definition f (x y : A) := x. +Axiom g : forall x y : A, f x y = y -> Prop. +Axiom x : A. +Check (g x _ (refl_equal x)). diff --git a/test-suite/bugs/closed/shouldsucceed/1918.v b/test-suite/bugs/closed/shouldsucceed/1918.v new file mode 100644 index 00000000..9d4a3e04 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1918.v @@ -0,0 +1,377 @@ +(** Occur-check for Meta (up to delta) *) + +(** LNMItPredShort.v Version 2.0 July 2008 *) +(** does not need impredicative Set, runs under V8.2, tested with SVN 11296 *) + +(** Copyright Ralph Matthes, I.R.I.T., C.N.R.S. & University of Toulouse*) + + +Set Implicit Arguments. + +(** the universe of all monotypes *) +Definition k0 := Set. + +(** the type of all type transformations *) +Definition k1 := k0 -> k0. + +(** the type of all rank-2 type transformations *) +Definition k2 := k1 -> k1. + +(** polymorphic identity *) +Definition id : forall (A:Set), A -> A := fun A x => x. + +(** composition *) +Definition comp (A B C:Set)(g:B->C)(f:A->B) : A->C := fun x => g (f x). + +Infix "o" := comp (at level 90). + +Definition sub_k1 (X Y:k1) : Type := + forall A:Set, X A -> Y A. + +Infix "c_k1" := sub_k1 (at level 60). + +(** monotonicity *) +Definition mon (X:k1) : Type := forall (A B:Set), (A -> B) -> X A -> X B. + +(** extensionality *) +Definition ext (X:k1)(h: mon X): Prop := + forall (A B:Set)(f g:A -> B), + (forall a, f a = g a) -> forall r, h _ _ f r = h _ _ g r. + +(** first functor law *) +Definition fct1 (X:k1)(m: mon X) : Prop := + forall (A:Set)(x:X A), m _ _ (id(A:=A)) x = x. + +(** second functor law *) +Definition fct2 (X:k1)(m: mon X) : Prop := + forall (A B C:Set)(f:A -> B)(g:B -> C)(x:X A), + m _ _ (g o f) x = m _ _ g (m _ _ f x). + +(** pack up the good properties of the approximation into + the notion of an extensional functor *) +Record EFct (X:k1) : Type := mkEFct + { m : mon X; + e : ext m; + f1 : fct1 m; + f2 : fct2 m }. + +(** preservation of extensional functors *) +Definition pEFct (F:k2) : Type := + forall (X:k1), EFct X -> EFct (F X). + + +(** we show some closure properties of pEFct, depending on such properties + for EFct *) + +Definition moncomp (X Y:k1)(mX:mon X)(mY:mon Y): mon (fun A => X(Y A)). +Proof. + red. + intros X Y mX mY A B f x. + exact (mX (Y A)(Y B) (mY A B f) x). +Defined. + +(** closure under composition *) +Lemma compEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X(Y A)). +Proof. + intros X Y ef1 ef2. + apply (mkEFct(m:=moncomp (m ef1) (m ef2))); red; intros; unfold moncomp. +(* prove ext *) + apply (e ef1). + intro. + apply (e ef2); trivial. +(* prove fct1 *) + rewrite (e ef1 (m ef2 (id (A:=A))) (id(A:=Y A))). + apply (f1 ef1). + intro. + apply (f1 ef2). +(* prove fct2 *) + rewrite (e ef1 (m ef2 (g o f))((m ef2 g)o(m ef2 f))). + apply (f2 ef1). + intro. + unfold comp at 2. + apply (f2 ef2). +Defined. + +Corollary comppEFct (F G:k2): pEFct F -> pEFct G -> + pEFct (fun X A => F X (G X A)). +Proof. + red. + intros. + apply compEFct; auto. +Defined. + +(** closure under sums *) +Lemma sumEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A + Y A)%type. +Proof. + intros X Y ef1 ef2. + set (m12:=fun (A B:Set)(f:A->B) x => match x with + | inl y => inl _ (m ef1 f y) + | inr y => inr _ (m ef2 f y) + end). + apply (mkEFct(m:=m12)); red; intros. +(* prove ext *) + destruct r. + simpl. + apply (f_equal (fun x=>inl (A:=X B) (Y B) x)). + apply (e ef1); trivial. + simpl. + apply (f_equal (fun x=>inr (X B) (B:=Y B) x)). + apply (e ef2); trivial. +(* prove fct1 *) + destruct x. + simpl. + apply (f_equal (fun x=>inl (A:=X A) (Y A) x)). + apply (f1 ef1). + simpl. + apply (f_equal (fun x=>inr (X A) (B:=Y A) x)). + apply (f1 ef2). +(* prove fct2 *) + destruct x. + simpl. + rewrite (f2 ef1); reflexivity. + simpl. + rewrite (f2 ef2); reflexivity. +Defined. + +Corollary sumpEFct (F G:k2): pEFct F -> pEFct G -> + pEFct (fun X A => F X A + G X A)%type. +Proof. + red. + intros. + apply sumEFct; auto. +Defined. + +(** closure under products *) +Lemma prodEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A * Y A)%type. +Proof. + intros X Y ef1 ef2. + set (m12:=fun (A B:Set)(f:A->B) x => match x with + (x1,x2) => (m ef1 f x1, m ef2 f x2) end). + apply (mkEFct(m:=m12)); red; intros. +(* prove ext *) + destruct r as [x1 x2]. + simpl. + apply injective_projections; simpl. + apply (e ef1); trivial. + apply (e ef2); trivial. +(* prove fct1 *) + destruct x as [x1 x2]. + simpl. + apply injective_projections; simpl. + apply (f1 ef1). + apply (f1 ef2). +(* prove fct2 *) + destruct x as [x1 x2]. + simpl. + apply injective_projections; simpl. + apply (f2 ef1). + apply (f2 ef2). +Defined. + +Corollary prodpEFct (F G:k2): pEFct F -> pEFct G -> + pEFct (fun X A => F X A * G X A)%type. +Proof. + red. + intros. + apply prodEFct; auto. +Defined. + +(** the identity in k2 preserves extensional functors *) +Lemma idpEFct: pEFct (fun X => X). +Proof. + red. + intros. + assumption. +Defined. + +(** a variant for the eta-expanded identity *) +Lemma idpEFct_eta: pEFct (fun X A => X A). +Proof. + red. + intros X ef. + destruct ef as [m0 e0 f01 f02]. + change (mon X) with (mon (fun A => X A)) in m0. + apply (mkEFct (m:=m0) e0 f01 f02). +Defined. + +(** the identity in k1 "is" an extensional functor *) +Lemma idEFct: EFct (fun A => A). +Proof. + set (mId:=fun A B (f:A->B)(x:A) => f x). + apply (mkEFct(m:=mId)). + red. + intros. + unfold mId. + apply H. + red. + reflexivity. + red. + reflexivity. +Defined. + +(** constants in k2 *) +Lemma constpEFct (X:k1): EFct X -> pEFct (fun _ => X). +Proof. + red. + intros. + assumption. +Defined. + +(** constants in k1 *) +Lemma constEFct (C:Set): EFct (fun _ => C). +Proof. + intro. + set (mC:=fun A B (f:A->B)(x:C) => x). + apply (mkEFct(m:=mC)); red; intros; unfold mC; reflexivity. +Defined. + + +(** the option type *) +Lemma optionEFct: EFct (fun (A:Set) => option A). + apply (mkEFct (X:=fun (A:Set) => option A)(m:=option_map)); red; intros. + destruct r. + simpl. + rewrite H. + reflexivity. + reflexivity. + destruct x; reflexivity. + destruct x; reflexivity. +Defined. + + +(** natural transformations from (X,mX) to (Y,mY) *) +Definition NAT(X Y:k1)(j:X c_k1 Y)(mX:mon X)(mY:mon Y) : Prop := + forall (A B:Set)(f:A->B)(t:X A), j B (mX A B f t) = mY _ _ f (j A t). + + +Module Type LNMIt_Type. + +Parameter F:k2. +Parameter FpEFct: pEFct F. +Parameter mu20: k1. +Definition mu2: k1:= fun A => mu20 A. +Parameter mapmu2: mon mu2. +Definition MItType: Type := + forall G : k1, (forall X : k1, X c_k1 G -> F X c_k1 G) -> mu2 c_k1 G. +Parameter MIt0 : MItType. +Definition MIt : MItType:= fun G s A t => MIt0 s t. +Definition InType : Type := + forall (X:k1)(ef:EFct X)(j: X c_k1 mu2), + NAT j (m ef) mapmu2 -> F X c_k1 mu2. +Parameter In : InType. +Axiom mapmu2Red : forall (A:Set)(X:k1)(ef:EFct X)(j: X c_k1 mu2) + (n: NAT j (m ef) mapmu2)(t: F X A)(B:Set)(f:A->B), + mapmu2 f (In ef n t) = In ef n (m (FpEFct ef) f t). +Axiom MItRed : forall (G : k1) + (s : forall X : k1, X c_k1 G -> F X c_k1 G)(X : k1)(ef:EFct X)(j: X c_k1 mu2) + (n: NAT j (m ef) mapmu2)(A:Set)(t:F X A), + MIt s (In ef n t) = s X (fun A => (MIt s (A:=A)) o (j A)) A t. +Definition mu2IndType : Prop := + forall (P : (forall A : Set, mu2 A -> Prop)), + (forall (X : k1)(ef:EFct X)(j : X c_k1 mu2)(n: NAT j (m ef) mapmu2), + (forall (A : Set) (x : X A), P A (j A x)) -> + forall (A:Set)(t : F X A), P A (In ef n t)) -> + forall (A : Set) (r : mu2 A), P A r. +Axiom mu2Ind : mu2IndType. + +End LNMIt_Type. + +(** BushDepPredShort.v Version 0.2 July 2008 *) +(** does not need impredicative Set, produces stack overflow under V8.2, tested +with SVN 11296 *) + +(** Copyright Ralph Matthes, I.R.I.T., C.N.R.S. & University of Toulouse *) + +Set Implicit Arguments. + +Require Import List. + +Definition listk1 (A:Set) : Set := list A. +Open Scope type_scope. + +Definition BushF(X:k1)(A:Set) := unit + A * X (X A). + +Definition bushpEFct : pEFct BushF. +Proof. + unfold BushF. + apply sumpEFct. + apply constpEFct. + apply constEFct. + apply prodpEFct. + apply constpEFct. + apply idEFct. + apply comppEFct. + apply idpEFct. + apply idpEFct_eta. +Defined. + +Module Type BUSH := LNMIt_Type with Definition F:=BushF + with Definition FpEFct := +bushpEFct. + +Module Bush (BushBase:BUSH). + +Definition Bush : k1 := BushBase.mu2. + +Definition bush : mon Bush := BushBase.mapmu2. + +End Bush. + + +Definition Id : k1 := fun X => X. + +Fixpoint Pow (X:k1)(k:nat){struct k}:k1:= + match k with 0 => Id + | S k' => fun A => X (Pow X k' A) + end. + +Fixpoint POW (k:nat)(X:k1)(m:mon X){struct k} : mon (Pow X k) := + match k return mon (Pow X k) + with 0 => fun _ _ f => f + | S k' => fun _ _ f => m _ _ (POW k' m f) + end. + +Module Type BushkToList_Type. + +Declare Module Import BP: BUSH. +Definition F:=BushF. +Definition FpEFct:= bushpEFct. +Definition mu20 := mu20. +Definition mu2 := mu2. +Definition mapmu2 := mapmu2. +Definition MItType:= MItType. +Definition MIt0 := MIt0. +Definition MIt := MIt. +Definition InType := InType. +Definition In := In. +Definition mapmu2Red:=mapmu2Red. +Definition MItRed:=MItRed. +Definition mu2IndType:=mu2IndType. +Definition mu2Ind:=mu2Ind. + +Definition Bush:= mu2. +Module BushM := Bush BP. + +Parameter BushkToList: forall(k:nat)(A:k0)(t:Pow Bush k A), list A. +Axiom BushkToList0: forall(A:k0)(t:Pow Bush 0 A), BushkToList 0 A t = t::nil. + +End BushkToList_Type. + +Module BushDep (BushkToListM:BushkToList_Type). + +Module Bush := Bush BushkToListM. + +Import Bush. +Import BushkToListM. + + +Lemma BushkToList0NAT: NAT(Y:=listk1) (BushkToList 0) (POW 0 bush) map. +Proof. + red. + intros. + simpl. + rewrite BushkToList0. +(* stack overflow for coqc and coqtop *) + + +Abort. diff --git a/test-suite/bugs/closed/shouldsucceed/1925.v b/test-suite/bugs/closed/shouldsucceed/1925.v new file mode 100644 index 00000000..17eb721a --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1925.v @@ -0,0 +1,22 @@ +(* Check that the analysis of projectable rel's in an evar instance is up to + aliases *) + +Require Import List. + +Definition compose (A B C : Type) (g : B -> C) (f : A -> B) : A -> C := + fun x : A => g(f x). + +Definition map_fuse' : + forall (A B C : Type) (g : B -> C) (f : A -> B) (xs : list A), + (map g (map f xs)) = map (compose _ _ _ g f) xs + := + fun A B C g f => + (fix loop (ys : list A) {struct ys} := + match ys as ys return (map g (map f ys)) = map (compose _ _ _ g f) ys + with + | nil => refl_equal nil + | x :: xs => + match loop xs in eq _ a return eq _ ((g (f x)) :: a) with + | refl_equal => refl_equal (map g (map f (x :: xs))) + end + end). diff --git a/test-suite/bugs/closed/shouldsucceed/1931.v b/test-suite/bugs/closed/shouldsucceed/1931.v new file mode 100644 index 00000000..bc8be78f --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1931.v @@ -0,0 +1,29 @@ + + +Set Implicit Arguments. + +Inductive T (A:Set) : Set := + app : T A -> T A -> T A. + +Fixpoint map (A B:Set)(f:A->B)(t:T A) : T B := + match t with + app t1 t2 => app (map f t1)(map f t2) + end. + +Fixpoint subst (A B:Set)(f:A -> T B)(t:T A) :T B := + match t with + app t1 t2 => app (subst f t1)(subst f t2) + end. + +(* This is the culprit: *) +Definition k0:=Set. + +(** interaction of subst with map *) +Lemma substLaw1 (A:k0)(B C:Set)(f: A -> B)(g:B -> T C)(t: T A): + subst g (map f t) = subst (fun x => g (f x)) t. +Proof. + intros. + generalize B C f g; clear B C f g. + induction t; intros; simpl. + f_equal. +Admitted. diff --git a/test-suite/bugs/closed/shouldsucceed/1935.v b/test-suite/bugs/closed/shouldsucceed/1935.v new file mode 100644 index 00000000..641dcb7a --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1935.v @@ -0,0 +1,21 @@ +Definition f (n:nat) := n = n. + +Lemma f_refl : forall n , f n. +intros. reflexivity. +Qed. + +Definition f' (x:nat) (n:nat) := n = n. + +Lemma f_refl' : forall n , f' n n. +Proof. + intros. reflexivity. +Qed. + +Require Import ZArith. + +Definition f'' (a:bool) := if a then eq (A:= Z) else Zlt. + +Lemma f_refl'' : forall n , f'' true n n. +Proof. + intro. reflexivity. +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1963.v b/test-suite/bugs/closed/shouldsucceed/1963.v new file mode 100644 index 00000000..11e2ee44 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1963.v @@ -0,0 +1,19 @@ +(* Check that "dependent inversion" behaves correctly w.r.t to universes *) + +Require Import Eqdep. + +Set Implicit Arguments. + +Inductive illist(A:Type) : nat -> Type := + illistn : illist A 0 +| illistc : forall n:nat, A -> illist A n -> illist A (S n). + +Inductive isig (A:Type)(P:A -> Type) : Type := + iexists : forall x : A, P x -> isig P. + +Lemma inv : forall (A:Type)(n n':nat)(ts':illist A n'), n' = S n -> + isig (fun t => isig (fun ts => + eq_dep nat (fun n => illist A n) n' ts' (S n) (illistc t ts))). +Proof. +intros. +dependent inversion ts'. diff --git a/test-suite/bugs/closed/shouldsucceed/1977.v b/test-suite/bugs/closed/shouldsucceed/1977.v new file mode 100644 index 00000000..28715040 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1977.v @@ -0,0 +1,4 @@ +Inductive T {A} : Prop := c : A -> T. +Goal (@T nat). +apply c. exact 0. +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1981.v b/test-suite/bugs/closed/shouldsucceed/1981.v new file mode 100644 index 00000000..0c3b96da --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/1981.v @@ -0,0 +1,5 @@ +Implicit Arguments ex_intro [A]. + +Goal exists n : nat, True. + eapply ex_intro. exact 0. exact I. +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2001.v b/test-suite/bugs/closed/shouldsucceed/2001.v new file mode 100644 index 00000000..323021de --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2001.v @@ -0,0 +1,20 @@ +(* Automatic computing of guard in "Theorem with"; check that guard is not + computed when the user explicitly indicated it *) + +Inductive T : Set := +| v : T. + +Definition f (s:nat) (t:T) : nat. +fix 2. +intros s t. +refine + match t with + | v => s + end. +Defined. + +Lemma test : + forall s, f s v = s. +Proof. +reflexivity. +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2017.v b/test-suite/bugs/closed/shouldsucceed/2017.v new file mode 100644 index 00000000..948cea3e --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2017.v @@ -0,0 +1,15 @@ +(* Some check of Miller's pattern inference - used to fail in 8.2 due + first to the presence of aliases, secondly due to the absence of + restriction of the potential interesting variables to the subset of + variables effectively occurring in the term to instantiate *) + +Set Implicit Arguments. + +Variable choose : forall(P : bool -> Prop)(H : exists x, P x), bool. + +Variable H : exists x : bool, True. + +Definition coef := +match Some true with + Some _ => @choose _ H |_ => true +end . diff --git a/test-suite/bugs/closed/shouldsucceed/2021.v b/test-suite/bugs/closed/shouldsucceed/2021.v new file mode 100644 index 00000000..e598e5ae --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2021.v @@ -0,0 +1,23 @@ +(* correct failure of injection/discriminate on types whose inductive + status derives from the substitution of an argument *) + +Inductive t : nat -> Type := +| M : forall n: nat, nat -> t n. + +Lemma eq_t : forall n n' m m', + existT (fun B : Type => B) (t n) (M n m) = + existT (fun B : Type => B) (t n') (M n' m') -> True. +Proof. + intros. + injection H. + intro Ht. + exact I. +Qed. + +Lemma eq_t' : forall n n' : nat, + existT (fun B : Type => B) (t n) (M n 0) = + existT (fun B : Type => B) (t n') (M n' 1) -> True. +Proof. + intros. + discriminate H || exact I. +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2027.v b/test-suite/bugs/closed/shouldsucceed/2027.v new file mode 100644 index 00000000..fb53c6ef --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2027.v @@ -0,0 +1,11 @@ + +Parameter T : Type -> Type. +Parameter f : forall {A}, T A -> T A. +Parameter P : forall {A}, T A -> Prop. +Axiom f_id : forall {A} (l : T A), f l = l. + +Goal forall A (p : T A), P p. +Proof. + intros. + rewrite <- f_id. +Admitted. \ No newline at end of file diff --git a/test-suite/check b/test-suite/check index 47960e98..bed86c41 100755 --- a/test-suite/check +++ b/test-suite/check @@ -3,9 +3,9 @@ # Automatic test of Coq if [ "$1" = -byte ]; then - coqtop="../bin/coqtop.byte -q -batch" + coqtop="../bin/coqtop.byte -boot -q -batch" else - coqtop="../bin/coqtop -q -batch" + coqtop="../bin/coqtop -boot -q -batch" fi command="$coqtop -top Top -load-vernac-source" diff --git a/test-suite/complexity/autodecomp.v b/test-suite/complexity/autodecomp.v new file mode 100644 index 00000000..8916b104 --- /dev/null +++ b/test-suite/complexity/autodecomp.v @@ -0,0 +1,11 @@ +(* 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. + +Time auto decomp. diff --git a/test-suite/failure/Reordering.v b/test-suite/failure/Reordering.v new file mode 100644 index 00000000..7b36d1c3 --- /dev/null +++ b/test-suite/failure/Reordering.v @@ -0,0 +1,5 @@ +(* Testing that hypothesis order (following a conversion/folding) is checked *) + +Goal forall (A:Set) (x:A) (A':=A), True. +intros. +change ((fun (_:A') => Set) x) in (type of A). diff --git a/test-suite/failure/guard.v b/test-suite/failure/guard.v index 46208c29..7e07a905 100644 --- a/test-suite/failure/guard.v +++ b/test-suite/failure/guard.v @@ -8,3 +8,14 @@ Fixpoint F (n:nat) : False := F (match F n with end). +(* de Bruijn mix-up *) +(* If accepted, Eval compute in f 0. loops *) +Definition f := + let f (f1 f2:nat->nat) := f1 in + let _ := 0 in + let _ := 0 in + let g (f1 f2:nat->nat) := f2 in + let h := f in (* h = Rel 4 *) + fix F (n:nat) : nat := + h F S n. (* here Rel 4 = g *) + diff --git a/test-suite/output/ArgumentsScope.v b/test-suite/output/ArgumentsScope.v index 13b5e13d..1ff53294 100644 --- a/test-suite/output/ArgumentsScope.v +++ b/test-suite/output/ArgumentsScope.v @@ -1,4 +1,4 @@ -(* A few tests to check Argument Scope Global command *) +(* A few tests to check Global Argument Scope command *) Section A. Variable a : bool -> bool. @@ -11,11 +11,11 @@ About b. About negb''. About negb'. About negb. -Arguments Scope Global negb'' [ _ ]. -Arguments Scope Global negb' [ _ ]. -Arguments Scope Global negb [ _ ]. -Arguments Scope Global a [ _ ]. -Arguments Scope Global b [ _ ]. +Global Arguments Scope negb'' [ _ ]. +Global Arguments Scope negb' [ _ ]. +Global Arguments Scope negb [ _ ]. +Global Arguments Scope a [ _ ]. +Global Arguments Scope b [ _ ]. About a. About b. About negb. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 995754a6..1f0e12d3 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -28,3 +28,5 @@ fix foo (A : Type) (l : list A) {struct l} : option A := : forall A : Type, list A -> option A Argument scopes are [type_scope list_scope] +foo' = if A 0 then true else false + : bool diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 61f89d40..37ee71e9 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -33,3 +33,16 @@ Fixpoint foo (A:Type) (l:list A) : option A := end. Print foo. + +(* Do not duplicate the matched term *) + +Axiom A : nat -> bool. + +Definition foo' := + match A 0 with + | true => true + | x => x + end. + +Print foo'. + diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 2066a7ef..42858304 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -50,3 +50,10 @@ Nil : forall A : Type, list A NIL:list nat : list nat +Defining 'I' as keyword +(false && I 3)%bool /\ I 6 + : Prop +[|1, 2, 3; 4, 5, 6|] + : Z * Z * Z * (Z * Z * Z) +fun f : Z -> Z -> Z -> Z => {|f; 0; 1; 2|}:Z + : (Z -> Z -> Z -> Z) -> Z diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index 6e637aca..b37c3638 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -129,3 +129,33 @@ Check Nil. Notation NIL := nil. Check NIL : list nat. + + +(**********************************************************************) +(* Test printing of notation with coercions in scope of a coercion *) + +Open Scope nat_scope. + +Coercion is_true := fun b => b=true. +Coercion of_nat n := match n with 0 => true | _ => false end. +Notation "'I' x" := (of_nat (S x) || true)%bool (at level 10). + +Check (false && I 3)%bool /\ I 6. + +(**********************************************************************) +(* Check notations with several recursive patterns *) + +Open Scope Z_scope. + +Notation "[| x , y , .. , z ; a , b , .. , c |]" := + (pair (pair .. (pair x y) .. z) (pair .. (pair a b) .. c)). +Check [|1,2,3;4,5,6|]. + +(**********************************************************************) +(* Test recursive notations involving applications *) +(* Caveat: does not work for applied constant because constants are *) +(* classified as notations for the particular constant while this *) +(* generic application notation is classified as generic *) + +Notation "{| f ; x ; .. ; y |}" := ( .. (f x) .. y). +Check fun f => {| f; 0; 1; 2 |} : Z. diff --git a/test-suite/success/Equations.v b/test-suite/success/Equations.v new file mode 100644 index 00000000..e31135c2 --- /dev/null +++ b/test-suite/success/Equations.v @@ -0,0 +1,321 @@ +Require Import Program. + +Equations neg (b : bool) : bool := +neg true := false ; +neg false := true. + +Eval compute in neg. + +Require Import Coq.Lists.List. + +Equations head A (default : A) (l : list A) : A := +head A default nil := default ; +head A default (cons a v) := a. + +Eval compute in head. + +Equations tail {A} (l : list A) : (list A) := +tail A nil := nil ; +tail A (cons a v) := v. + +Eval compute in @tail. + +Eval compute in (tail (cons 1 nil)). + +Reserved Notation " x ++ y " (at level 60, right associativity). + +Equations app' {A} (l l' : list A) : (list A) := +app' A nil l := l ; +app' A (cons a v) l := cons a (app' v l). + +Equations app (l l' : list nat) : list nat := + [] ++ l := l ; + (a :: v) ++ l := a :: (v ++ l) + +where " x ++ y " := (app x y). + +Eval compute in @app'. + +Equations zip' {A} (f : A -> A -> A) (l l' : list A) : (list A) := +zip' A f nil nil := nil ; +zip' A f (cons a v) (cons b w) := cons (f a b) (zip' f v w) ; +zip' A f nil (cons b w) := nil ; +zip' A f (cons a v) nil := nil. + + +Eval compute in @zip'. + +Equations zip'' {A} (f : A -> A -> A) (l l' : list A) (def : list A) : (list A) := +zip'' A f nil nil def := nil ; +zip'' A f (cons a v) (cons b w) def := cons (f a b) (zip'' f v w def) ; +zip'' A f nil (cons b w) def := def ; +zip'' A f (cons a v) nil def := def. + +Eval compute in @zip''. + +Inductive fin : nat -> Set := +| fz : Π {n}, fin (S n) +| fs : Π {n}, fin n -> fin (S n). + +Inductive finle : Π (n : nat) (x : fin n) (y : fin n), Prop := +| leqz : Π {n j}, finle (S n) fz j +| leqs : Π {n i j}, finle n i j -> finle (S n) (fs i) (fs j). + +Scheme finle_ind_dep := Induction for finle Sort Prop. + +Instance finle_ind_pack n x y : DependentEliminationPackage (finle n x y) := + { elim_type := _ ; elim := finle_ind_dep }. + +Implicit Arguments finle [[n]]. + +Require Import Bvector. + +Implicit Arguments Vnil [[A]]. +Implicit Arguments Vcons [[A] [n]]. + +Equations vhead {A n} (v : vector A (S n)) : A := +vhead A n (Vcons a v) := a. + +Equations vmap {A B} (f : A -> B) {n} (v : vector A n) : (vector B n) := +vmap A B f 0 Vnil := Vnil ; +vmap A B f (S n) (Vcons a v) := Vcons (f a) (vmap f v). + +Eval compute in (vmap id (@Vnil nat)). +Eval compute in (vmap id (@Vcons nat 2 _ Vnil)). +Eval compute in @vmap. + +Equations Below_nat (P : nat -> Type) (n : nat) : Type := +Below_nat P 0 := unit ; +Below_nat P (S n) := prod (P n) (Below_nat P n). + +Equations below_nat (P : nat -> Type) n (step : Π (n : nat), Below_nat P n -> P n) : Below_nat P n := +below_nat P 0 step := tt ; +below_nat P (S n) step := let rest := below_nat P n step in + (step n rest, rest). + +Class BelowPack (A : Type) := + { Below : Type ; below : Below }. + +Instance nat_BelowPack : BelowPack nat := + { Below := Π P n step, Below_nat P n ; + below := λ P n step, below_nat P n (step P) }. + +Definition rec_nat (P : nat -> Type) n (step : Π n, Below_nat P n -> P n) : P n := + step n (below_nat P n step). + +Fixpoint Below_vector (P : Π A n, vector A n -> Type) A n (v : vector A n) : Type := + match v with Vnil => unit | Vcons a n' v' => prod (P A n' v') (Below_vector P A n' v') end. + +Equations below_vector (P : Π A n, vector A n -> Type) A n (v : vector A n) + (step : Π A n (v : vector A n), Below_vector P A n v -> P A n v) : Below_vector P A n v := +below_vector P A ?(0) Vnil step := tt ; +below_vector P A ?(S n) (Vcons a v) step := + let rest := below_vector P A n v step in + (step A n v rest, rest). + +Instance vector_BelowPack : BelowPack (Π A n, vector A n) := + { Below := Π P A n v step, Below_vector P A n v ; + below := λ P A n v step, below_vector P A n v (step P) }. + +Instance vector_noargs_BelowPack A n : BelowPack (vector A n) := + { Below := Π P v step, Below_vector P A n v ; + below := λ P v step, below_vector P A n v (step P) }. + +Definition rec_vector (P : Π A n, vector A n -> Type) A n v + (step : Π A n (v : vector A n), Below_vector P A n v -> P A n v) : P A n v := + step A n v (below_vector P A n v step). + +Class Recursor (A : Type) (BP : BelowPack A) := + { rec_type : Π x : A, Type ; rec : Π x : A, rec_type x }. + +Instance nat_Recursor : Recursor nat nat_BelowPack := + { rec_type := λ n, Π P step, P n ; + rec := λ n P step, rec_nat P n (step P) }. + +(* Instance vect_Recursor : Recursor (Π A n, vector A n) vector_BelowPack := *) +(* rec_type := Π (P : Π A n, vector A n -> Type) step A n v, P A n v; *) +(* rec := λ P step A n v, rec_vector P A n v step. *) + +Instance vect_Recursor_noargs A n : Recursor (vector A n) (vector_noargs_BelowPack A n) := + { rec_type := λ v, Π (P : Π A n, vector A n -> Type) step, P A n v; + rec := λ v P step, rec_vector P A n v step }. + +Implicit Arguments Below_vector [P A n]. + +Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity). + +(** Won't pass the guardness check which diverges anyway. *) + +(* Equations trans {n} {i j k : fin n} (p : finle i j) (q : finle j k) : finle i k := *) +(* trans ?(S n) ?(fz) ?(j) ?(k) leqz q := leqz ; *) +(* trans ?(S n) ?(fs i) ?(fs j) ?(fs k) (leqs p) (leqs q) := leqs (trans p q). *) + +(* Lemma trans_eq1 n (j k : fin (S n)) (q : finle j k) : trans leqz q = leqz. *) +(* Proof. intros. simplify_equations ; reflexivity. Qed. *) + +(* Lemma trans_eq2 n i j k p q : @trans (S n) (fs i) (fs j) (fs k) (leqs p) (leqs q) = leqs (trans p q). *) +(* Proof. intros. simplify_equations ; reflexivity. Qed. *) + +Section Image. + Context {S T : Type}. + Variable f : S -> T. + + Inductive Imf : T -> Type := imf (s : S) : Imf (f s). + + Equations inv (t : T) (im : Imf t) : S := + inv (f s) (imf s) := s. + +End Image. + +Section Univ. + + Inductive univ : Set := + | ubool | unat | uarrow (from:univ) (to:univ). + + Equations interp (u : univ) : Type := + interp ubool := bool ; interp unat := nat ; + interp (uarrow from to) := interp from -> interp to. + + Equations foo (u : univ) (el : interp u) : interp u := + foo ubool true := false ; + foo ubool false := true ; + foo unat t := t ; + foo (uarrow from to) f := id ∘ f. + + Eval lazy beta delta [ foo foo_obligation_1 foo_obligation_2 ] iota zeta in foo. + +End Univ. + +Eval compute in (foo ubool false). +Eval compute in (foo (uarrow ubool ubool) negb). +Eval compute in (foo (uarrow ubool ubool) id). + +Inductive foobar : Set := bar | baz. + +Equations bla (f : foobar) : bool := +bla bar := true ; +bla baz := false. + +Eval simpl in bla. +Print refl_equal. + +Notation "'refl'" := (@refl_equal _ _). + +Equations K {A} (x : A) (P : x = x -> Type) (p : P (refl_equal x)) (p : x = x) : P p := +K A x P p refl := p. + +Equations eq_sym {A} (x y : A) (H : x = y) : y = x := +eq_sym A x x refl := refl. + +Equations eq_trans {A} (x y z : A) (p : x = y) (q : y = z) : x = z := +eq_trans A x x x refl refl := refl. + +Lemma eq_trans_eq A x : @eq_trans A x x x refl refl = refl. +Proof. reflexivity. Qed. + +Equations nth {A} {n} (v : vector A n) (f : fin n) : A := +nth A (S n) (Vcons a v) fz := a ; +nth A (S n) (Vcons a v) (fs f) := nth v f. + +Equations tabulate {A} {n} (f : fin n -> A) : vector A n := +tabulate A 0 f := Vnil ; +tabulate A (S n) f := Vcons (f fz) (tabulate (f ∘ fs)). + +Equations vlast {A} {n} (v : vector A (S n)) : A := +vlast A 0 (Vcons a Vnil) := a ; +vlast A (S n) (Vcons a (n:=S n) v) := vlast v. + +Print Assumptions vlast. + +Equations vlast' {A} {n} (v : vector A (S n)) : A := +vlast' A ?(0) (Vcons a Vnil) := a ; +vlast' A ?(S n) (Vcons a (n:=S n) v) := vlast' v. + +Lemma vlast_equation1 A (a : A) : vlast' (Vcons a Vnil) = a. +Proof. intros. simplify_equations. reflexivity. Qed. + +Lemma vlast_equation2 A n a v : @vlast' A (S n) (Vcons a v) = vlast' v. +Proof. intros. simplify_equations ; reflexivity. Qed. + +Print Assumptions vlast'. +Print Assumptions nth. +Print Assumptions tabulate. + +Extraction vlast. +Extraction vlast'. + +Equations vliat {A} {n} (v : vector A (S n)) : vector A n := +vliat A 0 (Vcons a Vnil) := Vnil ; +vliat A (S n) (Vcons a v) := Vcons a (vliat v). + +Eval compute in (vliat (Vcons 2 (Vcons 5 (Vcons 4 Vnil)))). + +Equations vapp' {A} {n m} (v : vector A n) (w : vector A m) : vector A (n + m) := +vapp' A ?(0) m Vnil w := w ; +vapp' A ?(S n) m (Vcons a v) w := Vcons a (vapp' v w). + +Eval compute in @vapp'. + +Fixpoint vapp {A n m} (v : vector A n) (w : vector A m) : vector A (n + m) := + match v with + | Vnil => w + | Vcons a n' v' => Vcons a (vapp v' w) + end. + +Lemma JMeq_Vcons_inj A n m a (x : vector A n) (y : vector A m) : n = m -> JMeq x y -> JMeq (Vcons a x) (Vcons a y). +Proof. intros until y. simplify_dep_elim. reflexivity. Qed. + +Equations NoConfusion_fin (P : Prop) {n : nat} (x y : fin n) : Prop := +NoConfusion_fin P (S n) fz fz := P -> P ; +NoConfusion_fin P (S n) fz (fs y) := P ; +NoConfusion_fin P (S n) (fs x) fz := P ; +NoConfusion_fin P (S n) (fs x) (fs y) := (x = y -> P) -> P. + +Eval compute in NoConfusion_fin. +Eval compute in NoConfusion_fin_comp. + +Print Assumptions NoConfusion_fin. + +Eval compute in (fun P n => NoConfusion_fin P (n:=S n) fz fz). + +(* Equations noConfusion_fin P (n : nat) (x y : fin n) (H : x = y) : NoConfusion_fin P x y := *) +(* noConfusion_fin P (S n) fz fz refl := λ p _, p ; *) +(* noConfusion_fin P (S n) (fs x) (fs x) refl := λ p : x = x -> P, p refl. *) + +Equations_nocomp NoConfusion_vect (P : Prop) {A n} (x y : vector A n) : Prop := +NoConfusion_vect P A 0 Vnil Vnil := P -> P ; +NoConfusion_vect P A (S n) (Vcons a x) (Vcons b y) := (a = b -> x = y -> P) -> P. + +Equations noConfusion_vect (P : Prop) A n (x y : vector A n) (H : x = y) : NoConfusion_vect P x y := +noConfusion_vect P A 0 Vnil Vnil refl := λ p, p ; +noConfusion_vect P A (S n) (Vcons a v) (Vcons a v) refl := λ p : a = a -> v = v -> P, p refl refl. + +(* Instance fin_noconf n : NoConfusionPackage (fin n) := *) +(* NoConfusion := λ P, Π x y, x = y -> NoConfusion_fin P x y ; *) +(* noConfusion := λ P x y, noConfusion_fin P n x y. *) + +Instance vect_noconf A n : NoConfusionPackage (vector A n) := + { NoConfusion := λ P, Π x y, x = y -> NoConfusion_vect P x y ; + noConfusion := λ P x y, noConfusion_vect P A n x y }. + +Equations fog {n} (f : fin n) : nat := +fog (S n) fz := 0 ; fog (S n) (fs f) := S (fog f). + +Inductive Split {X : Set}{m n : nat} : vector X (m + n) -> Set := + append : Π (xs : vector X m)(ys : vector X n), Split (vapp xs ys). + +Implicit Arguments Split [[X]]. + +Equations_nocomp split {X : Set}(m n : nat) (xs : vector X (m + n)) : Split m n xs := +split X 0 n xs := append Vnil xs ; +split X (S m) n (Vcons x xs) := + let 'append xs' ys' in Split _ _ vec := split m n xs return Split (S m) n (Vcons x vec) in + append (Vcons x xs') ys'. + +Eval compute in (split 0 1 (vapp Vnil (Vcons 2 Vnil))). +Eval compute in (split _ _ (vapp (Vcons 3 Vnil) (Vcons 2 Vnil))). + +Extraction Inline split_obligation_1 split_obligation_2. +Recursive Extraction split. + +Eval compute in @split. diff --git a/test-suite/success/Generalization.v b/test-suite/success/Generalization.v new file mode 100644 index 00000000..6b503e95 --- /dev/null +++ b/test-suite/success/Generalization.v @@ -0,0 +1,13 @@ + +Check `(a = 0). +Check `(a = 0)%type. +Definition relation A := A -> A -> Prop. +Definition equivalence `(R : relation A) := True. +Check (`(@equivalence A R)). + +Definition a_eq_b : `( a = 0 /\ a = b /\ b > c \/ d = e /\ d = 1). +Admitted. +Print a_eq_b. + + + diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v index f83328e8..b08ffcc3 100644 --- a/test-suite/success/Inversion.v +++ b/test-suite/success/Inversion.v @@ -99,3 +99,11 @@ Lemma depinv : forall a b, foo a b -> True. intros a b H. inversion H. Abort. + +(* Check non-regression of bug #1968 *) + +Inductive foo2 : option nat -> Prop := Foo : forall t, foo2 (Some t). +Goal forall o, foo2 o -> 0 = 1. +intros. +eapply trans_eq. +inversion H. diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index 6dce0401..4bdd579a 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -26,3 +26,8 @@ Notation "x +1" := (S x) (at level 8, right associativity). right order *) Notation "' 'C_' G ( A )" := (A,G) (at level 8, G at level 2). + +(* Check import of notations from within a section *) + +Notation "+1 x" := (S x) (at level 25, x at level 9). +Section A. Global Notation "'Z'" := O (at level 9). End A. diff --git a/test-suite/success/Record.v b/test-suite/success/Record.v index 7fdbcda7..885fff48 100644 --- a/test-suite/success/Record.v +++ b/test-suite/success/Record.v @@ -1,3 +1,82 @@ (* Nijmegen expects redefinition of sorts *) Definition CProp := Prop. -Record test : CProp := {n : nat}. +Record test : CProp := {n : nat ; m : bool ; _ : n <> 0 }. +Require Import Program. +Require Import List. + +Record vector {A : Type} {n : nat} := { vec_list : list A ; vec_len : length vec_list = n }. +Implicit Arguments vector []. + +Coercion vec_list : vector >-> list. + +Hint Rewrite @vec_len : datatypes. + +Ltac crush := repeat (program_simplify ; autorewrite with list datatypes ; auto with *). + +Obligation Tactic := crush. + +Program Definition vnil {A} : vector A 0 := {| vec_list := [] |}. + +Program Definition vcons {A n} (a : A) (v : vector A n) : vector A (S n) := + {| vec_list := cons a (vec_list v) |}. + +Hint Rewrite map_length rev_length : datatypes. + +Program Definition vmap {A B n} (f : A -> B) (v : vector A n) : vector B n := + {| vec_list := map f v |}. + +Program Definition vreverse {A n} (v : vector A n) : vector A n := + {| vec_list := rev v |}. + +Fixpoint va_list {A B} (v : list (A -> B)) (w : list A) : list B := + match v, w with + | nil, nil => nil + | cons f fs, cons x xs => cons (f x) (va_list fs xs) + | _, _ => nil + end. + +Program Definition va {A B n} (v : vector (A -> B) n) (w : vector A n) : vector B n := + {| vec_list := va_list v w |}. + +Next Obligation. + destruct v as [v Hv]; destruct w as [w Hw] ; simpl. + subst n. revert w Hw. induction v ; destruct w ; crush. + rewrite IHv ; auto. +Qed. + +(* Correct type inference of record notation. Initial example by Spiwack. *) + +Inductive Machin := { + Bazar : option Machin +}. + +Definition bli : Machin := + {| Bazar := Some ({| Bazar := None |}:Machin) |}. + +Definition bli' : option (option Machin) := + Some (Some {| Bazar := None |} ). + +Definition bli'' : Machin := + {| Bazar := Some {| Bazar := None |} |}. + +Definition bli''' := {| Bazar := Some {| Bazar := None |} |}. + +(** Correctly use scoping information *) + +Require Import ZArith. + +Record Foo := { bar : Z }. +Definition foo := {| bar := 0 |}. + +(** Notations inside records *) + +Require Import Relation_Definitions. + +Record DecidableOrder : Type := +{ A : Type +; le : relation A where "x <= y" := (le x y) +; le_refl : reflexive _ le +; le_antisym : antisymmetric _ le +; le_trans : transitive _ le +; le_total : forall x y, {x <= y}+{y <= x} +}. diff --git a/test-suite/success/Reordering.v b/test-suite/success/Reordering.v new file mode 100644 index 00000000..de9b9975 --- /dev/null +++ b/test-suite/success/Reordering.v @@ -0,0 +1,15 @@ +(* Testing the reordering of hypothesis required by pattern, fold and change. *) +Goal forall (A:Set) (x:A) (A':=A), True. +intros. +fold A' in x. (* suceeds: x is moved after A' *) +Undo. +pattern A' in x. +Undo. +change A' in x. +Abort. + +(* p and m should be moved before H *) +Goal forall n:nat, n=n -> forall m:nat, let p := (m,n) in True. +intros. +change n with (snd p) in H. +Abort. diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index fcce68b9..952890ee 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -12,6 +12,44 @@ intros; apply Znot_le_gt, Zgt_lt in H. apply Zmult_lt_reg_r, Zlt_le_weak in H0; auto. Qed. +(* Test application under tuples *) + +Goal (forall x, x=0 <-> 0=x) -> 1=0 -> 0=1. +intros H H'. +apply H in H'. +exact H'. +Qed. + +(* Test as clause *) + +Goal (forall x, x=0 <-> (0=x /\ True)) -> 1=0 -> True. +intros H H'. +apply H in H' as (_,H'). +exact H'. +Qed. + +(* Test application modulo conversion *) + +Goal (forall x, id x = 0 -> 0 = x) -> 1 = id 0 -> 0 = 1. +intros H H'. +apply H in H'. +exact H'. +Qed. + +(* Check apply/eapply distinction in presence of open terms *) + +Parameter h : forall x y z : nat, x = z -> x = y. +Implicit Arguments h [[x] [y]]. +Goal 1 = 0 -> True. +intro H. +apply h in H || exact I. +Qed. + +Goal False -> 1 = 0. +intro H. +apply h || contradiction. +Qed. + (* Check if it unfolds when there are not enough premises *) Goal forall n, n = S n -> False. @@ -201,3 +239,18 @@ Axiom silly_axiom : forall v : exp, v = v -> False. Lemma silly_lemma : forall x : atom, False. intros x. apply silly_axiom with (v := x). (* fails *) + +(* Test non-regression of (temporary) bug 1981 *) + +Goal exists n : nat, True. +eapply ex_intro. +exact O. +trivial. +Qed. + +(* Test non-regression of (temporary) bug 1980 *) + +Goal True. +try eapply ex_intro. +trivial. +Qed. diff --git a/test-suite/success/dependentind.v b/test-suite/success/dependentind.v index 48255386..488b057f 100644 --- a/test-suite/success/dependentind.v +++ b/test-suite/success/dependentind.v @@ -1,10 +1,10 @@ Require Import Coq.Program.Program. -Set Implicit Arguments. -Unset Strict Implicit. +Set Manual Implicit Arguments. + Variable A : Set. -Inductive vector : nat -> Type := vnil : vector 0 | vcons : A -> forall n, vector n -> vector (S n). +Inductive vector : nat -> Type := vnil : vector 0 | vcons : A -> forall {n}, vector n -> vector (S n). Goal forall n, forall v : vector (S n), vector n. Proof. @@ -35,51 +35,55 @@ Inductive ctx : Type := | empty : ctx | snoc : ctx -> type -> ctx. -Notation " Γ , Ï„ " := (snoc Γ Ï„) (at level 25, t at next level, left associativity). +Bind Scope context_scope with ctx. +Delimit Scope context_scope with ctx. + +Arguments Scope snoc [context_scope]. + +Notation " Γ ,, Ï„ " := (snoc Γ Ï„) (at level 25, t at next level, left associativity). -Fixpoint conc (Γ Δ : ctx) : ctx := +Fixpoint conc (Δ Γ : ctx) : ctx := match Δ with | empty => Γ - | snoc Δ' x => snoc (conc Γ Δ') x + | snoc Δ' x => snoc (conc Δ' Γ) x end. -Notation " Γ ; Δ " := (conc Γ Δ) (at level 25, left associativity). +Notation " Γ ;; Δ " := (conc Δ Γ) (at level 25, left associativity) : context_scope. Inductive term : ctx -> type -> Type := -| ax : forall Γ Ï„, term (Γ, Ï„) Ï„ -| weak : forall Γ Ï„, term Γ Ï„ -> forall Ï„', term (Γ, Ï„') Ï„ -| abs : forall Γ Ï„ Ï„', term (Γ , Ï„) Ï„' -> term Γ (Ï„ --> Ï„') +| ax : forall Γ Ï„, term (snoc Γ Ï„) Ï„ +| weak : forall Γ Ï„, term Γ Ï„ -> forall Ï„', term (Γ ,, Ï„') Ï„ +| abs : forall Γ Ï„ Ï„', term (snoc Γ Ï„) Ï„' -> term Γ (Ï„ --> Ï„') | app : forall Γ Ï„ Ï„', term Γ (Ï„ --> Ï„') -> term Γ Ï„ -> term Γ Ï„'. -Lemma weakening : forall Γ Δ Ï„, term (Γ ; Δ) Ï„ -> - forall Ï„', term (Γ , Ï„' ; Δ) Ï„. -Proof with simpl in * ; auto ; simpl_depind. +Hint Constructors term : lambda. + +Open Local Scope context_scope. + +Notation " Γ |-- Ï„ " := (term Γ Ï„) (at level 0) : type_scope. + +Lemma weakening : forall Γ Δ Ï„, term (Γ ;; Δ) Ï„ -> + forall Ï„', term (Γ ,, Ï„' ;; Δ) Ï„. +Proof with simpl in * ; reverse ; simplify_dep_elim ; simplify_IH_hyps ; eauto with lambda. intros Γ Δ Ï„ H. dependent induction H. destruct Δ... - apply weak ; apply ax. - - apply ax. - - destruct Δ... - specialize (IHterm Γ empty)... - apply weak... - - apply weak... destruct Δ... - apply weak ; apply abs ; apply H. + destruct Δ... apply abs... - specialize (IHterm Γ0 (Δ, t, Ï„))... + + specialize (IHterm (Δ,, t,, Ï„)%ctx Γ0)... + intro. apply app with Ï„... Qed. -Lemma exchange : forall Γ Δ α β Ï„, term (Γ, α, β ; Δ) Ï„ -> term (Γ, β, α ; Δ) Ï„. -Proof with simpl in * ; simpl_depind ; auto. +Lemma exchange : forall Γ Δ α β Ï„, term (Γ,, α,, β ;; Δ) Ï„ -> term (Γ,, β,, α ;; Δ) Ï„. +Proof with simpl in * ; subst ; reverse ; simplify_dep_elim ; simplify_IH_hyps ; auto. intros until 1. dependent induction H. @@ -89,12 +93,37 @@ Proof with simpl in * ; simpl_depind ; auto. apply ax. destruct Δ... - pose (weakening (Γ:=Γ0) (Δ:=(empty, α)))... + pose (weakening Γ0 (empty,, α))... apply weak... - apply abs... - specialize (IHterm Γ0 α β (Δ, Ï„))... + apply abs... + specialize (IHterm (Δ ,, Ï„))... eapply app with Ï„... Save. + +(** Example by Andrew Kenedy, uses simplification of the first component of dependent pairs. *) + +Unset Manual Implicit Arguments. + +Inductive Ty := + | Nat : Ty + | Prod : Ty -> Ty -> Ty. + +Inductive Exp : Ty -> Type := +| Const : nat -> Exp Nat +| Pair : forall t1 t2, Exp t1 -> Exp t2 -> Exp (Prod t1 t2) +| Fst : forall t1 t2, Exp (Prod t1 t2) -> Exp t1. + +Inductive Ev : forall t, Exp t -> Exp t -> Prop := +| EvConst : forall n, Ev (Const n) (Const n) +| EvPair : forall t1 t2 (e1:Exp t1) (e2:Exp t2) e1' e2', + Ev e1 e1' -> Ev e2 e2' -> Ev (Pair e1 e2) (Pair e1' e2') +| EvFst : forall t1 t2 (e:Exp (Prod t1 t2)) e1 e2, + Ev e (Pair e1 e2) -> + Ev (Fst e) e1. + +Lemma EvFst_inversion : forall t1 t2 (e:Exp (Prod t1 t2)) e1, Ev (Fst e) e1 -> exists e2, Ev e (Pair e1 e2). +intros t1 t2 e e1 ev. dependent destruction ev. exists e2 ; assumption. +Qed. diff --git a/test-suite/success/guard.v b/test-suite/success/guard.v new file mode 100644 index 00000000..b9181d43 --- /dev/null +++ b/test-suite/success/guard.v @@ -0,0 +1,11 @@ +(* Specific tests about guard condition *) + +(* f must unfold to x, not F (de Bruijn mix-up!) *) +Check let x (f:nat->nat) k := f k in + fun (y z:nat->nat) => + let f:=x in (* f := Rel 3 *) + fix F (n:nat) : nat := + match n with + | 0 => 0 + | S k => f F k (* here Rel 3 = F ! *) + end. diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v index 4b636618..b654277c 100644 --- a/test-suite/success/refine.v +++ b/test-suite/success/refine.v @@ -117,3 +117,8 @@ refine let fn := fact_rec (n-1) _ in n * fn). Abort. + +(* Wish 1988: that fun forces unfold in refine *) + +Goal (forall A : Prop, A -> ~~A). +Proof. refine(fun A a f => _). diff --git a/test-suite/success/rewrite_iterated.v b/test-suite/success/rewrite_iterated.v new file mode 100644 index 00000000..962dada3 --- /dev/null +++ b/test-suite/success/rewrite_iterated.v @@ -0,0 +1,30 @@ +Require Import Arith Omega. + +Lemma test : forall p:nat, p<>0 -> p-1+1=p. +Proof. + intros; omega. +Qed. + +(** Test of new syntax for rewrite : ! ? and so on... *) + +Lemma but : forall a b c, a<>0 -> b<>0 -> c<>0 -> + (a-1+1)+(b-1+1)+(c-1+1)=a+b+c. +Proof. +intros. +rewrite test. +Undo. +rewrite test,test. +Undo. +rewrite 2 test. (* or rewrite 2test or rewrite 2!test *) +Undo. +rewrite 2!test,2?test. +Undo. +(*rewrite 4!test. --> error *) +rewrite 3!test. +Undo. +rewrite <- 3?test. +Undo. +(*rewrite <-?test. --> loops*) +rewrite !test by auto. +reflexivity. +Qed. diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v index f49f58e5..be5999df 100644 --- a/test-suite/success/setoid_test.v +++ b/test-suite/success/setoid_test.v @@ -116,3 +116,17 @@ Add Morphism (@f A) : f_morph. Proof. unfold rel, f. trivial. Qed. + +(* Submitted by Nicolas Tabareau *) +(* Needs unification.ml to support environments with de Bruijn *) + +Goal forall + (f : Prop -> Prop) + (Q : (nat -> Prop) -> Prop) + (H : forall (h : nat -> Prop), Q (fun x : nat => f (h x)) <-> True) + (h:nat -> Prop), + Q (fun x : nat => f (Q (fun b : nat => f (h x)))) <-> True. +intros f0 Q H. +setoid_rewrite H. +tauto. +Qed. diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v index 8d32b1d9..b4de4932 100644 --- a/test-suite/success/simpl.v +++ b/test-suite/success/simpl.v @@ -21,4 +21,27 @@ with copy_of_compute_size_tree (t:tree) : nat := Eval simpl in (copy_of_compute_size_forest leaf). +(* Another interesting case: Hrec has to occurrences: one cannot be folded + back to f while the second can. *) +Parameter g : (nat->nat)->nat->nat->nat. +Definition f (n n':nat) := + nat_rec (fun _ => nat -> nat) + (fun x => x) + (fun k Hrec => g Hrec (Hrec k)) + n n'. + +Goal forall a b, f (S a) b = b. +intros. +simpl. +admit. +Qed. (* Qed will fail if simpl performs eta-expansion *) + +(* Yet another example. *) + +Require Import List. + +Goal forall A B (a:A) l f (i:B), fold_right f i ((a :: l))=i. +simpl. +admit. +Qed. (* Qed will fail if simplification is incorrect (de Bruijn!) *) diff --git a/test-suite/success/unicode_utf8.v b/test-suite/success/unicode_utf8.v index 19e306fe..8b7764e5 100644 --- a/test-suite/success/unicode_utf8.v +++ b/test-suite/success/unicode_utf8.v @@ -1,12 +1,104 @@ -(* Check correct separation of identifiers followed by unicode symbols *) - Notation "x 〈 w" := (plus x w) (at level 30). - Check fun x => x〈x. +(** PARSER TESTS *) -(* Check Greek letters *) +(** Check correct separation of identifiers followed by unicode symbols *) +Notation "x ⊕ w" := (plus x w) (at level 30). +Check fun x => x⊕x. + +(** Check Greek letters *) Definition test_greek : nat -> nat := fun Δ => Δ. Parameter â„ : Set. Parameter Ï€ : â„. -(* Check indices *) +(** Check indices *) Definition test_indices : nat -> nat := fun xâ‚ => xâ‚. Definition π₂ := snd. + +(** More unicode in identifiers *) +Definition αβ_áà_×ב := 0. + + +(** UNICODE IN STRINGS *) + +Require Import List Ascii String. +Open Scope string_scope. + +Definition test_string := "azertyαβ∀ééé". +Eval compute in length test_string. + (** last six "chars" are unicode, hence represented by 2 bytes, + except the forall which is 3 bytes *) + +Fixpoint string_to_list s := + match s with + | EmptyString => nil + | String c s => c :: string_to_list s + end. + +Eval compute in (string_to_list test_string). + (** for instance, α is \206\177 whereas ∀ is \226\136\128 *) +Close Scope string_scope. + + + +(** INTERFACE TESTS *) + +Require Import Utf8. + +(** Printing of unicode notation, in *goals* *) +Lemma test : forall A:Prop, A -> A. +Proof. +auto. +Qed. + +(** Parsing of unicode notation, in *goals* *) +Lemma test2 : ∀A:Prop, A → A. +Proof. +intro. +intro. +auto. +Qed. + +(** Printing of unicode notation, in *response* *) +Check fun (X:Type)(x:X) => x. + +(** Parsing of unicode notation, in *response* *) +Check ∀Δ, Δ → Δ. +Check ∀x, x=0 ∨ x=0 → x=0. + + +(** ISSUES: *) + +Notation "x ≠ y" := (x<>y) (at level 70). + +Notation "x ≤ y" := (x<=y) (at level 70, no associativity). + +(** First Issue : ≤ is attached to "le" of nat, not to notation <= *) + +Require Import ZArith. +Open Scope Z_scope. +Locate "≤". (* still le, not Zle *) +Notation "x ≤ y" := (x<=y) (at level 70, no associativity). +Locate "≤". +Close Scope Z_scope. + +(** ==> How to proceed modularly ? *) + + +(** Second Issue : notation for -> generates useless parenthesis + if followed by a binder *) + +Check 0≠0 → ∀x:nat,x=x. + +(** Example of real situation : *) + +Definition pred : ∀x, x≠0 → ∃y, x = S y. +Proof. +destruct x. +destruct 1; auto. +intros _. +exists x; auto. +Defined. + +Print pred. + + + diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 1216a545..7cab976f 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Div2.v 10625 2008-03-06 11:21:01Z notin $ i*) +(*i $Id: Div2.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Require Import Lt. Require Import Plus. @@ -60,45 +60,38 @@ Hint Resolve lt_div2: arith. (** Properties related to the parity *) -Lemma even_odd_div2 : - forall n, - (even n <-> div2 n = div2 (S n)) /\ (odd n <-> S (div2 n) = div2 (S n)). +Lemma even_div2 : forall n, even n -> div2 n = div2 (S n) +with odd_div2 : forall n, odd n -> S (div2 n) = div2 (S n). Proof. - intro n. pattern n in |- *. apply ind_0_1_SS. - (* n = 0 *) - split. split; auto with arith. - split. intro H. inversion H. - intro H. absurd (S (div2 0) = div2 1); auto with arith. - (* n = 1 *) - split. split. intro. inversion H. inversion H1. - intro H. absurd (div2 1 = div2 2). - simpl in |- *. discriminate. assumption. - split; auto with arith. - (* n = (S (S n')) *) - intros. decompose [and] H. unfold iff in H0, H1. - decompose [and] H0. decompose [and] H1. clear H H0 H1. - split; split; auto with arith. - intro H. inversion H. inversion H1. - change (S (div2 n0) = S (div2 (S n0))) in |- *. auto with arith. - intro H. inversion H. inversion H1. - change (S (S (div2 n0)) = S (div2 (S n0))) in |- *. auto with arith. + destruct n; intro H. + (* 0 *) trivial. + (* S n *) inversion_clear H. apply odd_div2 in H0 as <-. trivial. + destruct n; intro. + (* 0 *) inversion H. + (* S n *) inversion_clear H. apply even_div2 in H0 as <-. trivial. Qed. -(** Specializations *) - -Lemma even_div2 : forall n, even n -> div2 n = div2 (S n). -Proof fun n => proj1 (proj1 (even_odd_div2 n)). +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. +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. +Qed. -Lemma div2_even : forall n, div2 n = div2 (S n) -> even n. -Proof fun n => proj2 (proj1 (even_odd_div2 n)). +Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith. -Lemma odd_div2 : forall n, odd n -> S (div2 n) = div2 (S n). -Proof fun n => proj1 (proj2 (even_odd_div2 n)). +Lemma even_odd_div2 : + forall 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. +Qed. -Lemma div2_odd : forall n, S (div2 n) = div2 (S n) -> odd n. -Proof fun n => proj2 (proj2 (even_odd_div2 n)). -Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith. (** Properties related to the double ([2n]) *) @@ -132,8 +125,7 @@ Proof. split; split; auto with arith. intro H. inversion H. inversion H1. (* n = (S (S n')) *) - intros. decompose [and] H. unfold iff in H0, H1. - decompose [and] H0. decompose [and] H1. clear H H0 H1. + intros. destruct H as ((IH1,IH2),(IH3,IH4)). split; split. intro H. inversion H. inversion H1. simpl in |- *. rewrite (double_S (div2 n0)). auto with arith. @@ -142,8 +134,6 @@ Proof. simpl in |- *. rewrite (double_S (div2 n0)). auto with arith. simpl in |- *. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith. Qed. - - (** Specializations *) Lemma even_double : forall n, even n -> n = double (div2 n). diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index 1484666b..59209370 100644 --- a/theories/Arith/Even.v +++ b/theories/Arith/Even.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Even.v 10410 2007-12-31 13:11:55Z msozeau $ i*) +(*i $Id: Even.v 11512 2008-10-27 12:28:36Z herbelin $ i*) (** Here we define the predicates [even] and [odd] by mutual induction and we prove the decidability and the exclusion of those predicates. @@ -52,153 +52,91 @@ Qed. (** * Facts about [even] & [odd] wrt. [plus] *) -Lemma even_plus_aux : - forall n m, - (odd (n + m) <-> odd n /\ even m \/ even n /\ odd m) /\ - (even (n + m) <-> even n /\ even m \/ odd n /\ odd m). +Lemma even_plus_split : forall n m, + (even (n + m) -> even n /\ even m \/ odd n /\ odd m) +with odd_plus_split : forall n m, + odd (n + m) -> odd n /\ even m \/ even n /\ odd m. Proof. - intros n; elim n; simpl in |- *; auto with arith. - intros m; split; auto. - split. - intros H; right; split; auto with arith. - intros H'; case H'; auto with arith. - intros H'0; elim H'0; intros H'1 H'2; inversion H'1. - intros H; elim H; auto. - split; auto with arith. - intros H'; elim H'; auto with arith. - intros H; elim H; auto. - intros H'0; elim H'0; intros H'1 H'2; inversion H'1. - intros n0 H' m; elim (H' m); intros H'1 H'2; elim H'1; intros E1 E2; elim H'2; - intros E3 E4; clear H'1 H'2. - split; split. - intros H'0; case E3. - inversion H'0; auto. - intros H; elim H; intros H0 H1; clear H; auto with arith. - intros H; elim H; intros H0 H1; clear H; auto with arith. - intros H'0; case H'0; intros C0; case C0; intros C1 C2. - apply odd_S. - apply E4; left; split; auto with arith. - inversion C1; auto. - apply odd_S. - apply E4; right; split; auto with arith. - inversion C1; auto. - intros H'0. - case E1. - inversion H'0; auto. - intros H; elim H; intros H0 H1; clear H; auto with arith. - intros H; elim H; intros H0 H1; clear H; auto with arith. - intros H'0; case H'0; intros C0; case C0; intros C1 C2. - apply even_S. - apply E2; left; split; auto with arith. - inversion C1; auto. - apply even_S. - apply E2; right; split; auto with arith. - inversion C1; auto. +intros. clear even_plus_split. destruct n; simpl in *. + auto with arith. + inversion_clear H; + apply odd_plus_split in H0 as [(H0,?)|(H0,?)]; auto with arith. +intros. clear odd_plus_split. destruct n; simpl in *. + auto with arith. + inversion_clear H; + apply even_plus_split in H0 as [(H0,?)|(H0,?)]; auto with arith. Qed. - -Lemma even_even_plus : forall n m, even n -> even m -> even (n + m). + +Lemma even_even_plus : forall n m, even n -> even m -> even (n + m) +with odd_plus_l : forall n m, odd n -> even m -> odd (n + m). Proof. - intros n m; case (even_plus_aux n m). - intros H H0; case H0; auto. +intros n m [|] ?. trivial. apply even_S, odd_plus_l; trivial. +intros n m [] ?. apply odd_S, even_even_plus; trivial. Qed. - -Lemma odd_even_plus : forall n m, odd n -> odd m -> even (n + m). + +Lemma odd_plus_r : forall n m, even n -> odd m -> odd (n + m) +with odd_even_plus : forall n m, odd n -> odd m -> even (n + m). Proof. - intros n m; case (even_plus_aux n m). - intros H H0; case H0; auto. +intros n m [|] ?. trivial. apply odd_S, odd_even_plus; trivial. +intros n m [] ?. apply even_S, odd_plus_r; trivial. +Qed. + +Lemma even_plus_aux : forall n m, + (odd (n + m) <-> odd n /\ even m \/ even n /\ odd m) /\ + (even (n + m) <-> even n /\ even m \/ odd n /\ odd m). +Proof. +split; split; auto using odd_plus_split, even_plus_split. +intros [[]|[]]; auto using odd_plus_r, odd_plus_l. +intros [[]|[]]; auto using even_even_plus, odd_even_plus. Qed. Lemma even_plus_even_inv_r : forall n m, even (n + m) -> even n -> even m. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'0. - intros H'1; case H'1; auto. - intros H0; elim H0; auto. - intros H0 H1 H2; case (not_even_and_odd n); auto. - case H0; auto. + intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd n); auto. Qed. Lemma even_plus_even_inv_l : forall n m, even (n + m) -> even m -> even n. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'0. - intros H'1; case H'1; auto. - intros H0; elim H0; auto. - intros H0 H1 H2; case (not_even_and_odd m); auto. - case H0; auto. + intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd m); auto. Qed. Lemma even_plus_odd_inv_r : forall n m, even (n + m) -> odd n -> odd m. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'0. - intros H'1; case H'1; auto. - intros H0 H1 H2; case (not_even_and_odd n); auto. - case H0; auto. - intros H0; case H0; auto. + intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd n); auto. Qed. Lemma even_plus_odd_inv_l : forall n m, even (n + m) -> odd m -> odd n. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'0. - intros H'1; case H'1; auto. - intros H0 H1 H2; case (not_even_and_odd m); auto. - case H0; auto. - intros H0; case H0; auto. + intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd m); auto. Qed. Hint Resolve even_even_plus odd_even_plus: arith. -Lemma odd_plus_l : forall n m, odd n -> even m -> odd (n + m). -Proof. - intros n m; case (even_plus_aux n m). - intros H; case H; auto. -Qed. - -Lemma odd_plus_r : forall n m, even n -> odd m -> odd (n + m). -Proof. - intros n m; case (even_plus_aux n m). - intros H; case H; auto. -Qed. - Lemma odd_plus_even_inv_l : forall n m, odd (n + m) -> odd m -> even n. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'. - intros H'1; case H'1; auto. - intros H0 H1 H2; case (not_even_and_odd m); auto. - case H0; auto. - intros H0; case H0; auto. + intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd m); auto. Qed. Lemma odd_plus_even_inv_r : forall n m, odd (n + m) -> odd n -> even m. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'. - intros H'1; case H'1; auto. - intros H0; case H0; auto. - intros H0 H1 H2; case (not_even_and_odd n); auto. - case H0; auto. + intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd n); auto. Qed. Lemma odd_plus_odd_inv_l : forall n m, odd (n + m) -> even m -> odd n. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'. - intros H'1; case H'1; auto. - intros H0; case H0; auto. - intros H0 H1 H2; case (not_even_and_odd m); auto. - case H0; auto. + intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd m); auto. Qed. Lemma odd_plus_odd_inv_r : forall n m, odd (n + m) -> even n -> odd m. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'. - intros H'1; case H'1; auto. - intros H0 H1 H2; case (not_even_and_odd n); auto. - case H0; auto. - intros H0; case H0; auto. + intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd n); auto. Qed. Hint Resolve odd_plus_l odd_plus_r: arith. diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index 95af67f8..5de2298d 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Max.v 9883 2007-06-07 18:44:59Z letouzey $ i*) +(*i $Id: Max.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Require Import Le. @@ -74,13 +74,13 @@ Lemma max_dec : forall n m, {max n m = n} + {max n m = m}. Proof. induction n; induction m; simpl in |- *; auto with arith. elim (IHn m); intro H; elim H; auto. -Qed. +Defined. Lemma max_case : forall n m (P:nat -> Type), P n -> P m -> P (max n m). Proof. induction n; simpl in |- *; auto with arith. induction m; intros; simpl in |- *; auto with arith. pattern (max n m) in |- *; apply IHn; auto with arith. -Qed. +Defined. Notation max_case2 := max_case (only parsing). diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 1e58d05d..157217ae 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* DecidableEquivalence := +Class DecidableEquivalence `(equiv : Equivalence A) := setoid_decidable : forall x y : A, decidable (x === y). (** The [EqDec] class gives a decision procedure for a particular setoid equality. *) -Class [ equiv : Equivalence A ] => EqDec := +Class EqDec A R {equiv : Equivalence R} := equiv_dec : forall x y : A, { x === y } + { x =/= y }. (** We define the [==] overloaded notation for deciding equality. It does not take precedence @@ -54,7 +52,7 @@ Open Local Scope program_scope. (** Invert the branches. *) -Program Definition nequiv_dec [ EqDec A ] (x y : A) : { x =/= y } + { x === y } := swap_sumbool (x == y). +Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } := swap_sumbool (x == y). (** Overloaded notation for inequality. *) @@ -62,10 +60,10 @@ Infix "<>" := nequiv_dec (no associativity, at level 70) : equiv_scope. (** Define boolean versions, losing the logical information. *) -Definition equiv_decb [ EqDec A ] (x y : A) : bool := +Definition equiv_decb `{EqDec A} (x y : A) : bool := if x == y then true else false. -Definition nequiv_decb [ EqDec A ] (x y : A) : bool := +Definition nequiv_decb `{EqDec A} (x y : A) : bool := negb (equiv_decb x y). Infix "==b" := equiv_decb (no associativity, at level 70). @@ -77,16 +75,13 @@ Require Import Coq.Arith.Peano_dec. (** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) -Program Instance nat_eq_eqdec : ! EqDec nat eq := - equiv_dec := eq_nat_dec. +Program Instance nat_eq_eqdec : EqDec nat eq := eq_nat_dec. Require Import Coq.Bool.Bool. -Program Instance bool_eqdec : ! EqDec bool eq := - equiv_dec := bool_dec. +Program Instance bool_eqdec : EqDec bool eq := bool_dec. -Program Instance unit_eqdec : ! EqDec unit eq := - equiv_dec x y := in_left. +Program Instance unit_eqdec : EqDec unit eq := λ x y, in_left. Next Obligation. Proof. @@ -94,39 +89,38 @@ Program Instance unit_eqdec : ! EqDec unit eq := reflexivity. Qed. -Program Instance prod_eqdec [ EqDec A eq, EqDec B eq ] : +Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) : ! EqDec (prod A B) eq := - equiv_dec x y := + { equiv_dec x y := let '(x1, x2) := x in let '(y1, y2) := y in if x1 == y1 then if x2 == y2 then in_left else in_right - else in_right. + else in_right }. Solve Obligations using unfold complement, equiv ; program_simpl. -Program Instance sum_eqdec [ EqDec A eq, EqDec B eq ] : - ! EqDec (sum A B) eq := +Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) : + EqDec (sum A B) eq := { equiv_dec x y := match x, y with | inl a, inl b => if a == b then in_left else in_right | inr a, inr b => if a == b then in_left else in_right | inl _, inr _ | inr _, inl _ => in_right - end. + end }. Solve Obligations using unfold complement, equiv ; program_simpl. -(** Objects of function spaces with countable domains like bool have decidable equality. *) - -Require Import Coq.Program.FunctionalExtensionality. +(** Objects of function spaces with countable domains like bool have decidable equality. + Proving the reflection requires functional extensionality though. *) -Program Instance bool_function_eqdec [ EqDec A eq ] : ! EqDec (bool -> A) eq := - equiv_dec f g := +Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq := + { equiv_dec f g := if f true == g true then if f false == g false then in_left else in_right - else in_right. + else in_right }. Solve Obligations using try red ; unfold equiv, complement ; program_simpl. @@ -138,8 +132,8 @@ Program Instance bool_function_eqdec [ EqDec A eq ] : ! EqDec (bool -> A) eq := Require Import List. -Program Instance list_eqdec [ eqa : EqDec A eq ] : ! EqDec (list A) eq := - equiv_dec := +Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq := + { equiv_dec := fix aux (x : list A) y { struct x } := match x, y with | nil, nil => in_left @@ -148,7 +142,7 @@ Program Instance list_eqdec [ eqa : EqDec A eq ] : ! EqDec (list A) eq := if aux tl tl' then in_left else in_right else in_right | _, _ => in_right - end. + end }. Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index d52eed47..5e5895ab 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* B | respectful R R' morph morph }. - Program Instance respecting_equiv [ eqa : Equivalence A R, eqb : Equivalence B R' ] : - Equivalence respecting - (fun (f g : respecting) => forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)). - + Program Instance respecting_equiv `(eqa : Equivalence A R, eqb : Equivalence B R') : + Equivalence (fun (f g : respecting eqa eqb) => forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)). + Solve Obligations using unfold respecting in * ; simpl_relation ; program_simpl. Next Obligation. @@ -131,13 +120,10 @@ End Respecting. (** The default equivalence on function spaces, with higher-priority than [eq]. *) -Program Instance pointwise_equivalence [ eqb : Equivalence B eqB ] : - Equivalence (A -> B) (pointwise_relation eqB) | 9. - - Solve Obligations using simpl_relation ; first [ reflexivity | (symmetry ; auto) ]. +Program Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) : + Equivalence (pointwise_relation A eqB) | 9. Next Obligation. Proof. - transitivity (y x0) ; auto. + transitivity (y a) ; auto. Qed. - diff --git a/theories/Classes/Functions.v b/theories/Classes/Functions.v index 4c844911..998f8cb7 100644 --- a/theories/Classes/Functions.v +++ b/theories/Classes/Functions.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* B) (RA ++> RB) f)) : Prop := +Class Injective `(m : Morphism (A -> B) (RA ++> RB) f) : Prop := injective : forall x y : A, RB (f x) (f y) -> RA x y. -Class ((m : Morphism (A -> B) (RA ++> RB) f)) => Surjective : Prop := +Class Surjective `(m : Morphism (A -> B) (RA ++> RB) f) : Prop := surjective : forall y, exists x : A, RB y (f x). -Definition Bijective ((m : Morphism (A -> B) (RA ++> RB) (f : A -> B))) := +Definition Bijective `(m : Morphism (A -> B) (RA ++> RB) (f : A -> B)) := Injective m /\ Surjective m. -Class MonoMorphism (( m : Morphism (A -> B) (eqA ++> eqB) )) := +Class MonoMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) := monic :> Injective m. -Class EpiMorphism ((m : Morphism (A -> B) (eqA ++> eqB))) := +Class EpiMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) := epic :> Surjective m. -Class IsoMorphism ((m : Morphism (A -> B) (eqA ++> eqB))) := - monomorphism :> MonoMorphism m ; epimorphism :> EpiMorphism m. +Class IsoMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) := + { monomorphism :> MonoMorphism m ; epimorphism :> EpiMorphism m }. -Class ((m : Morphism (A -> A) (eqA ++> eqA))) [ ! IsoMorphism m ] => AutoMorphism. +Class AutoMorphism `(m : Morphism (A -> A) (eqA ++> eqA)) {I : IsoMorphism m}. diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index e5f951d0..5df7a4ed 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -13,12 +13,18 @@ Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud 91405 Orsay, France *) -(* $Id: Init.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: Init.v 11709 2008-12-20 11:42:15Z msozeau $ *) (* Ltac typeclass_instantiation := typeclasses eauto || eauto. *) Tactic Notation "clapply" ident(c) := - eapply @c ; eauto with typeclass_instances. + eapply @c ; typeclasses eauto. + +(** Hints for the proof search: these combinators should be considered rigid. *) + +Require Import Coq.Program.Basics. + +Typeclasses Opaque id const flip compose arrow impl iff. (** The unconvertible typeclass, to test that two objects of the same type are actually different. *) @@ -27,8 +33,8 @@ Class Unconvertible (A : Type) (a b : A). Ltac unconvertible := match goal with - | |- @Unconvertible _ ?x ?y => conv x y ; fail 1 "Convertible" - | |- _ => apply Build_Unconvertible + | |- @Unconvertible _ ?x ?y => unify x y with typeclass_instances ; fail 1 "Convertible" + | |- _ => eapply Build_Unconvertible end. Hint Extern 0 (@Unconvertible _ _ _) => unconvertible : typeclass_instances. \ No newline at end of file diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index c2ae026d..86097a56 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -13,16 +13,15 @@ Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud 91405 Orsay, France *) -(* $Id: Morphisms.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: Morphisms.v 11709 2008-12-20 11:42:15Z msozeau $ *) + +Set Manual Implicit Arguments. Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. Require Import Coq.Relations.Relation_Definitions. Require Export Coq.Classes.RelationClasses. -Set Implicit Arguments. -Unset Strict Implicit. - (** * Morphisms. We now turn to the definition of [Morphism] and declare standard instances. @@ -32,13 +31,9 @@ Unset Strict Implicit. The relation [R] will be instantiated by [respectful] and [A] by an arrow type for usual morphisms. *) -Class Morphism A (R : relation A) (m : A) : Prop := +Class Morphism {A} (R : relation A) (m : A) : Prop := respect : R m m. -(** We make the type implicit, it can be infered from the relations. *) - -Implicit Arguments Morphism [A]. - (** Respectful morphisms. *) (** The fully dependent version, not used yet. *) @@ -53,7 +48,7 @@ Definition respectful_hetero (** The non-dependent version is an instance where we forget dependencies. *) -Definition respectful (A B : Type) +Definition respectful {A B : Type} (R : relation A) (R' : relation B) : relation (A -> B) := Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). @@ -75,13 +70,20 @@ Arguments Scope respectful [type_scope type_scope signature_scope signature_scop Open Local Scope signature_scope. -(** Pointwise lifting is just respect with leibniz equality on the left. *) +(** Dependent pointwise lifting of a relation on the range. *) + +Definition forall_relation {A : Type} {B : A -> Type} (sig : Π a : A, relation (B a)) : relation (Π x : A, B x) := + λ f g, Π a : A, sig a (f a) (g a). + +Arguments Scope forall_relation [type_scope type_scope signature_scope]. -Definition pointwise_relation {A B : Type} (R : relation B) : relation (A -> B) := - fun f g => forall x : A, R (f x) (g x). +(** Non-dependent pointwise lifting *) + +Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := + Eval compute in forall_relation (B:=λ _, B) (λ _, R). Lemma pointwise_pointwise A B (R : relation B) : - relation_equivalence (pointwise_relation R) (@eq A ==> R). + relation_equivalence (pointwise_relation A R) (@eq A ==> R). Proof. intros. split. simpl_relation. firstorder. Qed. (** We can build a PER on the Coq function space if we have PERs on the domain and @@ -91,24 +93,26 @@ Hint Unfold Reflexive : core. Hint Unfold Symmetric : core. Hint Unfold Transitive : core. -Program Instance respectful_per [ PER A (R : relation A), PER B (R' : relation B) ] : - PER (A -> B) (R ==> R'). +Typeclasses Opaque respectful pointwise_relation forall_relation. + +Program Instance respectful_per `(PER A (R : relation A), PER B (R' : relation B)) : + PER (R ==> R'). Next Obligation. Proof with auto. - assert(R x0 x0). + assert(R x0 x0). transitivity y0... symmetry... transitivity (y x0)... Qed. (** Subrelations induce a morphism on the identity. *) -Instance subrelation_id_morphism [ subrelation A Râ‚ Râ‚‚ ] : Morphism (Râ‚ ==> Râ‚‚) id. +Instance subrelation_id_morphism `(subrelation A Râ‚ Râ‚‚) : Morphism (Râ‚ ==> Râ‚‚) id. Proof. firstorder. Qed. (** The subrelation property goes through products as usual. *) -Instance morphisms_subrelation_respectful [ subl : subrelation A Râ‚‚ Râ‚, subr : subrelation B Sâ‚ Sâ‚‚ ] : +Instance morphisms_subrelation_respectful `(subl : subrelation A Râ‚‚ Râ‚, subr : subrelation B Sâ‚ Sâ‚‚) : subrelation (Râ‚ ==> Sâ‚) (Râ‚‚ ==> Sâ‚‚). Proof. simpl_relation. apply subr. apply H. apply subl. apply H0. Qed. @@ -119,8 +123,8 @@ Proof. simpl_relation. Qed. (** [Morphism] is itself a covariant morphism for [subrelation]. *) -Lemma subrelation_morphism [ mor : Morphism A Râ‚ m, unc : Unconvertible (relation A) Râ‚ Râ‚‚, - sub : subrelation A Râ‚ Râ‚‚ ] : Morphism Râ‚‚ m. +Lemma subrelation_morphism `(mor : Morphism A Râ‚ m, unc : Unconvertible (relation A) Râ‚ Râ‚‚, + sub : subrelation A Râ‚ Râ‚‚) : Morphism Râ‚‚ m. Proof. intros. apply sub. apply mor. Qed. @@ -153,14 +157,14 @@ Proof. firstorder. Qed. Instance iff_inverse_impl_subrelation : subrelation iff (inverse impl). Proof. firstorder. Qed. -Instance pointwise_subrelation [ sub : subrelation A R R' ] : - subrelation (pointwise_relation (A:=B) R) (pointwise_relation R') | 4. +Instance pointwise_subrelation {A} `(sub : subrelation B R R') : + subrelation (pointwise_relation A R) (pointwise_relation A R') | 4. Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed. (** The complement of a relation conserves its morphisms. *) Program Instance complement_morphism - [ mR : Morphism (A -> A -> Prop) (RA ==> RA ==> iff) R ] : + `(mR : Morphism (A -> A -> Prop) (RA ==> RA ==> iff) R) : Morphism (RA ==> RA ==> iff) (complement R). Next Obligation. @@ -173,7 +177,7 @@ Program Instance complement_morphism (** The [inverse] too, actually the [flip] instance is a bit more general. *) Program Instance flip_morphism - [ mor : Morphism (A -> B -> C) (RA ==> RB ==> RC) f ] : + `(mor : Morphism (A -> B -> C) (RA ==> RB ==> RC) f) : Morphism (RB ==> RA ==> RC) (flip f). Next Obligation. @@ -185,7 +189,7 @@ Program Instance flip_morphism contravariant in the first argument, covariant in the second. *) Program Instance trans_contra_co_morphism - [ Transitive A R ] : Morphism (R --> R ++> impl) R. + `(Transitive A R) : Morphism (R --> R ++> impl) R. Next Obligation. Proof with auto. @@ -196,7 +200,7 @@ Program Instance trans_contra_co_morphism (** Morphism declarations for partial applications. *) Program Instance trans_contra_inv_impl_morphism - [ Transitive A R ] : Morphism (R --> inverse impl) (R x) | 3. + `(Transitive A R) : Morphism (R --> inverse impl) (R x) | 3. Next Obligation. Proof with auto. @@ -204,7 +208,7 @@ Program Instance trans_contra_inv_impl_morphism Qed. Program Instance trans_co_impl_morphism - [ Transitive A R ] : Morphism (R ==> impl) (R x) | 3. + `(Transitive A R) : Morphism (R ==> impl) (R x) | 3. Next Obligation. Proof with auto. @@ -212,7 +216,7 @@ Program Instance trans_co_impl_morphism Qed. Program Instance trans_sym_co_inv_impl_morphism - [ PER A R ] : Morphism (R ==> inverse impl) (R x) | 2. + `(PER A R) : Morphism (R ==> inverse impl) (R x) | 2. Next Obligation. Proof with auto. @@ -220,7 +224,7 @@ Program Instance trans_sym_co_inv_impl_morphism Qed. Program Instance trans_sym_contra_impl_morphism - [ PER A R ] : Morphism (R --> impl) (R x) | 2. + `(PER A R) : Morphism (R --> impl) (R x) | 2. Next Obligation. Proof with auto. @@ -228,7 +232,7 @@ Program Instance trans_sym_contra_impl_morphism Qed. Program Instance per_partial_app_morphism - [ PER A R ] : Morphism (R ==> iff) (R x) | 1. + `(PER A R) : Morphism (R ==> iff) (R x) | 1. Next Obligation. Proof with auto. @@ -242,7 +246,7 @@ Program Instance per_partial_app_morphism to get an [R y z] goal. *) Program Instance trans_co_eq_inv_impl_morphism - [ Transitive A R ] : Morphism (R ==> (@eq A) ==> inverse impl) R | 2. + `(Transitive A R) : Morphism (R ==> (@eq A) ==> inverse impl) R | 2. Next Obligation. Proof with auto. @@ -251,7 +255,7 @@ Program Instance trans_co_eq_inv_impl_morphism (** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *) -Program Instance PER_morphism [ PER A R ] : Morphism (R ==> R ==> iff) R | 1. +Program Instance PER_morphism `(PER A R) : Morphism (R ==> R ==> iff) R | 1. Next Obligation. Proof with auto. @@ -261,7 +265,7 @@ Program Instance PER_morphism [ PER A R ] : Morphism (R ==> R ==> iff) R | 1. transitivity y... transitivity y0... symmetry... Qed. -Lemma symmetric_equiv_inverse [ Symmetric A R ] : relation_equivalence R (flip R). +Lemma symmetric_equiv_inverse `(Symmetric A R) : relation_equivalence R (flip R). Proof. firstorder. Qed. Program Instance compose_morphism A B C Râ‚€ Râ‚ Râ‚‚ : @@ -276,7 +280,7 @@ Program Instance compose_morphism A B C Râ‚€ Râ‚ Râ‚‚ : (** Coq functions are morphisms for leibniz equality, applied only if really needed. *) -Instance reflexive_eq_dom_reflexive (A : Type) [ Reflexive B R' ] : +Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') : Reflexive (@Logic.eq A ==> R'). Proof. simpl_relation. Qed. @@ -307,20 +311,20 @@ Qed. to set different priorities in different hint bases and select a particular hint database for resolution of a type class constraint.*) -Class MorphismProxy A (R : relation A) (m : A) : Prop := +Class MorphismProxy {A} (R : relation A) (m : A) : Prop := respect_proxy : R m m. Instance reflexive_morphism_proxy - [ Reflexive A R ] (x : A) : MorphismProxy R x | 1. + `(Reflexive A R) (x : A) : MorphismProxy R x | 1. Proof. firstorder. Qed. Instance morphism_morphism_proxy - [ Morphism A R x ] : MorphismProxy R x | 2. + `(Morphism A R x) : MorphismProxy R x | 2. Proof. firstorder. Qed. (** [R] is Reflexive, hence we can build the needed proof. *) -Lemma Reflexive_partial_app_morphism [ Morphism (A -> B) (R ==> R') m, MorphismProxy A R x ] : +Lemma Reflexive_partial_app_morphism `(Morphism (A -> B) (R ==> R') m, MorphismProxy A R x) : Morphism R' (m x). Proof. simpl_relation. Qed. @@ -399,38 +403,48 @@ Qed. (** Special-purpose class to do normalization of signatures w.r.t. inverse. *) -Class (A : Type) => Normalizes (m : relation A) (m' : relation A) : Prop := +Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop := normalizes : relation_equivalence m m'. -Instance inverse_respectful_norm : - ! Normalizes (A -> B) (inverse R ==> inverse R') (inverse (R ==> R')) . -Proof. firstorder. Qed. +(** Current strategy: add [inverse] everywhere and reduce using [subrelation] + afterwards. *) + +Lemma inverse_atom A R : Normalizes A R (inverse (inverse R)). +Proof. + firstorder. +Qed. -(* If not an inverse on the left, do a double inverse. *) +Lemma inverse_arrow `(NA : Normalizes A R (inverse R'''), NB : Normalizes B R' (inverse R'')) : + Normalizes (A -> B) (R ==> R') (inverse (R''' ==> R'')%signature). +Proof. unfold Normalizes. intros. + rewrite NA, NB. firstorder. +Qed. + +Ltac inverse := + match goal with + | [ |- Normalizes _ (respectful _ _) _ ] => eapply @inverse_arrow + | _ => eapply @inverse_atom + end. + +Hint Extern 1 (Normalizes _ _ _) => inverse : typeclass_instances. + +(** Treating inverse: can't make them direct instances as we + need at least a [flip] present in the goal. *) -Instance not_inverse_respectful_norm : - ! Normalizes (A -> B) (R ==> inverse R') (inverse (inverse R ==> R')) | 4. +Lemma inverse1 `(subrelation A R' R) : subrelation (inverse (inverse R')) R. Proof. firstorder. Qed. -Instance inverse_respectful_rec_norm [ Normalizes B R' (inverse R'') ] : - ! Normalizes (A -> B) (inverse R ==> R') (inverse (R ==> R'')). -Proof. red ; intros. - assert(r:=normalizes). - setoid_rewrite r. - setoid_rewrite inverse_respectful. - reflexivity. -Qed. +Lemma inverse2 `(subrelation A R R') : subrelation R (inverse (inverse R')). +Proof. firstorder. Qed. -(** Once we have normalized, we will apply this instance to simplify the problem. *) +Hint Extern 1 (subrelation (flip _) _) => eapply @inverse1 : typeclass_instances. +Hint Extern 1 (subrelation _ (flip _)) => eapply @inverse2 : typeclass_instances. -Definition morphism_inverse_morphism [ mor : Morphism A R m ] : Morphism (inverse R) m := mor. +(** Once we have normalized, we will apply this instance to simplify the problem. *) -Ltac morphism_inverse := - match goal with - [ |- @Morphism _ (flip _) _ ] => eapply @morphism_inverse_morphism - end. +Definition morphism_inverse_morphism `(mor : Morphism A R m) : Morphism (inverse R) m := mor. -Hint Extern 2 (@Morphism _ _ _) => morphism_inverse : typeclass_instances. +Hint Extern 2 (@Morphism _ (flip _) _) => eapply @morphism_inverse_morphism : typeclass_instances. (** Bootstrap !!! *) @@ -445,7 +459,7 @@ Proof. apply H0. Qed. -Lemma morphism_releq_morphism [ Normalizes A R R', Morphism _ R' m ] : Morphism R m. +Lemma morphism_releq_morphism `(Normalizes A R R', Morphism _ R' m) : Morphism R m. Proof. intros. @@ -467,7 +481,7 @@ Hint Extern 6 (@Morphism _ _ _) => morphism_normalization : typeclass_instances. (** Every reflexive relation gives rise to a morphism, only for immediately solving goals without variables. *) -Lemma reflexive_morphism [ Reflexive A R ] (x : A) +Lemma reflexive_morphism `{Reflexive A R} (x : A) : Morphism R x. Proof. firstorder. Qed. diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index ec62e12e..3bbd56cf 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.Morphisms") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* impl ==> impl) and. -(* Program Instance and_impl_iff_morphism : *) -(* Morphism (impl ==> iff ==> impl) and. *) - -(* Program Instance and_iff_impl_morphism : *) -(* Morphism (iff ==> impl ==> impl) and. *) - -(* Program Instance and_inverse_impl_iff_morphism : *) -(* Morphism (inverse impl ==> iff ==> inverse impl) and. *) - -(* Program Instance and_iff_inverse_impl_morphism : *) -(* Morphism (iff ==> inverse impl ==> inverse impl) and. *) - Program Instance and_iff_morphism : Morphism (iff ==> iff ==> iff) and. @@ -52,18 +39,6 @@ Program Instance and_iff_morphism : Program Instance or_impl_morphism : Morphism (impl ==> impl ==> impl) or. -(* Program Instance or_impl_iff_morphism : *) -(* Morphism (impl ==> iff ==> impl) or. *) - -(* Program Instance or_iff_impl_morphism : *) -(* Morphism (iff ==> impl ==> impl) or. *) - -(* Program Instance or_inverse_impl_iff_morphism : *) -(* Morphism (inverse impl ==> iff ==> inverse impl) or. *) - -(* Program Instance or_iff_inverse_impl_morphism : *) -(* Morphism (iff ==> inverse impl ==> inverse impl) or. *) - Program Instance or_iff_morphism : Morphism (iff ==> iff ==> iff) or. @@ -73,7 +48,7 @@ Program Instance iff_iff_iff_impl_morphism : Morphism (iff ==> iff ==> iff) impl (** Morphisms for quantifiers *) -Program Instance ex_iff_morphism {A : Type} : Morphism (pointwise_relation iff ==> iff) (@ex A). +Program Instance ex_iff_morphism {A : Type} : Morphism (pointwise_relation A iff ==> iff) (@ex A). Next Obligation. Proof. @@ -87,7 +62,7 @@ Program Instance ex_iff_morphism {A : Type} : Morphism (pointwise_relation iff = Qed. Program Instance ex_impl_morphism {A : Type} : - Morphism (pointwise_relation impl ==> impl) (@ex A). + Morphism (pointwise_relation A impl ==> impl) (@ex A). Next Obligation. Proof. @@ -96,7 +71,7 @@ Program Instance ex_impl_morphism {A : Type} : Qed. Program Instance ex_inverse_impl_morphism {A : Type} : - Morphism (pointwise_relation (inverse impl) ==> inverse impl) (@ex A). + Morphism (pointwise_relation A (inverse impl) ==> inverse impl) (@ex A). Next Obligation. Proof. @@ -105,7 +80,7 @@ Program Instance ex_inverse_impl_morphism {A : Type} : Qed. Program Instance all_iff_morphism {A : Type} : - Morphism (pointwise_relation iff ==> iff) (@all A). + Morphism (pointwise_relation A iff ==> iff) (@all A). Next Obligation. Proof. @@ -114,7 +89,7 @@ Program Instance all_iff_morphism {A : Type} : Qed. Program Instance all_impl_morphism {A : Type} : - Morphism (pointwise_relation impl ==> impl) (@all A). + Morphism (pointwise_relation A impl ==> impl) (@all A). Next Obligation. Proof. @@ -123,7 +98,7 @@ Program Instance all_impl_morphism {A : Type} : Qed. Program Instance all_inverse_impl_morphism {A : Type} : - Morphism (pointwise_relation (inverse impl) ==> inverse impl) (@all A). + Morphism (pointwise_relation A (inverse impl) ==> inverse impl) (@all A). Next Obligation. Proof. diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v index 1b389667..24b8d636 100644 --- a/theories/Classes/Morphisms_Relations.v +++ b/theories/Classes/Morphisms_Relations.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.Morphisms") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* pointwise_relation (A:=A) (pointwise_relation (A:=A) iff)) id. + Morphism (relation_equivalence ==> pointwise_relation A (pointwise_relation A iff)) id. Proof. intro. apply (predicate_equivalence_pointwise (cons A (cons A nil))). Qed. Instance subrelation_pointwise : - Morphism (subrelation ==> pointwise_relation (A:=A) (pointwise_relation (A:=A) impl)) id. + Morphism (subrelation ==> pointwise_relation A (pointwise_relation A impl)) id. Proof. intro. apply (predicate_implication_pointwise (cons A (cons A nil))). Qed. Lemma inverse_pointwise_relation A (R : relation A) : - relation_equivalence (pointwise_relation (inverse R)) (inverse (pointwise_relation (A:=A) R)). + relation_equivalence (pointwise_relation A (inverse R)) (inverse (pointwise_relation A R)). Proof. intros. split; firstorder. Qed. - - - diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 9a43a1ba..f95894be 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-name: "coqtop.byte"; coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.RelationClasses") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R x y -> False. +(** Opaque for proof-search. *) +Typeclasses Opaque complement. + (** These are convertible. *) Lemma complement_inverse : forall A (R : relation A), complement (inverse R) = inverse (complement R). @@ -39,64 +39,65 @@ Proof. reflexivity. Qed. Set Implicit Arguments. Unset Strict Implicit. -Class Reflexive A (R : relation A) := +Class Reflexive {A} (R : relation A) := reflexivity : forall x, R x x. -Class Irreflexive A (R : relation A) := +Class Irreflexive {A} (R : relation A) := irreflexivity :> Reflexive (complement R). -Class Symmetric A (R : relation A) := +Class Symmetric {A} (R : relation A) := symmetry : forall x y, R x y -> R y x. -Class Asymmetric A (R : relation A) := +Class Asymmetric {A} (R : relation A) := asymmetry : forall x y, R x y -> R y x -> False. -Class Transitive A (R : relation A) := +Class Transitive {A} (R : relation A) := transitivity : forall x y z, R x y -> R y z -> R x z. Hint Resolve @irreflexivity : ord. Unset Implicit Arguments. +(** A HintDb for relations. *) + +Ltac solve_relation := + match goal with + | [ |- ?R ?x ?x ] => reflexivity + | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H + end. + +Hint Extern 4 => solve_relation : relations. + (** We can already dualize all these properties. *) -Program Instance flip_Reflexive [ Reflexive A R ] : Reflexive (flip R) := - reflexivity := reflexivity (R:=R). +Program Instance flip_Reflexive `(Reflexive A R) : Reflexive (flip R) := + reflexivity (R:=R). -Program Instance flip_Irreflexive [ Irreflexive A R ] : Irreflexive (flip R) := - irreflexivity := irreflexivity (R:=R). +Program Instance flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) := + irreflexivity (R:=R). -Program Instance flip_Symmetric [ Symmetric A R ] : Symmetric (flip R). +Program Instance flip_Symmetric `(Symmetric A R) : Symmetric (flip R). - Solve Obligations using unfold flip ; program_simpl ; clapply Symmetric. + Solve Obligations using unfold flip ; intros ; tcapp symmetry ; assumption. -Program Instance flip_Asymmetric [ Asymmetric A R ] : Asymmetric (flip R). +Program Instance flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R). - Solve Obligations using program_simpl ; unfold flip in * ; intros ; clapply asymmetry. + Solve Obligations using program_simpl ; unfold flip in * ; intros ; typeclass_app asymmetry ; eauto. -Program Instance flip_Transitive [ Transitive A R ] : Transitive (flip R). +Program Instance flip_Transitive `(Transitive A R) : Transitive (flip R). - Solve Obligations using unfold flip ; program_simpl ; clapply transitivity. + Solve Obligations using unfold flip ; program_simpl ; typeclass_app transitivity ; eauto. -Program Instance Reflexive_complement_Irreflexive [ Reflexive A (R : relation A) ] +Program Instance Reflexive_complement_Irreflexive `(Reflexive A (R : relation A)) : Irreflexive (complement R). Next Obligation. - Proof. - unfold complement. - red. intros H. - intros H' ; apply H'. - apply reflexivity. - Qed. - + Proof. firstorder. Qed. -Program Instance complement_Symmetric [ Symmetric A (R : relation A) ] : Symmetric (complement R). +Program Instance complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R). Next Obligation. - Proof. - red ; intros H'. - apply (H (symmetry H')). - Qed. + Proof. firstorder. Qed. (** * Standard instances. *) @@ -147,52 +148,52 @@ Program Instance eq_Transitive : Transitive (@eq A). (** A [PreOrder] is both Reflexive and Transitive. *) -Class PreOrder A (R : relation A) : Prop := +Class PreOrder {A} (R : relation A) : Prop := { PreOrder_Reflexive :> Reflexive R ; - PreOrder_Transitive :> Transitive R. + PreOrder_Transitive :> Transitive R }. (** A partial equivalence relation is Symmetric and Transitive. *) -Class PER (carrier : Type) (pequiv : relation carrier) : Prop := - PER_Symmetric :> Symmetric pequiv ; - PER_Transitive :> Transitive pequiv. +Class PER {A} (R : relation A) : Prop := { + PER_Symmetric :> Symmetric R ; + PER_Transitive :> Transitive R }. (** Equivalence relations. *) -Class Equivalence (carrier : Type) (equiv : relation carrier) : Prop := - Equivalence_Reflexive :> Reflexive equiv ; - Equivalence_Symmetric :> Symmetric equiv ; - Equivalence_Transitive :> Transitive equiv. +Class Equivalence {A} (R : relation A) : Prop := { + Equivalence_Reflexive :> Reflexive R ; + Equivalence_Symmetric :> Symmetric R ; + Equivalence_Transitive :> Transitive R }. (** An Equivalence is a PER plus reflexivity. *) -Instance Equivalence_PER [ Equivalence A R ] : PER A R | 10 := - PER_Symmetric := Equivalence_Symmetric ; - PER_Transitive := Equivalence_Transitive. +Instance Equivalence_PER `(Equivalence A R) : PER R | 10 := + { PER_Symmetric := Equivalence_Symmetric ; + PER_Transitive := Equivalence_Transitive }. (** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) -Class Antisymmetric ((equ : Equivalence A eqA)) (R : relation A) := +Class Antisymmetric A eqA `{equ : Equivalence A eqA} (R : relation A) := antisymmetry : forall x y, R x y -> R y x -> eqA x y. -Program Instance flip_antiSymmetric {{Antisymmetric A eqA R}} : +Program Instance flip_antiSymmetric `(Antisymmetric A eqA R) : ! Antisymmetric A eqA (flip R). (** Leibinz equality [eq] is an equivalence relation. The instance has low priority as it is always applicable if only the type is constrained. *) -Program Instance eq_equivalence : Equivalence A (@eq A) | 10. +Program Instance eq_equivalence : Equivalence (@eq A) | 10. (** Logical equivalence [iff] is an equivalence relation. *) -Program Instance iff_equivalence : Equivalence Prop iff. +Program Instance iff_equivalence : Equivalence iff. (** We now develop a generalization of results on relations for arbitrary predicates. The resulting theory can be applied to homogeneous binary relations but also to arbitrary n-ary predicates. *) -Require Import List. +Require Import Coq.Lists.List. (* Notation " [ ] " := nil : list_scope. *) (* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *) @@ -273,7 +274,7 @@ Definition predicate_implication {l : list Type} := (** Notations for pointwise equivalence and implication of predicates. *) Infix "<∙>" := predicate_equivalence (at level 95, no associativity) : predicate_scope. -Infix "-∙>" := predicate_implication (at level 70) : predicate_scope. +Infix "-∙>" := predicate_implication (at level 70, right associativity) : predicate_scope. Open Local Scope predicate_scope. @@ -306,7 +307,7 @@ Notation "∙⊥∙" := false_predicate : predicate_scope. (** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *) Program Instance predicate_equivalence_equivalence : - Equivalence (predicate l) predicate_equivalence. + Equivalence (@predicate_equivalence l). Next Obligation. induction l ; firstorder. @@ -324,7 +325,7 @@ Program Instance predicate_equivalence_equivalence : Qed. Program Instance predicate_implication_preorder : - PreOrder (predicate l) predicate_implication. + PreOrder (@predicate_implication l). Next Obligation. induction l ; firstorder. @@ -356,10 +357,10 @@ Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relatio (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) Instance relation_equivalence_equivalence (A : Type) : - Equivalence (relation A) relation_equivalence. + Equivalence (@relation_equivalence A). Proof. intro A. exact (@predicate_equivalence_equivalence (cons A (cons A nil))). Qed. -Instance relation_implication_preorder : PreOrder (relation A) subrelation. +Instance relation_implication_preorder : PreOrder (@subrelation A). Proof. intro A. exact (@predicate_implication_preorder (cons A (cons A nil))). Qed. (** *** Partial Order. @@ -367,14 +368,14 @@ Proof. intro A. exact (@predicate_implication_preorder (cons A (cons A nil))). Q We give an equivalent definition, up-to an equivalence relation on the carrier. *) -Class [ equ : Equivalence A eqA, preo : PreOrder A R ] => PartialOrder := +Class PartialOrder A eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)). (** The equivalence proof is sufficient for proving that [R] must be a morphism for equivalence (see Morphisms). It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *) -Instance partial_order_antisym [ PartialOrder A eqA R ] : ! Antisymmetric A eqA R. +Instance partial_order_antisym `(PartialOrder A eqA R) : ! Antisymmetric A eqA R. Proof with auto. reduce_goal. pose proof partial_order_equivalence as poe. do 3 red in poe. apply <- poe. firstorder. @@ -389,3 +390,6 @@ Program Instance subrelation_partial_order : Proof. unfold relation_equivalence in *. firstorder. Qed. + +Typeclasses Opaque arrows predicate_implication predicate_equivalence + relation_equivalence pointwise_lifting. diff --git a/theories/Classes/SetoidAxioms.v b/theories/Classes/SetoidAxioms.v index 9264b6d2..305168ec 100644 --- a/theories/Classes/SetoidAxioms.v +++ b/theories/Classes/SetoidAxioms.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* x = y. +Axiom setoideq_eq : forall `{sa : Setoid a} (x y : a), x == y -> x = y. (** Application of the extensionality principle for setoids. *) diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index 178d5333..47f92ada 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Equivalence A equiv. - -Typeclasses unfold equiv. + setoid_equiv :> Equivalence equiv }. (* Too dangerous instance *) (* Program Instance [ eqa : Equivalence A eqA ] => *) @@ -40,13 +37,13 @@ Typeclasses unfold equiv. (** Shortcuts to make proof search easier. *) -Definition setoid_refl [ sa : Setoid A ] : Reflexive equiv. +Definition setoid_refl `(sa : Setoid A) : Reflexive equiv. Proof. typeclasses eauto. Qed. -Definition setoid_sym [ sa : Setoid A ] : Symmetric equiv. +Definition setoid_sym `(sa : Setoid A) : Symmetric equiv. Proof. typeclasses eauto. Qed. -Definition setoid_trans [ sa : Setoid A ] : Transitive equiv. +Definition setoid_trans `(sa : Setoid A) : Transitive equiv. Proof. typeclasses eauto. Qed. Existing Instance setoid_refl. @@ -58,8 +55,8 @@ Existing Instance setoid_trans. (* Program Instance eq_setoid : Setoid A := *) (* equiv := eq ; setoid_equiv := eq_equivalence. *) -Program Instance iff_setoid : Setoid Prop := - equiv := iff ; setoid_equiv := iff_equivalence. +Program Instance iff_setoid : Setoid Prop := + { equiv := iff ; setoid_equiv := iff_equivalence }. (** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) @@ -87,7 +84,7 @@ Ltac clsubst_nofail := Tactic Notation "clsubst" "*" := clsubst_nofail. -Lemma nequiv_equiv_trans : forall [ Setoid A ] (x y z : A), x =/= y -> y == z -> x =/= z. +Lemma nequiv_equiv_trans : forall `{Setoid A} (x y z : A), x =/= y -> y == z -> x =/= z. Proof with auto. intros; intro. assert(z == y) by (symmetry ; auto). @@ -95,7 +92,7 @@ Proof with auto. contradiction. Qed. -Lemma equiv_nequiv_trans : forall [ Setoid A ] (x y z : A), x == y -> y =/= z -> x =/= z. +Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z. Proof. intros; intro. assert(y == x) by (symmetry ; auto). @@ -122,23 +119,11 @@ Ltac setoidify := repeat setoidify_tac. (** Every setoid relation gives rise to a morphism, in fact every partial setoid does. *) -Program Definition setoid_morphism [ sa : Setoid A ] : Morphism (equiv ++> equiv ++> iff) equiv := - PER_morphism. - -(** Add this very useful instance in the database. *) - -Implicit Arguments setoid_morphism [[!sa]]. -Existing Instance setoid_morphism. - -Program Definition setoid_partial_app_morphism [ sa : Setoid A ] (x : A) : Morphism (equiv ++> iff) (equiv x) := - Reflexive_partial_app_morphism. - -Existing Instance setoid_partial_app_morphism. +Program Instance setoid_morphism `(sa : Setoid A) : Morphism (equiv ++> equiv ++> iff) equiv := + respect. -Definition type_eq : relation Type := - fun x y => x = y. - -Program Instance type_equivalence : Equivalence Type type_eq. +Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Morphism (equiv ++> iff) (equiv x) := + respect. Ltac morphism_tac := try red ; unfold arrow ; intros ; program_simpl ; try tauto. @@ -148,29 +133,12 @@ Ltac obligation_tactic ::= morphism_tac. using [iff_impl_id_morphism] if the proof is in [Prop] and [eq_arrow_id_morphism] if it is in Type. *) -Program Instance iff_impl_id_morphism : Morphism (iff ++> impl) Basics.id. - -(* Program Instance eq_arrow_id_morphism : ? Morphism (eq +++> arrow) id. *) - -(* Definition compose_respect (A B C : Type) (R : relation (A -> B)) (R' : relation (B -> C)) *) -(* (x y : A -> C) : Prop := forall (f : A -> B) (g : B -> C), R f f -> R' g g. *) - -(* Program Instance (A B C : Type) (R : relation (A -> B)) (R' : relation (B -> C)) *) -(* [ mg : ? Morphism R' g ] [ mf : ? Morphism R f ] => *) -(* compose_morphism : ? Morphism (compose_respect R R') (g o f). *) - -(* Next Obligation. *) -(* Proof. *) -(* apply (respect (m0:=mg)). *) -(* apply (respect (m0:=mf)). *) -(* assumption. *) -(* Qed. *) +Program Instance iff_impl_id_morphism : Morphism (iff ++> impl) id. (** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *) -Class PartialSetoid (carrier : Type) := - pequiv : relation carrier ; - pequiv_prf :> PER carrier pequiv. +Class PartialSetoid (A : Type) := + { pequiv : relation A ; pequiv_prf :> PER pequiv }. (** Overloaded notation for partial setoid equivalence. *) diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index 8a069343..bac64724 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* EqDec := +Class EqDec `(S : Setoid A) := equiv_dec : forall x y : A, { x == y } + { x =/= y }. (** We define the [==] overloaded notation for deciding equality. It does not take precedence @@ -52,7 +51,7 @@ Open Local Scope program_scope. (** Invert the branches. *) -Program Definition nequiv_dec [ EqDec A ] (x y : A) : { x =/= y } + { x == y } := swap_sumbool (x == y). +Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x == y } := swap_sumbool (x == y). (** Overloaded notation for inequality. *) @@ -60,10 +59,10 @@ Infix "=/=" := nequiv_dec (no associativity, at level 70). (** Define boolean versions, losing the logical information. *) -Definition equiv_decb [ EqDec A ] (x y : A) : bool := +Definition equiv_decb `{EqDec A} (x y : A) : bool := if x == y then true else false. -Definition nequiv_decb [ EqDec A ] (x y : A) : bool := +Definition nequiv_decb `{EqDec A} (x y : A) : bool := negb (equiv_decb x y). Infix "==b" := equiv_decb (no associativity, at level 70). @@ -75,19 +74,19 @@ Require Import Coq.Arith.Arith. (** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) -Program Instance eq_setoid A : Setoid A := - equiv := eq ; setoid_equiv := eq_equivalence. +Program Instance eq_setoid A : Setoid A | 10 := + { equiv := eq ; setoid_equiv := eq_equivalence }. Program Instance nat_eq_eqdec : EqDec (eq_setoid nat) := - equiv_dec := eq_nat_dec. + eq_nat_dec. Require Import Coq.Bool.Bool. Program Instance bool_eqdec : EqDec (eq_setoid bool) := - equiv_dec := bool_dec. + bool_dec. Program Instance unit_eqdec : EqDec (eq_setoid unit) := - equiv_dec x y := in_left. + λ x y, in_left. Next Obligation. Proof. @@ -95,8 +94,8 @@ Program Instance unit_eqdec : EqDec (eq_setoid unit) := reflexivity. Qed. -Program Instance prod_eqdec [ ! EqDec (eq_setoid A), ! EqDec (eq_setoid B) ] : EqDec (eq_setoid (prod A B)) := - equiv_dec x y := +Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) : EqDec (eq_setoid (prod A B)) := + λ x y, let '(x1, x2) := x in let '(y1, y2) := y in if x1 == y1 then @@ -108,10 +107,8 @@ Program Instance prod_eqdec [ ! EqDec (eq_setoid A), ! EqDec (eq_setoid B) ] : E (** Objects of function spaces with countable domains like bool have decidable equality. *) -Require Import Coq.Program.FunctionalExtensionality. - -Program Instance bool_function_eqdec [ ! EqDec (eq_setoid A) ] : EqDec (eq_setoid (bool -> A)) := - equiv_dec f g := +Program Instance bool_function_eqdec `(! EqDec (eq_setoid A)) : EqDec (eq_setoid (bool -> A)) := + λ f g, if f true == g true then if f false == g false then in_left else in_right diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v index 6398b125..caacc9ec 100644 --- a/theories/Classes/SetoidTactics.v +++ b/theories/Classes/SetoidTactics.v @@ -13,7 +13,7 @@ * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud * 91405 Orsay, France *) -(* $Id: SetoidTactics.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: SetoidTactics.v 11709 2008-12-20 11:42:15Z msozeau $ *) Require Export Coq.Classes.RelationClasses. Require Export Coq.Classes.Morphisms. @@ -45,11 +45,11 @@ Class DefaultRelation A (R : relation A). (** To search for the default relation, just call [default_relation]. *) -Definition default_relation [ DefaultRelation A R ] := R. +Definition default_relation `{DefaultRelation A R} := R. (** Every [Equivalence] gives a default relation, if no other is given (lowest priority). *) -Instance equivalence_default [ Equivalence A R ] : DefaultRelation R | 4. +Instance equivalence_default `(Equivalence A R) : DefaultRelation R | 4. (** The setoid_replace tactics in Ltac, defined in terms of default relations and the setoid_rewrite tactic. *) @@ -178,7 +178,7 @@ Ltac reverse_arrows x := end. Ltac default_add_morphism_tactic := - intros ; + unfold flip ; intros ; (try destruct_morphism) ; match goal with | [ |- (?x ==> ?y) _ _ ] => red_subst_eq_morphism (x ==> y) ; reverse_arrows (x ==> y) diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 05cd1892..df12166e 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapFacts.v 11359 2008-09-04 09:43:36Z notin $ *) +(* $Id: FMapFacts.v 11720 2008-12-28 07:12:15Z letouzey $ *) (** * Finite maps library *) @@ -20,9 +20,14 @@ Require Export FMapInterface. Set Implicit Arguments. Unset Strict Implicit. +Hint Extern 1 (Equivalence _) => constructor; congruence. + +Notation Leibniz := (@eq _) (only parsing). + + (** * Facts about weak maps *) -Module WFacts (E:DecidableType)(Import M:WSfun E). +Module WFacts_fun (E:DecidableType)(Import M:WSfun E). Notation eq_dec := E.eq_dec. Definition eqb x y := if eq_dec x y then true else false. @@ -32,6 +37,15 @@ Proof. destruct b; destruct b'; intuition. Qed. +Lemma eq_option_alt : forall (elt:Type)(o o':option elt), + o=o' <-> (forall e, o=Some e <-> o'=Some e). +Proof. +split; intros. +subst; split; auto. +destruct o; destruct o'; try rewrite H; auto. +symmetry; rewrite <- H; auto. +Qed. + Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), MapsTo x e m -> MapsTo x e' m -> e=e'. Proof. @@ -85,14 +99,10 @@ Qed. Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None. Proof. -intros. -generalize (find_mapsto_iff m x); destruct (find x m). -split; intros; try discriminate. -destruct H0. -exists e; rewrite H; auto. -split; auto. -intros; intros (e,H1). -rewrite H in H1; discriminate. +split; intros. +rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff. +split; intro H'; try discriminate. elim H; exists e; auto. +intros (e,He); rewrite find_mapsto_iff,H in He; discriminate. Qed. Lemma in_find_iff : forall m x, In x m <-> find x m <> None. @@ -334,21 +344,14 @@ Qed. Lemma find_o : forall m x y, E.eq x y -> find x m = find y m. Proof. -intros. -generalize (find_mapsto_iff m x) (find_mapsto_iff m y) (fun e => MapsTo_iff m e H). -destruct (find x m); destruct (find y m); intros. -rewrite <- H0; rewrite H2; rewrite H1; auto. -symmetry; rewrite <- H1; rewrite <- H2; rewrite H0; auto. -rewrite <- H0; rewrite H2; rewrite H1; auto. -auto. +intros. rewrite eq_option_alt. intro e. rewrite <- 2 find_mapsto_iff. +apply MapsTo_iff; auto. Qed. Lemma empty_o : forall x, find x (empty elt) = None. Proof. -intros. -case_eq (find x (empty elt)); intros; auto. -generalize (find_2 H). -rewrite empty_mapsto_iff; intuition. +intros. rewrite eq_option_alt. intro e. +rewrite <- find_mapsto_iff, empty_mapsto_iff; now intuition. Qed. Lemma empty_a : forall x, mem x (empty elt) = false. @@ -368,15 +371,12 @@ Qed. Lemma add_neq_o : forall m x y e, ~ E.eq x y -> find y (add x e m) = find y m. Proof. -intros. -case_eq (find y m); intros; auto with map. -case_eq (find y (add x e m)); intros; auto with map. -rewrite <- H0; symmetry. -apply find_1; apply add_3 with x e; auto with map. +intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. +apply add_neq_mapsto_iff; auto. Qed. Hint Resolve add_neq_o : map. -Lemma add_o : forall m x y e, +Lemma add_o : forall m x y e, find y (add x e m) = if eq_dec x y then Some e else find y m. Proof. intros; destruct (eq_dec x y); auto with map. @@ -404,45 +404,38 @@ Qed. Lemma remove_eq_o : forall m x y, E.eq x y -> find y (remove x m) = None. Proof. -intros. -generalize (remove_1 (m:=m) H). -generalize (find_mapsto_iff (remove x m) y). -destruct (find y (remove x m)); auto. -destruct 2. -exists e; rewrite H0; auto. +intros. rewrite eq_option_alt. intro e. +rewrite <- find_mapsto_iff, remove_mapsto_iff; now intuition. Qed. Hint Resolve remove_eq_o : map. -Lemma remove_neq_o : forall m x y, - ~ E.eq x y -> find y (remove x m) = find y m. +Lemma remove_neq_o : forall m x y, + ~ E.eq x y -> find y (remove x m) = find y m. Proof. -intros. -case_eq (find y m); intros; auto with map. -case_eq (find y (remove x m)); intros; auto with map. -rewrite <- H0; symmetry. -apply find_1; apply remove_3 with x; auto with map. +intros. rewrite eq_option_alt. intro e. +rewrite <- find_mapsto_iff, remove_neq_mapsto_iff; now intuition. Qed. Hint Resolve remove_neq_o : map. -Lemma remove_o : forall m x y, +Lemma remove_o : forall m x y, find y (remove x m) = if eq_dec x y then None else find y m. Proof. intros; destruct (eq_dec x y); auto with map. Qed. -Lemma remove_eq_b : forall m x y, +Lemma remove_eq_b : forall m x y, E.eq x y -> mem y (remove x m) = false. Proof. intros; rewrite mem_find_b; rewrite remove_eq_o; auto. Qed. -Lemma remove_neq_b : forall m x y, +Lemma remove_neq_b : forall m x y, ~ E.eq x y -> mem y (remove x m) = mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto. Qed. -Lemma remove_b : forall m x y, +Lemma remove_b : forall m x y, mem y (remove x m) = negb (eqb x y) && mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. @@ -506,7 +499,7 @@ Qed. Lemma map2_1bis : forall (m: t elt)(m': t elt') x (f:option elt->option elt'->option elt''), f None None = None -> - find x (map2 f m m') = f (find x m) (find x m'). + find x (map2 f m m') = f (find x m) (find x m'). Proof. intros. case_eq (find x m); intros. @@ -525,23 +518,16 @@ rewrite (find_1 H4) in H0; discriminate. rewrite (find_1 H4) in H1; discriminate. Qed. -Lemma elements_o : forall m x, +Lemma elements_o : forall m x, find x m = findA (eqb x) (elements m). Proof. -intros. -assert (forall e, find x m = Some e <-> InA (eq_key_elt (elt:=elt)) (x,e) (elements m)). - intros; rewrite <- find_mapsto_iff; apply elements_mapsto_iff. -assert (H0:=elements_3w m). -generalize (fun e => @findA_NoDupA _ _ _ E.eq_sym E.eq_trans eq_dec (elements m) x e H0). -fold (eqb x). -destruct (find x m); destruct (findA (eqb x) (elements m)); - simpl; auto; intros. -symmetry; rewrite <- H1; rewrite <- H; auto. -symmetry; rewrite <- H1; rewrite <- H; auto. -rewrite H; rewrite H1; auto. -Qed. - -Lemma elements_b : forall m x, +intros. rewrite eq_option_alt. intro e. +rewrite <- find_mapsto_iff, elements_mapsto_iff. +unfold eqb. +rewrite <- findA_NoDupA; intuition; try apply elements_3w; eauto. +Qed. + +Lemma elements_b : forall m x, mem x m = existsb (fun p => eqb x (fst p)) (elements m). Proof. intros. @@ -568,30 +554,41 @@ Qed. End BoolSpec. -Section Equalities. +Section Equalities. Variable elt:Type. + (** Another characterisation of [Equal] *) + +Lemma Equal_mapsto_iff : forall m1 m2 : t elt, + Equal m1 m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2). +Proof. +intros m1 m2. split; [intros Heq k e|intros Hiff]. +rewrite 2 find_mapsto_iff, Heq. split; auto. +intro k. rewrite eq_option_alt. intro e. +rewrite <- 2 find_mapsto_iff; auto. +Qed. + (** * Relations between [Equal], [Equiv] and [Equivb]. *) (** First, [Equal] is [Equiv] with Leibniz on elements. *) -Lemma Equal_Equiv : forall (m m' : t elt), +Lemma Equal_Equiv : forall (m m' : t elt), Equal m m' <-> Equiv (@Logic.eq elt) m m'. Proof. - unfold Equal, Equiv; split; intros. - split; intros. - rewrite in_find_iff, in_find_iff, H; intuition. - rewrite find_mapsto_iff in H0,H1; congruence. - destruct H. - specialize (H y). - specialize (H0 y). - do 2 rewrite in_find_iff in H. - generalize (find_mapsto_iff m y)(find_mapsto_iff m' y). - do 2 destruct find; auto; intros. - f_equal; apply H0; [rewrite H1|rewrite H2]; auto. - destruct H as [H _]; now elim H. - destruct H as [_ H]; now elim H. +intros. rewrite Equal_mapsto_iff. split; intros. +split. +split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto. +intros; apply MapsTo_fun with m k; auto; rewrite H; auto. +split; intros H'. +destruct H. +assert (Hin : In k m') by (rewrite <- H; exists e; auto). +destruct Hin as (e',He'). +rewrite (H0 k e e'); auto. +destruct H. +assert (Hin : In k m) by (rewrite H; exists e; auto). +destruct Hin as (e',He'). +rewrite <- (H0 k e' e); auto. Qed. (** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp] @@ -649,8 +646,8 @@ Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), Equal m m' -> Equal m' m'' -> Equal m m''. Proof. unfold Equal; congruence. Qed. -Definition Equal_ST : forall elt:Type, Setoid_Theory (t elt) (@Equal _). -Proof. +Definition Equal_ST : forall elt:Type, Equivalence (@Equal elt). +Proof. constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans]. Qed. @@ -660,8 +657,6 @@ Add Relation key E.eq transitivity proved by E.eq_trans as KeySetoid. -Typeclasses unfold key. - Implicit Arguments Equal [[elt]]. Add Parametric Relation (elt : Type) : (t elt) Equal @@ -670,52 +665,52 @@ Add Parametric Relation (elt : Type) : (t elt) Equal transitivity proved by (@Equal_trans elt) as EqualSetoid. -Add Parametric Morphism elt : (@In elt) with signature E.eq ==> Equal ==> iff as In_m. +Add Parametric Morphism elt : (@In elt) + with signature E.eq ==> Equal ==> iff as In_m. Proof. unfold Equal; intros k k' Hk m m' Hm. rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition. Qed. Add Parametric Morphism elt : (@MapsTo elt) - with signature E.eq ==> @Logic.eq _ ==> Equal ==> iff as MapsTo_m. + with signature E.eq ==> Leibniz ==> Equal ==> iff as MapsTo_m. Proof. unfold Equal; intros k k' Hk e m m' Hm. -rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; +rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; intuition. Qed. -Add Parametric Morphism elt : (@Empty elt) with signature Equal ==> iff as Empty_m. +Add Parametric Morphism elt : (@Empty elt) + with signature Equal ==> iff as Empty_m. Proof. unfold Empty; intros m m' Hm; intuition. rewrite <-Hm in H0; eauto. rewrite Hm in H0; eauto. Qed. -Add Parametric Morphism elt : (@is_empty elt) with signature Equal ==> @Logic.eq _ as is_empty_m. +Add Parametric Morphism elt : (@is_empty elt) + with signature Equal ==> Leibniz as is_empty_m. Proof. intros m m' Hm. rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition. Qed. -Add Parametric Morphism elt : (@mem elt) with signature E.eq ==> Equal ==> @Logic.eq _ as mem_m. +Add Parametric Morphism elt : (@mem elt) + with signature E.eq ==> Equal ==> Leibniz as mem_m. Proof. intros k k' Hk m m' Hm. rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition. Qed. -Add Parametric Morphism elt : (@find elt) with signature E.eq ==> Equal ==> @Logic.eq _ as find_m. +Add Parametric Morphism elt : (@find elt) + with signature E.eq ==> Equal ==> Leibniz as find_m. Proof. -intros k k' Hk m m' Hm. -generalize (find_mapsto_iff m k)(find_mapsto_iff m' k') - (not_find_in_iff m k)(not_find_in_iff m' k'); -do 2 destruct find; auto; intros. -rewrite <- H, Hk, Hm, H0; auto. -rewrite <- H1, Hk, Hm, H2; auto. -symmetry; rewrite <- H2, <-Hk, <-Hm, H1; auto. +intros k k' Hk m m' Hm. rewrite eq_option_alt. intro e. +rewrite <- 2 find_mapsto_iff, Hk, Hm. split; auto. Qed. -Add Parametric Morphism elt : (@add elt) with signature - E.eq ==> @Logic.eq _ ==> Equal ==> Equal as add_m. +Add Parametric Morphism elt : (@add elt) + with signature E.eq ==> Leibniz ==> Equal ==> Equal as add_m. Proof. intros k k' Hk e m m' Hm y. rewrite add_o, add_o; do 2 destruct eq_dec; auto. @@ -723,8 +718,8 @@ elim n; rewrite <-Hk; auto. elim n; rewrite Hk; auto. Qed. -Add Parametric Morphism elt : (@remove elt) with signature - E.eq ==> Equal ==> Equal as remove_m. +Add Parametric Morphism elt : (@remove elt) + with signature E.eq ==> Equal ==> Equal as remove_m. Proof. intros k k' Hk m m' Hm y. rewrite remove_o, remove_o; do 2 destruct eq_dec; auto. @@ -732,7 +727,8 @@ elim n; rewrite <-Hk; auto. elim n; rewrite Hk; auto. Qed. -Add Parametric Morphism elt elt' : (@map elt elt') with signature @Logic.eq _ ==> Equal ==> Equal as map_m. +Add Parametric Morphism elt elt' : (@map elt elt') + with signature Leibniz ==> Equal ==> Equal as map_m. Proof. intros f m m' Hm y. rewrite map_o, map_o, Hm; auto. @@ -743,25 +739,23 @@ Qed. (* old name: *) Notation not_find_mapsto_iff := not_find_in_iff. -End WFacts. +End WFacts_fun. -(** * Same facts for full maps *) +(** * Same facts for self-contained weak sets and for full maps *) -Module Facts (M:S). - Module D := OT_as_DT M.E. - Include WFacts D M. -End Facts. +Module WFacts (M:S) := WFacts_fun M.E M. +Module Facts := WFacts. + +(** * Additional Properties for weak maps -(** * Additional Properties for weak maps - Results about [fold], [elements], induction principles... *) -Module WProperties (E:DecidableType)(M:WSfun E). - Module Import F:=WFacts E M. +Module WProperties_fun (E:DecidableType)(M:WSfun E). + Module Import F:=WFacts_fun E M. Import M. - Section Elt. + Section Elt. Variable elt:Type. Definition Add x (e:elt) m m' := forall y, find y m' = find y (add x e m). @@ -769,6 +763,44 @@ Module WProperties (E:DecidableType)(M:WSfun E). Notation eqke := (@eq_key_elt elt). Notation eqk := (@eq_key elt). + (** Complements about InA, NoDupA and findA *) + + Lemma InA_eqke_eqk : forall k1 k2 e1 e2 l, + E.eq k1 k2 -> InA eqke (k1,e1) l -> InA eqk (k2,e2) l. + Proof. + intros k1 k2 e1 e2 l Hk. rewrite 2 InA_alt. + intros ((k',e') & (Hk',He') & H); simpl in *. + exists (k',e'); split; auto. + red; simpl; eauto. + Qed. + + Lemma NoDupA_eqk_eqke : forall l, NoDupA eqk l -> NoDupA eqke l. + Proof. + induction 1; auto. + constructor; auto. + destruct x as (k,e). + eauto using InA_eqke_eqk. + Qed. + + Lemma findA_rev : forall l k, NoDupA eqk l -> + findA (eqb k) l = findA (eqb k) (rev l). + Proof. + intros. + case_eq (findA (eqb k) l). + intros. symmetry. + unfold eqb. + rewrite <- findA_NoDupA, InA_rev, findA_NoDupA + by eauto using NoDupA_rev; eauto. + case_eq (findA (eqb k) (rev l)); auto. + intros e. + unfold eqb. + rewrite <- findA_NoDupA, InA_rev, findA_NoDupA + by eauto using NoDupA_rev. + intro Eq; rewrite Eq; auto. + Qed. + + (** * Elements *) + Lemma elements_Empty : forall m:t elt, Empty m <-> elements m = nil. Proof. intros. @@ -793,29 +825,268 @@ Module WProperties (E:DecidableType)(M:WSfun E). rewrite <-elements_Empty; apply empty_1. Qed. - Lemma fold_Empty : forall m (A:Type)(f:key->elt->A->A)(i:A), - Empty m -> fold f m i = i. + (** * Conversions between maps and association lists. *) + + Definition of_list (l : list (key*elt)) := + List.fold_right (fun p => add (fst p) (snd p)) (empty _) l. + + Definition to_list := elements. + + Lemma of_list_1 : forall l k e, + NoDupA eqk l -> + (MapsTo k e (of_list l) <-> InA eqke (k,e) l). + Proof. + induction l as [|(k',e') l IH]; simpl; intros k e Hnodup. + rewrite empty_mapsto_iff, InA_nil; intuition. + inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. + specialize (IH k e Hnodup'); clear Hnodup'. + rewrite add_mapsto_iff, InA_cons, <- IH. + unfold eq_key_elt at 1; simpl. + split; destruct 1 as [H|H]; try (intuition;fail). + destruct (eq_dec k k'); [left|right]; split; auto. + contradict Hnotin. + apply InA_eqke_eqk with k e; intuition. + Qed. + + Lemma of_list_1b : forall l k, + NoDupA eqk l -> + find k (of_list l) = findA (eqb k) l. + Proof. + induction l as [|(k',e') l IH]; simpl; intros k Hnodup. + apply empty_o. + inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. + specialize (IH k Hnodup'); clear Hnodup'. + rewrite add_o, IH. + unfold eqb; do 2 destruct eq_dec; auto; elim n; eauto. + Qed. + + Lemma of_list_2 : forall l, NoDupA eqk l -> + equivlistA eqke l (to_list (of_list l)). + Proof. + intros l Hnodup (k,e). + rewrite <- elements_mapsto_iff, of_list_1; intuition. + Qed. + + Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s. + Proof. + intros s k. + rewrite of_list_1b, elements_o; auto. + apply elements_3w. + Qed. + + (** * Fold *) + + (** ** Induction principles about fold contributed by S. Lescuyer *) + + (** In the following lemma, the step hypothesis is deliberately restricted + to the precise map m we are considering. *) + + Lemma fold_rec : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), + forall (i:A)(m:t elt), + (forall m, Empty m -> P m i) -> + (forall k e a m' m'', MapsTo k e m -> ~In k m' -> + Add k e m' m'' -> P m' a -> P m'' (f k e a)) -> + P m (fold f m i). + Proof. + intros A P f i m Hempty Hstep. + rewrite fold_1, <- fold_left_rev_right. + set (F:=fun (y : key * elt) (x : A) => f (fst y) (snd y) x). + set (l:=rev (elements m)). + assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> + Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). + intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. + revert H; unfold l; rewrite InA_rev, elements_mapsto_iff; auto. + assert (Hdup : NoDupA eqk l). + unfold l. apply NoDupA_rev; try red; eauto. apply elements_3w. + assert (Hsame : forall k, find k m = findA (eqb k) l). + intros k. unfold l. rewrite elements_o, findA_rev; auto. + apply elements_3w. + clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l. + (* empty *) + intros m Hsame; simpl. + apply Hempty. intros k e. + rewrite find_mapsto_iff, Hsame; simpl; discriminate. + (* step *) + intros m Hsame; destruct a as (k,e); simpl. + apply Hstep' with (of_list l); auto. + rewrite InA_cons; left; red; auto. + inversion_clear Hdup. contradict H. destruct H as (e',He'). + apply InA_eqke_eqk with k e'; auto. + rewrite <- of_list_1; auto. + intro k'. rewrite Hsame, add_o, of_list_1b. simpl. + unfold eqb. do 2 destruct eq_dec; auto; elim n; eauto. + inversion_clear Hdup; auto. + apply IHl. + intros; eapply Hstep'; eauto. + inversion_clear Hdup; auto. + intros; apply of_list_1b. inversion_clear Hdup; auto. + Qed. + + (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this + case, [P] must be compatible with equality of sets *) + + Theorem fold_rec_bis : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), + forall (i:A)(m:t elt), + (forall m m' a, Equal m m' -> P m a -> P m' a) -> + (P (empty _) i) -> + (forall k e a m', MapsTo k e m -> ~In k m' -> + P m' a -> P (add k e m') (f k e a)) -> + P m (fold f m i). + Proof. + intros A P f i m Pmorphism Pempty Pstep. + apply fold_rec; intros. + apply Pmorphism with (empty _); auto. intro k. rewrite empty_o. + case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff. + intro H'; elim (H k e'); auto. + apply Pmorphism with (add k e m'); try intro; auto. + Qed. + + Lemma fold_rec_nodep : + forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt), + P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) -> + P (fold f m i). + Proof. + intros; apply fold_rec_bis with (P:=fun _ => P); auto. + Qed. + + (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : + the step hypothesis must here be applicable anywhere. + At the same time, it looks more like an induction principle, + and hence can be easier to use. *) + + Lemma fold_rec_weak : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A)(i:A), + (forall m m' a, Equal m m' -> P m a -> P m' a) -> + P (empty _) i -> + (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) -> + forall m, P m (fold f m i). + Proof. + intros; apply fold_rec_bis; auto. + Qed. + + Lemma fold_rel : + forall (A B:Type)(R : A -> B -> Type) + (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B) + (m : t elt), + R i j -> + (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) -> + R (fold f m i) (fold g m j). + Proof. + intros A B R f g i j m Rempty Rstep. + do 2 rewrite fold_1, <- fold_left_rev_right. + set (l:=rev (elements m)). + assert (Rstep' : forall k e a b, InA eqke (k,e) l -> + R a b -> R (f k e a) (g k e b)) by + (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; auto). + clearbody l; clear Rstep m. + induction l; simpl; auto. + apply Rstep'; auto. + destruct a; simpl; rewrite InA_cons; left; red; auto. + Qed. + + (** From the induction principle on [fold], we can deduce some general + induction principles on maps. *) + + Lemma map_induction : + forall P : t elt -> Type, + (forall m, Empty m -> P m) -> + (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> + forall m, P m. + Proof. + intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. + Qed. + + Lemma map_induction_bis : + forall P : t elt -> Type, + (forall m m', Equal m m' -> P m -> P m') -> + P (empty _) -> + (forall x e m, ~In x m -> P m -> P (add x e m)) -> + forall m, P m. Proof. intros. - rewrite fold_1. - rewrite elements_Empty in H; rewrite H; simpl; auto. + apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. Qed. - Lemma NoDupA_eqk_eqke : forall l, NoDupA eqk l -> NoDupA eqke l. + (** [fold] can be used to reconstruct the same initial set. *) + + Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m (empty _)) m. Proof. - induction 1; auto. - constructor; auto. - contradict H. - destruct x as (x,y). - rewrite InA_alt in *; destruct H as ((a,b),((H1,H2),H3)); simpl in *. - exists (a,b); auto. + intros. + apply fold_rec with (P:=fun m acc => Equal acc m); auto with map. + intros m' Heq k'. + rewrite empty_o. + case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff. + intro; elim (Heq k' e'); auto. + intros k e a m' m'' _ _ Hadd Heq k'. + rewrite Hadd, 2 add_o, Heq; auto. + Qed. + + Section Fold_More. + + (** ** Additional properties of fold *) + + (** When a function [f] is compatible and allows transpositions, we can + compute [fold f] in any order. *) + + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A). + + (** This is more convenient than a [compat_op eqke ...]. + In fact, every [compat_op], [compat_bool], etc, should + become a [Morphism] someday. *) + Hypothesis Comp : Morphism (E.eq==>Leibniz==>eqA==>eqA) f. + + Lemma fold_init : + forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). + Proof. + intros. apply fold_rel with (R:=eqA); auto. + intros. apply Comp; auto. + Qed. + + Lemma fold_Empty : + forall m i, Empty m -> eqA (fold f m i) i. + Proof. + intros. apply fold_rec_nodep with (P:=fun a => eqA a i). + reflexivity. + intros. elim (H k e); auto. Qed. - Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - transpose eqA (fun y => f (fst y) (snd y)) -> - Equal m1 m2 -> + (** As noticed by P. Casteran, asking for the general [SetoidList.transpose] + here is too restrictive. Think for instance of [f] being [M.add] : + in general, [M.add k e (M.add k e' m)] is not equivalent to + [M.add k e' (M.add k e m)]. Fortunately, we will never encounter this + situation during a real [fold], since the keys received by this [fold] + are unique. Hence we can ask the transposition property to hold only + for non-equal keys. + + This idea could be push slightly further, by asking the transposition + property to hold only for (non-equal) keys living in the map given to + [fold]. Please contact us if you need such a version. + + FSets could also benefit from a restricted [transpose], but for this + case the gain is unclear. *) + + Definition transpose_neqkey := + forall k k' e e' a, ~E.eq k k' -> + eqA (f k e (f k' e' a)) (f k' e' (f k e a)). + + Hypothesis Tra : transpose_neqkey. + + Lemma fold_commutes : forall i m k e, ~In k m -> + eqA (fold f m (f k e i)) (f k e (fold f m i)). + Proof. + intros i m k e Hnotin. + apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto. + reflexivity. + intros. + transitivity (f k0 e0 (f k e b)). + apply Comp; auto. + apply Tra; auto. + contradict Hnotin; rewrite <- Hnotin; exists e0; auto. + Qed. + + Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 -> eqA (fold f m1 i) (fold f m2 i). Proof. assert (eqke_refl : forall p, eqke p p). @@ -826,22 +1097,26 @@ Module WProperties (E:DecidableType)(M:WSfun E). intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl. intuition; eauto; congruence. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. - apply fold_right_equivlistA with (eqA:=eqke) (eqB:=eqA); auto. + apply fold_right_equivlistA_restr with + (R:=fun p p' => ~eqk p p') (eqA:=eqke) (eqB:=eqA); auto. + intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; simpl in *; apply Comp; auto. + unfold eq_key; auto. + intros (k1,e1) (k2,e2) (k3,e3). unfold eq_key_elt, eq_key; simpl. + intuition eauto. + intros (k,e) (k',e'); unfold eq_key; simpl; auto. apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. + apply ForallList2_equiv1 with (eqA:=eqk); try red; eauto. + apply NoDupA_rev; try red; eauto. apply elements_3w. red; intros. do 2 rewrite InA_rev. destruct x; do 2 rewrite <- elements_mapsto_iff. do 2 rewrite find_mapsto_iff. - rewrite H1; split; auto. + rewrite H; split; auto. Qed. - Lemma fold_Add : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - transpose eqA (fun y =>f (fst y) (snd y)) -> - ~In x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (f x e (fold f m1 i)). + Lemma fold_Add : forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 -> + eqA (fold f m2 i) (f k e (fold f m1 i)). Proof. assert (eqke_refl : forall p, eqke p p). red; auto. @@ -852,52 +1127,68 @@ Module WProperties (E:DecidableType)(M:WSfun E). intuition; eauto; congruence. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. set (f':=fun y x0 => f (fst y) (snd y) x0) in *. - change (f x e (fold_right f' i (rev (elements m1)))) - with (f' (x,e) (fold_right f' i (rev (elements m1)))). - apply fold_right_add with (eqA:=eqke)(eqB:=eqA); auto. + change (f k e (fold_right f' i (rev (elements m1)))) + with (f' (k,e) (fold_right f' i (rev (elements m1)))). + apply fold_right_add_restr with + (R:=fun p p'=>~eqk p p')(eqA:=eqke)(eqB:=eqA); auto. + intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *. apply Comp; auto. + + unfold eq_key; auto. + intros (k1,e1) (k2,e2) (k3,e3). unfold eq_key_elt, eq_key; simpl. + intuition eauto. + unfold f'; intros (k1,e1) (k2,e2); unfold eq_key; simpl; auto. apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. + apply ForallList2_equiv1 with (eqA:=eqk); try red; eauto. + apply NoDupA_rev; try red; eauto. apply elements_3w. rewrite InA_rev. - contradict H1. + contradict H. exists e. rewrite elements_mapsto_iff; auto. intros a. - rewrite InA_cons; do 2 rewrite InA_rev; + rewrite InA_cons; do 2 rewrite InA_rev; destruct a as (a,b); do 2 rewrite <- elements_mapsto_iff. do 2 rewrite find_mapsto_iff; unfold eq_key_elt; simpl. - rewrite H2. + rewrite H0. rewrite add_o. - destruct (eq_dec x a); intuition. - inversion H3; auto. + destruct (eq_dec k a); intuition. + inversion H1; auto. f_equal; auto. - elim H1. + elim H. exists b; apply MapsTo_1 with a; auto with map. elim n; auto. Qed. - Lemma cardinal_fold : forall m : t elt, + Lemma fold_add : forall m k e i, ~In k m -> + eqA (fold f (add k e m) i) (f k e (fold f m i)). + Proof. + intros. apply fold_Add; try red; auto. + Qed. + + End Fold_More. + + (** * Cardinal *) + + Lemma cardinal_fold : forall m : t elt, cardinal m = fold (fun _ _ => S) m 0. Proof. intros; rewrite cardinal_1, fold_1. symmetry; apply fold_left_length; auto. Qed. - Lemma cardinal_Empty : forall m : t elt, + Lemma cardinal_Empty : forall m : t elt, Empty m <-> cardinal m = 0. Proof. intros. rewrite cardinal_1, elements_Empty. destruct (elements m); intuition; discriminate. Qed. - - Lemma Equal_cardinal : forall m m' : t elt, + + Lemma Equal_cardinal : forall m m' : t elt, Equal m m' -> cardinal m = cardinal m'. Proof. intros; do 2 rewrite cardinal_fold. - apply fold_Equal with (eqA:=@eq _); auto. - constructor; auto; congruence. - red; auto. - red; auto. + apply fold_Equal with (eqA:=Leibniz); compute; auto. Qed. Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0. @@ -910,10 +1201,7 @@ Module WProperties (E:DecidableType)(M:WSfun E). Proof. intros; do 2 rewrite cardinal_fold. change S with ((fun _ _ => S) x e). - apply fold_Add; auto. - constructor; intros; auto; congruence. - red; simpl; auto. - red; simpl; auto. + apply fold_Add with (eqA:=Leibniz); compute; auto. Qed. Lemma cardinal_inv_1 : forall m : t elt, @@ -943,27 +1231,16 @@ Module WProperties (E:DecidableType)(M:WSfun E). eauto. Qed. - Lemma map_induction : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - apply X; apply cardinal_inv_1; auto. + (** * Additional notions over maps *) - destruct (cardinal_inv_2 (sym_eq Heqn)) as ((x,e),H0); simpl in *. - assert (Add x e (remove x m) m). - red; intros. - rewrite add_o; rewrite remove_o; destruct (eq_dec x y); eauto with map. - apply X0 with (remove x m) x e; auto with map. - apply IHn; auto with map. - assert (S n = S (cardinal (remove x m))). - rewrite Heqn; eapply cardinal_2; eauto with map. - inversion H1; auto with map. - Qed. + Definition Disjoint (m m' : t elt) := + forall k, ~(In k m /\ In k m'). + + Definition Partition (m m1 m2 : t elt) := + Disjoint m1 m2 /\ + (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2). - (** * Let's emulate some functions not present in the interface *) + (** * Emulation of some functions lacking in the interface *) Definition filter (f : key -> elt -> bool)(m : t elt) := fold (fun k e m => if f k e then add k e m else m) m (empty _). @@ -977,122 +1254,411 @@ Module WProperties (E:DecidableType)(M:WSfun E). Definition partition (f : key -> elt -> bool)(m : t elt) := (filter f m, filter (fun k e => negb (f k e)) m). + (** [update] adds to [m1] all the bindings of [m2]. It can be seen as + an [union] operator which gives priority to its 2nd argument + in case of binding conflit. *) + + Definition update (m1 m2 : t elt) := fold (@add _) m2 m1. + + (** [restrict] keeps from [m1] only the bindings whose key is in [m2]. + It can be seen as an [inter] operator, with priority to its 1st argument + in case of binding conflit. *) + + Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1. + + (** [diff] erases from [m1] all bindings whose key is in [m2]. *) + + Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1. + Section Specs. Variable f : key -> elt -> bool. - Hypothesis Hf : forall e, compat_bool E.eq (fun k => f k e). + Hypothesis Hf : Morphism (E.eq==>Leibniz==>Leibniz) f. - Lemma filter_iff : forall m k e, + Lemma filter_iff : forall m k e, MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. Proof. - unfold filter; intros. - rewrite fold_1. - rewrite <- fold_left_rev_right. - rewrite (elements_mapsto_iff m). - rewrite <- (InA_rev eqke (k,e) (elements m)). - assert (NoDupA eqk (rev (elements m))). - apply NoDupA_rev; auto; try apply elements_3w; auto. - intros (k1,e1); compute; auto. - intros (k1,e1)(k2,e2); compute; auto. - intros (k1,e1)(k2,e2)(k3,e3); compute; eauto. - induction (rev (elements m)); simpl; auto. - - rewrite empty_mapsto_iff. - intuition. - inversion H1. - - destruct a as (k',e'); simpl. - inversion_clear H. - case_eq (f k' e'); intros; simpl; - try rewrite add_mapsto_iff; rewrite IHl; clear IHl; intuition. - constructor; red; auto. - rewrite (Hf e' H2),H4 in H; auto. - inversion_clear H3. - compute in H2; destruct H2; auto. - destruct (E.eq_dec k' k); auto. - elim H0. - rewrite InA_alt in *; destruct H2 as (w,Hw); exists w; intuition. - red in H2; red; simpl in *; intuition. - rewrite e0; auto. - inversion_clear H3; auto. - compute in H2; destruct H2. - rewrite (Hf e H2),H3,H in H4; discriminate. + unfold filter. + set (f':=fun k e m => if f k e then add k e m else m). + intro m. pattern m, (fold f' m (empty _)). apply fold_rec. + + intros m' Hm' k e. rewrite empty_mapsto_iff. intuition. + elim (Hm' k e); auto. + + intros k e acc m1 m2 Hke Hn Hadd IH k' e'. + change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd. + unfold f'; simpl. + case_eq (f k e); intros Hfke; simpl; + rewrite !add_mapsto_iff, IH; clear IH; intuition. + rewrite <- Hfke; apply Hf; auto. + destruct (eq_dec k k') as [Hk|Hk]; [left|right]; auto. + elim Hn; exists e'; rewrite Hk; auto. + assert (f k e = f k' e') by (apply Hf; auto). congruence. Qed. - + Lemma for_all_iff : forall m, for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true). Proof. - cut (forall m : t elt, - for_all f m = true <-> - (forall k e, InA eqke (k,e) (rev (elements m)) -> f k e = true)). - intros; rewrite H; split; intros. - apply H0; rewrite InA_rev, <- elements_mapsto_iff; auto. - apply H0; rewrite InA_rev, <- elements_mapsto_iff in H1; auto. - - unfold for_all; intros. - rewrite fold_1. - rewrite <- fold_left_rev_right. - assert (NoDupA eqk (rev (elements m))). - apply NoDupA_rev; auto; try apply elements_3w; auto. - intros (k1,e1); compute; auto. - intros (k1,e1)(k2,e2); compute; auto. - intros (k1,e1)(k2,e2)(k3,e3); compute; eauto. - induction (rev (elements m)); simpl; auto. - - intuition. - inversion H1. - - destruct a as (k,e); simpl. - inversion_clear H. - case_eq (f k e); intros; simpl; - try rewrite IHl; clear IHl; intuition. - inversion_clear H3; auto. - compute in H4; destruct H4. - rewrite (Hf e0 H3), H4; auto. - rewrite <-H, <-(H2 k e); auto. - constructor; red; auto. + unfold for_all. + set (f':=fun k e b => if f k e then b else false). + intro m. pattern m, (fold f' m true). apply fold_rec. + + intros m' Hm'. split; auto. intros _ k e Hke. elim (Hm' k e); auto. + + intros k e b m1 m2 _ Hn Hadd IH. clear m. + change (Equal m2 (add k e m1)) in Hadd. + unfold f'; simpl. case_eq (f k e); intros Hfke. + (* f k e = true *) + rewrite IH. clear IH. split; intros Hmapsto k' e' Hke'. + rewrite Hadd, add_mapsto_iff in Hke'. + destruct Hke' as [(?,?)|(?,?)]; auto. + rewrite <- Hfke; apply Hf; auto. + apply Hmapsto. rewrite Hadd, add_mapsto_iff; right; split; auto. + contradict Hn; exists e'; rewrite Hn; auto. + (* f k e = false *) + split; intros H; try discriminate. + rewrite <- Hfke. apply H. + rewrite Hadd, add_mapsto_iff; auto. Qed. - + Lemma exists_iff : forall m, - exists_ f m = true <-> + exists_ f m = true <-> (exists p, MapsTo (fst p) (snd p) m /\ f (fst p) (snd p) = true). Proof. - cut (forall m : t elt, - exists_ f m = true <-> - (exists p, InA eqke p (rev (elements m)) - /\ f (fst p) (snd p) = true)). - intros; rewrite H; split; intros. - destruct H0 as ((k,e),Hke); exists (k,e). - rewrite InA_rev, <-elements_mapsto_iff in Hke; auto. - destruct H0 as ((k,e),Hke); exists (k,e). - rewrite InA_rev, <-elements_mapsto_iff; auto. - unfold exists_; intros. - rewrite fold_1. - rewrite <- fold_left_rev_right. - assert (NoDupA eqk (rev (elements m))). - apply NoDupA_rev; auto; try apply elements_3w; auto. - intros (k1,e1); compute; auto. - intros (k1,e1)(k2,e2); compute; auto. - intros (k1,e1)(k2,e2)(k3,e3); compute; eauto. - induction (rev (elements m)); simpl; auto. - - intuition; try discriminate. - destruct H0 as ((k,e),(Hke,_)); inversion Hke. - - destruct a as (k,e); simpl. - inversion_clear H. - case_eq (f k e); intros; simpl; - try rewrite IHl; clear IHl; intuition. + unfold exists_. + set (f':=fun k e b => if f k e then true else b). + intro m. pattern m, (fold f' m false). apply fold_rec. + + intros m' Hm'. split; try (intros; discriminate). + intros ((k,e),(Hke,_)); simpl in *. elim (Hm' k e); auto. + + intros k e b m1 m2 _ Hn Hadd IH. clear m. + change (Equal m2 (add k e m1)) in Hadd. + unfold f'; simpl. case_eq (f k e); intros Hfke. + (* f k e = true *) + split; [intros _|auto]. exists (k,e); simpl; split; auto. - constructor; red; auto. - destruct H2 as ((k',e'),(Hke',Hf')); exists (k',e'); simpl; auto. - destruct H2 as ((k',e'),(Hke',Hf')); simpl in *. - inversion_clear Hke'. - compute in H2; destruct H2. - rewrite (Hf e' H2), H3,H in Hf'; discriminate. + rewrite Hadd, add_mapsto_iff; auto. + (* f k e = false *) + rewrite IH. clear IH. split; intros ((k',e'),(Hke1,Hke2)); simpl in *. + exists (k',e'); simpl; split; auto. + rewrite Hadd, add_mapsto_iff; right; split; auto. + contradict Hn. exists e'; rewrite Hn; auto. + rewrite Hadd, add_mapsto_iff in Hke1. destruct Hke1 as [(?,?)|(?,?)]. + assert (f k' e' = f k e) by (apply Hf; auto). congruence. exists (k',e'); auto. Qed. + End Specs. + Lemma Disjoint_alt : forall m m', + Disjoint m m' <-> + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False). + Proof. + unfold Disjoint; split. + intros H k v v' H1 H2. + apply H with k; split. + exists v; trivial. + exists v'; trivial. + intros H k ((v,Hv),(v',Hv')). + eapply H; eauto. + Qed. + + Section Partition. + Variable f : key -> elt -> bool. + Hypothesis Hf : Morphism (E.eq==>Leibniz==>Leibniz) f. + + Lemma partition_iff_1 : forall m m1 k e, + m1 = fst (partition f m) -> + (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true). + Proof. + unfold partition; simpl; intros. subst m1. + apply filter_iff; auto. + Qed. + + Lemma partition_iff_2 : forall m m2 k e, + m2 = snd (partition f m) -> + (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false). + Proof. + unfold partition; simpl; intros. subst m2. + rewrite filter_iff. + split; intros (H,H'); split; auto. + destruct (f k e); simpl in *; auto. + rewrite H'; auto. + repeat red; intros. f_equal. apply Hf; auto. + Qed. + + Lemma partition_Partition : forall m m1 m2, + partition f m = (m1,m2) -> Partition m m1 m2. + Proof. + intros. split. + rewrite Disjoint_alt. intros k e e'. + rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) + by (rewrite H; auto). + intros (U,V) (W,Z). rewrite <- (MapsTo_fun U W) in Z; congruence. + intros k e. + rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) + by (rewrite H; auto). + destruct (f k e); intuition. + Qed. + + End Partition. + + Lemma Partition_In : forall m m1 m2 k, + Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}. + Proof. + intros m m1 m2 k Hm Hk. + destruct (In_dec m1 k) as [H|H]; [left|right]; auto. + destruct Hm as (Hm,Hm'). + destruct Hk as (e,He); rewrite Hm' in He; destruct He. + elim H; exists e; auto. + exists e; auto. + Defined. + + Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1. + Proof. + intros m1 m2 H k (H1,H2). elim (H k); auto. + Qed. + + Lemma Partition_sym : forall m m1 m2, + Partition m m1 m2 -> Partition m m2 m1. + Proof. + intros m m1 m2 (H,H'); split. + apply Disjoint_sym; auto. + intros; rewrite H'; intuition. + Qed. + + Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 -> + (Empty m <-> (Empty m1 /\ Empty m2)). + Proof. + intros m m1 m2 (Hdisj,Heq). split. + intro He. + split; intros k e Hke; elim (He k e); rewrite Heq; auto. + intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke. + elim (He1 k e); auto. + elim (He2 k e); auto. + Qed. + + Lemma Partition_Add : + forall m m' x e , ~In x m -> Add x e m m' -> + forall m1 m2, Partition m' m1 m2 -> + exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/ + Add x e m3 m2 /\ Partition m m1 m3). + Proof. + unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor). + assert (Heq : Equal m (remove x m')). + change (Equal m' (add x e m)) in Hadd. rewrite Hadd. + intro k. rewrite remove_o, add_o. + destruct eq_dec as [He|Hne]; auto. + rewrite <- He, <- not_find_in_iff; auto. + assert (H : MapsTo x e m'). + change (Equal m' (add x e m)) in Hadd; rewrite Hadd. + apply add_1; auto. + rewrite Hor in H; destruct H. + + (* first case : x in m1 *) + exists (remove x m1); left. split; [|split]. + (* add *) + change (Equal m1 (add x e (remove x m1))). + intro k. + rewrite add_o, remove_o. + destruct eq_dec as [He|Hne]; auto. + rewrite <- He; apply find_1; auto. + (* disjoint *) + intros k (H1,H2). elim (Hdisj k). split; auto. + rewrite remove_in_iff in H1; destruct H1; auto. + (* mapsto *) + intros k' e'. + rewrite Heq, 2 remove_mapsto_iff, Hor. + intuition. + elim (Hdisj x); split; [exists e|exists e']; auto. + apply MapsTo_1 with k'; auto. + + (* second case : x in m2 *) + exists (remove x m2); right. split; [|split]. + (* add *) + change (Equal m2 (add x e (remove x m2))). + intro k. + rewrite add_o, remove_o. + destruct eq_dec as [He|Hne]; auto. + rewrite <- He; apply find_1; auto. + (* disjoint *) + intros k (H1,H2). elim (Hdisj k). split; auto. + rewrite remove_in_iff in H2; destruct H2; auto. + (* mapsto *) + intros k' e'. + rewrite Heq, 2 remove_mapsto_iff, Hor. + intuition. + elim (Hdisj x); split; [exists e'|exists e]; auto. + apply MapsTo_1 with k'; auto. + Qed. + + Lemma Partition_fold : + forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), + Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + transpose_neqkey eqA f -> + forall m m1 m2 i, + Partition m m1 m2 -> + eqA (fold f m i) (fold f m1 (fold f m2 i)). + Proof. + intros A eqA st f Comp Tra. + induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction. + + intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto. + rewrite (Partition_Empty Hp) in Hm. destruct Hm. + rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity. + + intros m1 m2 i Hp. + destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]). + (* fst case: m3 is (k,e)::m1 *) + assert (~In k m3). + contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. + transitivity (f k e (fold f m i)). + apply fold_Add with (eqA:=eqA); auto. + symmetry. + transitivity (f k e (fold f m3 (fold f m2 i))). + apply fold_Add with (eqA:=eqA); auto. + apply Comp; auto. + symmetry; apply IH; auto. + (* snd case: m3 is (k,e)::m2 *) + assert (~In k m3). + contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. + assert (~In k m1). + contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. + transitivity (f k e (fold f m i)). + apply fold_Add with (eqA:=eqA); auto. + transitivity (f k e (fold f m1 (fold f m3 i))). + apply Comp; auto using IH. + transitivity (fold f m1 (f k e (fold f m3 i))). + symmetry. + apply fold_commutes with (eqA:=eqA); auto. + apply fold_init with (eqA:=eqA); auto. + symmetry. + apply fold_Add with (eqA:=eqA); auto. + Qed. + + Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 -> + cardinal m = cardinal m1 + cardinal m2. + Proof. + intros. + rewrite (cardinal_fold m), (cardinal_fold m1). + set (f:=fun (_:key)(_:elt)=>S). + setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). + rewrite <- cardinal_fold. + intros. apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. + apply Partition_fold with (eqA:=@Logic.eq _); try red; auto. + compute; auto. + Qed. + + Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> + let f := fun k (_:elt) => mem k m1 in + Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). + Proof. + intros m m1 m2 Hm f. + assert (Hf : Morphism (E.eq==>Leibniz==>Leibniz) f). + intros k k' Hk e e' _; unfold f; rewrite Hk; auto. + set (m1':= fst (partition f m)). + set (m2':= snd (partition f m)). + split; rewrite Equal_mapsto_iff; intros k e. + rewrite (@partition_iff_1 f Hf m m1') by auto. + unfold f. + rewrite <- mem_in_iff. + destruct Hm as (Hm,Hm'). + rewrite Hm'. + intuition. + exists e; auto. + elim (Hm k); split; auto; exists e; auto. + rewrite (@partition_iff_2 f Hf m m2') by auto. + unfold f. + rewrite <- not_mem_in_iff. + destruct Hm as (Hm,Hm'). + rewrite Hm'. + intuition. + elim (Hm k); split; auto; exists e; auto. + elim H1; exists e; auto. + Qed. + + Lemma update_mapsto_iff : forall m m' k e, + MapsTo k e (update m m') <-> + (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')). + Proof. + unfold update. + intros m m'. + pattern m', (fold (@add _) m' m). apply fold_rec. + + intros m0 Hm0 k e. + assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto). + intuition. + elim (Hm0 k e); auto. + + intros k e m0 m1 m2 _ Hn Hadd IH k' e'. + change (Equal m2 (add k e m1)) in Hadd. + rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition. + Qed. + + Lemma update_dec : forall m m' k e, MapsTo k e (update m m') -> + { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}. + Proof. + intros m m' k e H. rewrite update_mapsto_iff in H. + destruct (In_dec m' k) as [H'|H']; [left|right]; intuition. + elim H'; exists e; auto. + Defined. + + Lemma update_in_iff : forall m m' k, + In k (update m m') <-> In k m \/ In k m'. + Proof. + intros m m' k. split. + intros (e,H); rewrite update_mapsto_iff in H. + destruct H; [right|left]; exists e; intuition. + destruct (In_dec m' k) as [H|H]. + destruct H as (e,H). intros _; exists e. + rewrite update_mapsto_iff; left; auto. + destruct 1 as [H'|H']; [|elim H; auto]. + destruct H' as (e,H'). exists e. + rewrite update_mapsto_iff; right; auto. + Qed. + + Lemma diff_mapsto_iff : forall m m' k e, + MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'. + Proof. + intros m m' k e. + unfold diff. + rewrite filter_iff. + intuition. + rewrite mem_1 in *; auto; discriminate. + intros ? ? Hk _ _ _; rewrite Hk; auto. + Qed. + + Lemma diff_in_iff : forall m m' k, + In k (diff m m') <-> In k m /\ ~In k m'. + Proof. + intros m m' k. split. + intros (e,H); rewrite diff_mapsto_iff in H. + destruct H; split; auto. exists e; auto. + intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto. + Qed. + + Lemma restrict_mapsto_iff : forall m m' k e, + MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'. + Proof. + intros m m' k e. + unfold restrict. + rewrite filter_iff. + intuition. + intros ? ? Hk _ _ _; rewrite Hk; auto. + Qed. + + Lemma restrict_in_iff : forall m m' k, + In k (restrict m m') <-> In k m /\ In k m'. + Proof. + intros m m' k. split. + intros (e,H); rewrite restrict_mapsto_iff in H. + destruct H; split; auto. exists e; auto. + intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto. + Qed. + (** specialized versions analyzing only keys (resp. elements) *) Definition filter_dom (f : key -> bool) := filter (fun k _ => f k). @@ -1106,17 +1672,85 @@ Module WProperties (E:DecidableType)(M:WSfun E). End Elt. - Add Parametric Morphism elt : (@cardinal elt) with signature Equal ==> @Logic.eq _ as cardinal_m. + Add Parametric Morphism elt : (@cardinal elt) + with signature Equal ==> Leibniz as cardinal_m. Proof. intros; apply Equal_cardinal; auto. Qed. -End WProperties. - -(** * Same Properties for full maps *) - -Module Properties (M:S). - Module D := OT_as_DT M.E. - Include WProperties D M. -End Properties. + Add Parametric Morphism elt : (@Disjoint elt) + with signature Equal ==> Equal ==> iff as Disjoint_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros. + rewrite <- Hm1, <- Hm2; auto. + rewrite Hm1, Hm2; auto. + Qed. + + Add Parametric Morphism elt : (@Partition elt) + with signature Equal ==> Equal ==> Equal ==> iff as Partition_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition. + rewrite <- Hm2, <- Hm3. + split; intros (H,H'); split; auto; intros. + rewrite <- Hm1, <- Hm2, <- Hm3; auto. + rewrite Hm1, Hm2, Hm3; auto. + Qed. + + Add Parametric Morphism elt : (@update elt) + with signature Equal ==> Equal ==> Equal as update_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. + setoid_replace (update m1 m2) with (update m1' m2); unfold update. + apply fold_Equal with (eqA:=Equal); auto. + intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. + intros k k' e e' i Hneq x. + rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. + apply fold_init with (eqA:=Equal); auto. + intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. + Qed. + + Add Parametric Morphism elt : (@restrict elt) + with signature Equal ==> Equal ==> Equal as restrict_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. + setoid_replace (restrict m1 m2) with (restrict m1' m2); + unfold restrict, filter. + apply fold_rel with (R:=Equal); try red; auto. + intros k e i i' H Hii' x. + pattern (mem k m2); rewrite Hm2. (* UGLY, see with Matthieu *) + destruct mem; rewrite Hii'; auto. + apply fold_Equal with (eqA:=Equal); auto. + intros k k' Hk e e' He m m' Hm; simpl in *. + pattern (mem k m2); rewrite Hk. (* idem *) + destruct mem; rewrite ?Hk,?He,Hm; red; auto. + intros k k' e e' i Hneq x. + case_eq (mem k m2); case_eq (mem k' m2); intros; auto. + rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. + Qed. + + Add Parametric Morphism elt : (@diff elt) + with signature Equal ==> Equal ==> Equal as diff_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. + setoid_replace (diff m1 m2) with (diff m1' m2); + unfold diff, filter. + apply fold_rel with (R:=Equal); try red; auto. + intros k e i i' H Hii' x. + pattern (mem k m2); rewrite Hm2. (* idem *) + destruct mem; simpl; rewrite Hii'; auto. + apply fold_Equal with (eqA:=Equal); auto. + intros k k' Hk e e' He m m' Hm; simpl in *. + pattern (mem k m2); rewrite Hk. (* idem *) + destruct mem; simpl; rewrite ?Hk,?He,Hm; red; auto. + intros k k' e e' i Hneq x. + case_eq (mem k m2); case_eq (mem k' m2); intros; simpl; auto. + rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. + Qed. + +End WProperties_fun. + +(** * Same Properties for self-contained weak maps and for full maps *) + +Module WProperties (M:WS) := WProperties_fun M.E M. +Module Properties := WProperties. (** * Properties specific to maps with ordered keys *) @@ -1151,7 +1785,8 @@ Module OrdProperties (M:S). Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto. - Definition gtb (p p':key*elt) := match E.compare (fst p) (fst p') with GT _ => true | _ => false end. + Definition gtb (p p':key*elt) := + match E.compare (fst p) (fst p') with GT _ => true | _ => false end. Definition leb p := fun p' => negb (gtb p p'). Definition elements_lt p m := List.filter (gtb p) (elements m). @@ -1275,7 +1910,7 @@ Module OrdProperties (M:S). rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. rewrite add_mapsto_iff; unfold O.eqke; simpl. intuition. - destruct (ME.eq_dec x t0); auto. + destruct (E.eq_dec x t0); auto. elimtype False. assert (In t0 m). exists e0; auto. @@ -1305,7 +1940,7 @@ Module OrdProperties (M:S). rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. rewrite add_mapsto_iff; unfold O.eqke; simpl. intuition. - destruct (ME.eq_dec x t0); auto. + destruct (E.eq_dec x t0); auto. elimtype False. assert (In t0 m). exists e0; auto. @@ -1361,7 +1996,7 @@ Module OrdProperties (M:S). inversion_clear H1; [ | inversion_clear H2; eauto ]. red in H3; simpl in H3; destruct H3. destruct p as (p1,p2). - destruct (ME.eq_dec p1 x). + destruct (E.eq_dec p1 x). apply ME.lt_eq with p1; auto. inversion_clear H2. inversion_clear H5. @@ -1513,74 +2148,53 @@ Module OrdProperties (M:S). (** The following lemma has already been proved on Weak Maps, but with one additionnal hypothesis (some [transpose] fact). *) - Lemma fold_Equal : forall s1 s2 (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - Equal s1 s2 -> - eqA (fold f s1 i) (fold f s2 i). + Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A), + Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + Equal m1 m2 -> + eqA (fold f m1 i) (fold f m2 i). Proof. - intros. + intros m1 m2 A eqA st f i Hf Heq. do 2 rewrite fold_1. do 2 rewrite <- fold_left_rev_right. apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - apply eqlistA_rev. - apply elements_Equal_eqlistA; auto. + intros (k,e) (k',e') a a' (Hk,He) Ha; simpl in *; apply Hf; auto. + apply eqlistA_rev. apply elements_Equal_eqlistA. auto. Qed. - Lemma fold_Add : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - transpose eqA (fun y =>f (fst y) (snd y)) -> - ~In x s1 -> Add x e s1 s2 -> - eqA (fold f s2 i) (f x e (fold f s1 i)). - Proof. - intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. - set (f':=fun y x0 => f (fst y) (snd y) x0) in *. - change (f x e (fold_right f' i (rev (elements s1)))) - with (f' (x,e) (fold_right f' i (rev (elements s1)))). - trans_st (fold_right f' i - (rev (elements_lt (x, e) s1 ++ (x,e) :: elements_ge (x, e) s1))). - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - apply eqlistA_rev. - apply elements_Add; auto. - rewrite distr_rev; simpl. - rewrite app_ass; simpl. - rewrite (elements_split (x,e) s1). - rewrite distr_rev; simpl. - apply fold_right_commutes with (eqA:=eqke) (eqB:=eqA); auto. - Qed. - - Lemma fold_Add_Above : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - Above x s1 -> Add x e s1 s2 -> - eqA (fold f s2 i) (f x e (fold f s1 i)). + Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A), + Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + Above x m1 -> Add x e m1 m2 -> + eqA (fold f m2 i) (f x e (fold f m1 i)). Proof. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. set (f':=fun y x0 => f (fst y) (snd y) x0) in *. - trans_st (fold_right f' i (rev (elements s1 ++ (x,e)::nil))). + transitivity (fold_right f' i (rev (elements m1 ++ (x,e)::nil))). apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *; apply H; auto. apply eqlistA_rev. apply elements_Add_Above; auto. rewrite distr_rev; simpl. - refl_st. + reflexivity. Qed. - Lemma fold_Add_Below : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - Below x s1 -> Add x e s1 s2 -> - eqA (fold f s2 i) (fold f s1 (f x e i)). + Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A), + Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + Below x m1 -> Add x e m1 m2 -> + eqA (fold f m2 i) (fold f m1 (f x e i)). Proof. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. set (f':=fun y x0 => f (fst y) (snd y) x0) in *. - trans_st (fold_right f' i (rev (((x,e)::nil)++elements s1))). + transitivity (fold_right f' i (rev (((x,e)::nil)++elements m1))). apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *; apply H; auto. apply eqlistA_rev. simpl; apply elements_Add_Below; auto. rewrite distr_rev; simpl. rewrite fold_right_app. - refl_st. + reflexivity. Qed. End Fold_properties. @@ -1589,7 +2203,3 @@ Module OrdProperties (M:S). End OrdProperties. - - - - diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index 1e475887..ebdc9c57 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapInterface.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: FMapInterface.v 11699 2008-12-18 11:49:08Z letouzey $ *) (** * Finite map library *) @@ -55,11 +55,7 @@ Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. No requirements for an ordering on keys nor elements, only decidability of equality on keys. First, a functorial signature: *) -Module Type WSfun (E : EqualityType). - - (** The module E of base objects is meant to be a [DecidableType] - (and used to be so). But requiring only an [EqualityType] here - allows subtyping between weak and ordered maps. *) +Module Type WSfun (E : DecidableType). Definition key := E.t. @@ -261,7 +257,7 @@ End WSfun. Similar to [WSfun] but expressed in a self-contained way. *) Module Type WS. - Declare Module E : EqualityType. + Declare Module E : DecidableType. Include Type WSfun E. End WS. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 23bf8196..0ec5ef36 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapList.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: FMapList.v 11699 2008-12-18 11:49:08Z letouzey $ *) (** * Finite map library *) @@ -402,7 +402,7 @@ Proof. elim (Sort_Inf_NotIn H6 H7). destruct H as (e'', hyp); exists e''; auto. apply MapsTo_eq with k; auto; order. - apply H1 with k; destruct (eq_dec x k); auto. + apply H1 with k; destruct (X.eq_dec x k); auto. destruct (X.compare x x'); try contradiction; clear y. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 9bc2a599..7fbc3d47 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: FMapPositive.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: FMapPositive.v 11699 2008-12-18 11:49:08Z letouzey $ *) Require Import Bool. Require Import ZArith. @@ -111,17 +111,17 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. apply EQ; red; auto. Qed. -End PositiveOrderedTypeBits. - -(** Other positive stuff *) - -Lemma peq_dec (x y: positive): {x = y} + {x <> y}. -Proof. + Lemma eq_dec (x y: positive): {x = y} + {x <> y}. + Proof. intros. case_eq ((x ?= y) Eq); intros. left. apply Pcompare_Eq_eq; auto. right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. -Qed. + Qed. + +End PositiveOrderedTypeBits. + +(** Other positive stuff *) Fixpoint append (i j : positive) {struct i} : positive := match i with @@ -717,7 +717,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. Proof. unfold MapsTo. - destruct (peq_dec x y). + destruct (E.eq_dec x y). subst. rewrite grs; intros; discriminate. rewrite gro; auto. @@ -820,16 +820,21 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Variable B : Type. - Fixpoint xmapi (f : positive -> A -> B) (m : t A) (i : positive) - {struct m} : t B := - match m with - | Leaf => @Leaf B - | Node l o r => Node (xmapi f l (append i (xO xH))) - (option_map (f i) o) - (xmapi f r (append i (xI xH))) - end. + Section Mapi. + + Variable f : positive -> A -> B. - Definition mapi (f : positive -> A -> B) m := xmapi f m xH. + Fixpoint xmapi (m : t A) (i : positive) {struct m} : t B := + match m with + | Leaf => @Leaf B + | Node l o r => Node (xmapi l (append i (xO xH))) + (option_map (f i) o) + (xmapi r (append i (xI xH))) + end. + + Definition mapi m := xmapi m xH. + + End Mapi. Definition map (f : A -> B) m := mapi (fun _ => f) m. @@ -983,14 +988,47 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. - Definition fold (A : Type)(B : Type) (f: positive -> A -> B -> B) (tr: t A) (v: B) := - List.fold_left (fun a p => f (fst p) (snd p) a) (elements tr) v. - + Section Fold. + + Variables A B : Type. + Variable f : positive -> A -> B -> B. + + Fixpoint xfoldi (m : t A) (v : B) (i : positive) := + match m with + | Leaf => v + | Node l (Some x) r => + xfoldi r (f i x (xfoldi l v (append i 2))) (append i 3) + | Node l None r => + xfoldi r (xfoldi l v (append i 2)) (append i 3) + end. + + Lemma xfoldi_1 : + forall m v i, + xfoldi m v i = fold_left (fun a p => f (fst p) (snd p) a) (xelements m i) v. + Proof. + set (F := fun a p => f (fst p) (snd p) a). + induction m; intros; simpl; auto. + destruct o. + rewrite fold_left_app; simpl. + rewrite <- IHm1. + rewrite <- IHm2. + unfold F; simpl; reflexivity. + rewrite fold_left_app; simpl. + rewrite <- IHm1. + rewrite <- IHm2. + reflexivity. + Qed. + + Definition fold m i := xfoldi m i 1. + + End Fold. + Lemma fold_1 : forall (A:Type)(m:t A)(B:Type)(i : B) (f : key -> A -> B -> B), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. - intros; unfold fold; auto. + intros; unfold fold, elements. + rewrite xfoldi_1; reflexivity. Qed. Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := @@ -1128,10 +1166,10 @@ Module PositiveMapAdditionalFacts. (* Derivable from the Map interface *) Theorem gsspec: forall (A:Type)(i j: positive) (x: A) (m: t A), - find i (add j x m) = if peq_dec i j then Some x else find i m. + find i (add j x m) = if E.eq_dec i j then Some x else find i m. Proof. intros. - destruct (peq_dec i j); [ rewrite e; apply gss | apply gso; auto ]. + destruct (E.eq_dec i j); [ rewrite e; apply gss | apply gso; auto ]. Qed. (* Not derivable from the Map interface *) diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v index faa705f6..cc1c0a76 100644 --- a/theories/FSets/FSetAVL.v +++ b/theories/FSets/FSetAVL.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: FSetAVL.v 10811 2008-04-17 16:29:49Z letouzey $ *) +(* $Id: FSetAVL.v 11699 2008-12-18 11:49:08Z letouzey $ *) (** * FSetAVL *) @@ -1881,6 +1881,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto. Defined. + Definition eq_dec (s s':t) : { eq s s' } + { ~ eq s s' }. + Proof. + intros (s,b) (s',b'); unfold eq; simpl. + case_eq (Raw.equal s s'); intro H; [left|right]. + apply equal_2; auto. + intro H'; rewrite equal_1 in H; auto; discriminate. + Defined. + (* specs *) Section Specs. Variable s s' s'': t. diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 0622451f..c03fb92e 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetBridge.v 10601 2008-02-28 00:20:33Z letouzey $ *) +(* $Id: FSetBridge.v 11699 2008-12-18 11:49:08Z letouzey $ *) (** * Finite sets library *) @@ -20,11 +20,8 @@ Set Firstorder Depth 2. (** * From non-dependent signature [S] to dependent signature [Sdep]. *) -Module DepOfNodep (M: S) <: Sdep with Module E := M.E. - Import M. +Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. - Module ME := OrderedTypeFacts E. - Definition empty : {s : t | Empty s}. Proof. exists empty; auto with set. @@ -50,7 +47,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. Proof. intros; exists (add x s); auto. unfold Add in |- *; intuition. - elim (ME.eq_dec x y); auto. + elim (E.eq_dec x y); auto. intros; right. eapply add_3; eauto. Qed. @@ -68,7 +65,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. intros; exists (remove x s); intuition. absurd (In x (remove x s)); auto with set. apply In_1 with y; auto. - elim (ME.eq_dec x y); intros; auto. + elim (E.eq_dec x y); intros; auto. absurd (In x (remove x s)); auto with set. apply In_1 with y; auto. eauto with set. @@ -396,6 +393,8 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. intros; discriminate H. Qed. + Definition eq_dec := equal. + Definition equal (s s' : t) : bool := if equal s s' then true else false. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index 0639c1f1..06b4e028 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetDecide.v 11064 2008-06-06 17:00:52Z letouzey $ *) +(* $Id: FSetDecide.v 11699 2008-12-18 11:49:08Z letouzey $ *) (**************************************************************) (* FSetDecide.v *) @@ -19,10 +19,10 @@ Require Import Decidable DecidableTypeEx FSetFacts. -(** First, a version for Weak Sets *) +(** First, a version for Weak Sets in functorial presentation *) -Module WDecide (E : DecidableType)(Import M : WSfun E). - Module F := FSetFacts.WFacts E M. +Module WDecide_fun (E : DecidableType)(Import M : WSfun E). + Module F := FSetFacts.WFacts_fun E M. (** * Overview This functor defines the tactic [fsetdec], which will @@ -509,7 +509,14 @@ the above form: | J : _ |- _ => progress (change T with E.t in J) | |- _ => progress (change T with E.t) end ) - end). + | H : forall x : ?T, _ |- _ => + progress (change T with E.t in H); + repeat ( + match goal with + | J : _ |- _ => progress (change T with E.t in J) + | |- _ => progress (change T with E.t) + end ) + end). (** These two tactics take us from Coq's built-in equality to [E.eq] (and vice versa) when possible. *) @@ -747,6 +754,12 @@ the above form: In x (singleton x). Proof. fsetdec. Qed. + Lemma test_add_In : forall x y s, + In x (add y s) -> + ~ E.eq x y -> + In x s. + Proof. fsetdec. Qed. + Lemma test_Subset_add_remove : forall x s, s [<=] (add x (remove x s)). Proof. fsetdec. Qed. @@ -825,17 +838,27 @@ the above form: intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. Qed. + Lemma test_baydemir : + forall (f : t -> t), + forall (s : t), + forall (x y : elt), + In x (add y (f s)) -> + ~ E.eq x y -> + In x (f s). + Proof. + fsetdec. + Qed. + End FSetDecideTestCases. -End WDecide. +End WDecide_fun. Require Import FSetInterface. -(** Now comes a special version dedicated to full sets. For this - one, only one argument [(M:S)] is necessary. *) +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Decide] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WDecide]. *) -Module Decide (M : S). - Module D:=OT_as_DT M.E. - Module WD := WDecide D M. - Ltac fsetdec := WD.fsetdec. -End Decide. \ No newline at end of file +Module WDecide (M:WS) := WDecide_fun M.E M. +Module Decide := WDecide. diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index a397cc28..80ab2b2c 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetEqProperties.v 11064 2008-06-06 17:00:52Z letouzey $ *) +(* $Id: FSetEqProperties.v 11720 2008-12-28 07:12:15Z letouzey $ *) (** * Finite sets library *) @@ -19,8 +19,8 @@ Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx. -Module WEqProperties (Import E:DecidableType)(M:WSfun E). -Module Import MP := WProperties E M. +Module WEqProperties_fun (Import E:DecidableType)(M:WSfun E). +Module Import MP := WProperties_fun E M. Import FM Dec.F. Import M. @@ -73,7 +73,7 @@ Qed. Lemma is_empty_equal_empty: is_empty s = equal s empty. Proof. apply bool_1; split; intros. -rewrite <- (empty_is_empty_1 (s:=empty)); auto with set. +auto with set. rewrite <- is_empty_iff; auto with set. Qed. @@ -281,7 +281,7 @@ Qed. Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. Proof. intros; rewrite singleton_b. -unfold eqb; destruct (eq_dec x y); intuition. +unfold eqb; destruct (E.eq_dec x y); intuition. Qed. Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. @@ -494,7 +494,7 @@ destruct (mem x s); destruct (mem x s'); intuition. Qed. Section Fold. -Variables (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). +Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). Variables (i:A). Variables (s s':t)(x:elt). @@ -852,7 +852,7 @@ assert (gc : compat_opL (fun x:elt => plus (g x))). auto. assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega. assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). auto. assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. -assert (st := gen_st nat). +assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). intros s;pattern s; apply set_rec. intros. rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H). @@ -867,7 +867,7 @@ Lemma sum_filter : forall f, (compat_bool E.eq f) -> forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). Proof. unfold sum; intros f Hf. -assert (st := gen_st nat). +assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). red; intros. rewrite (Hf x x' H); auto. @@ -892,7 +892,7 @@ rewrite filter_iff; auto; set_iff; tauto. Qed. Lemma fold_compat : - forall (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA) + forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f g:elt->A->A), (compat_op E.eq eqA f) -> (transpose eqA f) -> (compat_op E.eq eqA g) -> (transpose eqA g) -> @@ -901,19 +901,19 @@ Lemma fold_compat : Proof. intros A eqA st f g fc ft gc gt i. intro s; pattern s; apply set_rec; intros. -trans_st (fold f s0 i). +transitivity (fold f s0 i). apply fold_equal with (eqA:=eqA); auto. rewrite equal_sym; auto. -trans_st (fold g s0 i). +transitivity (fold g s0 i). apply H0; intros; apply H1; auto with set. elim (equal_2 H x); auto with set; intros. apply fold_equal with (eqA:=eqA); auto with set. -trans_st (f x (fold f s0 i)). +transitivity (f x (fold f s0 i)). apply fold_add with (eqA:=eqA); auto with set. -trans_st (g x (fold f s0 i)); auto with set. -trans_st (g x (fold g s0 i)); auto with set. -sym_st; apply fold_add with (eqA:=eqA); auto. -do 2 rewrite fold_empty; refl_st. +transitivity (g x (fold f s0 i)); auto with set. +transitivity (g x (fold g s0 i)); auto with set. +symmetry; apply fold_add with (eqA:=eqA); auto. +do 2 rewrite fold_empty; reflexivity. Qed. Lemma sum_compat : @@ -927,13 +927,12 @@ Qed. End Sum. -End WEqProperties. - +End WEqProperties_fun. -(** Now comes a special version dedicated to full sets. For this - one, only one argument [(M:S)] is necessary. *) +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [EqProperties] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WEqProperties]. *) -Module EqProperties (M:S). - Module D := OT_as_DT M.E. - Include WEqProperties D M. -End EqProperties. +Module WEqProperties (M:WS) := WEqProperties_fun M.E M. +Module EqProperties := WEqProperties. diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v index d77d9c60..1e15d3a1 100644 --- a/theories/FSets/FSetFacts.v +++ b/theories/FSets/FSetFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetFacts.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: FSetFacts.v 11720 2008-12-28 07:12:15Z letouzey $ *) (** * Finite sets library *) @@ -21,11 +21,9 @@ Require Export FSetInterface. Set Implicit Arguments. Unset Strict Implicit. -(** First, a functor for Weak Sets. Since the signature [WS] includes - an EqualityType and not a stronger DecidableType, this functor - should take two arguments in order to compensate this. *) +(** First, a functor for Weak Sets in functorial version. *) -Module WFacts (Import E : DecidableType)(Import M : WSfun E). +Module WFacts_fun (Import E : DecidableType)(Import M : WSfun E). Notation eq_dec := E.eq_dec. Definition eqb x y := if eq_dec x y then true else false. @@ -293,12 +291,12 @@ End BoolSpec. (** * [E.eq] and [Equal] are setoid equalities *) -Definition E_ST : Setoid_Theory elt E.eq. +Definition E_ST : Equivalence E.eq. Proof. constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. Qed. -Definition Equal_ST : Setoid_Theory t Equal. +Definition Equal_ST : Equivalence Equal. Proof. constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans]. Qed. @@ -309,8 +307,6 @@ Add Relation elt E.eq transitivity proved by E.eq_trans as EltSetoid. -Typeclasses unfold elt. - Add Relation t Equal reflexivity proved by eq_refl symmetry proved by eq_sym @@ -418,18 +414,15 @@ Qed. (* [Subset] is a setoid order *) Lemma Subset_refl : forall s, s[<=]s. -Proof. red; auto. Defined. +Proof. red; auto. Qed. Lemma Subset_trans : forall s s' s'', s[<=]s'->s'[<=]s''->s[<=]s''. -Proof. unfold Subset; eauto. Defined. +Proof. unfold Subset; eauto. Qed. -Add Relation t Subset +Add Relation t Subset reflexivity proved by Subset_refl transitivity proved by Subset_trans as SubsetSetoid. -(* NB: for the moment, it is important to use Defined and not Qed in - the two previous lemmas, in order to allow conversion of - SubsetSetoid coming from separate Facts modules. See bug #1738. *) Instance In_s_m : Morphism (E.eq ==> Subset ++> impl) In | 1. Proof. @@ -480,28 +473,35 @@ Proof. unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. Qed. +Lemma filter_ext : forall f f', compat_bool E.eq f -> (forall x, f x = f' x) -> + forall s s', s[=]s' -> filter f s [=] filter f' s'. +Proof. +intros f f' Hf Hff' s s' Hss' x. do 2 (rewrite filter_iff; auto). +rewrite Hff', Hss'; intuition. +red; intros; rewrite <- 2 Hff'; auto. +Qed. + Lemma filter_subset : forall f, compat_bool E.eq f -> forall s s', s[<=]s' -> filter f s [<=] filter f s'. Proof. unfold Subset; intros; rewrite filter_iff in *; intuition. Qed. -(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid +(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid structures on [list elt] and [option elt]. *) (* Later: Add Morphism cardinal ; cardinal_m. *) -End WFacts. - +End WFacts_fun. -(** Now comes a special version dedicated to full sets. For this - one, only one argument [(M:S)] is necessary. *) +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Facts] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WFacts]. *) -Module Facts (Import M:S). - Module D:=OT_as_DT M.E. - Include WFacts D M. +Module WFacts (M:WS) := WFacts_fun M.E M. +Module Facts := WFacts. -End Facts. diff --git a/theories/FSets/FSetFullAVL.v b/theories/FSets/FSetFullAVL.v index 1fc109f3..a2d8e681 100644 --- a/theories/FSets/FSetFullAVL.v +++ b/theories/FSets/FSetFullAVL.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: FSetFullAVL.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: FSetFullAVL.v 11699 2008-12-18 11:49:08Z letouzey $ *) (** * FSetFullAVL @@ -913,6 +913,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. change (Raw.Equal s s'); auto. Defined. + Definition eq_dec (s s':t) : { eq s s' } + { ~ eq s s' }. + Proof. + intros (s,b,a) (s',b',a'); unfold eq; simpl. + case_eq (Raw.equal s s'); intro H; [left|right]. + apply equal_2; auto. + intro H'; rewrite equal_1 in H; auto; discriminate. + Defined. + (* specs *) Section Specs. Variable s s' s'': t. diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index 1255fcc8..79eea34e 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetInterface.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: FSetInterface.v 11701 2008-12-18 11:49:12Z letouzey $ *) (** * Finite set library *) @@ -44,11 +44,7 @@ Unset Strict Implicit. Weak sets are sets without ordering on base elements, only a decidable equality. *) -Module Type WSfun (E : EqualityType). - - (** The module E of base objects is meant to be a [DecidableType] - (and used to be so). But requiring only an [EqualityType] here - allows subtyping between weak and ordered sets *) +Module Type WSfun (E : DecidableType). Definition elt := E.t. @@ -62,8 +58,8 @@ Module Type WSfun (E : EqualityType). Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - Notation "s [=] t" := (Equal s t) (at level 70, no associativity). - Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). Parameter empty : t. (** The empty set. *) @@ -95,12 +91,8 @@ Module Type WSfun (E : EqualityType). (** Set difference. *) Definition eq : t -> t -> Prop := Equal. - (** In order to have the subtyping WS < S between weak and ordered - sets, we do not require here an [eq_dec]. This interface is hence - not compatible with [DecidableType], but only with [EqualityType], - so in general it may not possible to form weak sets of weak sets. - Some particular implementations may allow this nonetheless, in - particular [FSetWeakList.Make]. *) + + Parameter eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. Parameter equal : t -> t -> bool. (** [equal s1 s2] tests whether the sets [s1] and [s2] are @@ -282,7 +274,7 @@ End WSfun. module [E] of base elements is incorporated in the signature. *) Module Type WS. - Declare Module E : EqualityType. + Declare Module E : DecidableType. Include Type WSfun E. End WS. @@ -367,17 +359,16 @@ WSfun ---> WS | | | | V V -Sfun ---> S - +Sfun ---> S -Module S_WS (M : S) <: SW := M. +Module S_WS (M : S) <: WS := M. Module Sfun_WSfun (E:OrderedType)(M : Sfun E) <: WSfun E := M. -Module S_Sfun (E:OrderedType)(M : S with Module E:=E) <: Sfun E := M. -Module WS_WSfun (E:EqualityType)(M : WS with Module E:=E) <: WSfun E := M. +Module S_Sfun (M : S) <: Sfun M.E := M. +Module WS_WSfun (M : WS) <: WSfun M.E := M. >> *) -(** * Dependent signature +(** * Dependent signature Signature [Sdep] presents ordered sets using dependent types *) @@ -402,7 +393,7 @@ Module Type Sdep. Parameter lt : t -> t -> Prop. Parameter compare : forall s s' : t, Compare lt eq s s'. - Parameter eq_refl : forall s : t, eq s s. + Parameter eq_refl : forall s : t, eq s s. Parameter eq_sym : forall s s' : t, eq s s' -> eq s' s. Parameter eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. Parameter lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''. diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v index a205d5b0..b009e109 100644 --- a/theories/FSets/FSetList.v +++ b/theories/FSets/FSetList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetList.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: FSetList.v 11866 2009-01-28 19:10:15Z letouzey $ *) (** * Finite sets library *) @@ -1263,6 +1263,14 @@ Module Make (X: OrderedType) <: S with Module E := X. auto. Defined. + Definition eq_dec : { eq s s' } + { ~ eq s s' }. + Proof. + change eq with Equal. + case_eq (equal s s'); intro H; [left | right]. + apply equal_2; auto. + intro H'; rewrite equal_1 in H; auto; discriminate. + Defined. + End Spec. End Make. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 7413b06b..8dc7fbd9 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetProperties.v 11064 2008-06-06 17:00:52Z letouzey $ *) +(* $Id: FSetProperties.v 11720 2008-12-28 07:12:15Z letouzey $ *) (** * Finite sets library *) @@ -22,15 +22,13 @@ Set Implicit Arguments. Unset Strict Implicit. Hint Unfold transpose compat_op. -Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence. +Hint Extern 1 (Equivalence _) => constructor; congruence. -(** First, a functor for Weak Sets. Since the signature [WS] includes - an EqualityType and not a stronger DecidableType, this functor - should take two arguments in order to compensate this. *) +(** First, a functor for Weak Sets in functorial version. *) -Module WProperties (Import E : DecidableType)(M : WSfun E). - Module Import Dec := WDecide E M. - Module Import FM := Dec.F (* FSetFacts.WFacts E M *). +Module WProperties_fun (Import E : DecidableType)(M : WSfun E). + Module Import Dec := WDecide_fun E M. + Module Import FM := Dec.F (* FSetFacts.WFacts_fun E M *). Import M. Lemma In_dec : forall x s, {In x s} + {~ In x s}. @@ -126,6 +124,10 @@ Module WProperties (Import E : DecidableType)(M : WSfun E). Lemma singleton_equal_add : singleton x [=] add x empty. Proof. fsetdec. Qed. + Lemma remove_singleton_empty : + In x s -> remove x s [=] empty -> singleton x [=] s. + Proof. fsetdec. Qed. + Lemma union_sym : union s s' [=] union s' s. Proof. fsetdec. Qed. @@ -306,21 +308,176 @@ Module WProperties (Import E : DecidableType)(M : WSfun E). rewrite <-elements_Empty; auto with set. Qed. - (** * Alternative (weaker) specifications for [fold] *) + (** * Conversions between lists and sets *) + + Definition of_list (l : list elt) := List.fold_right add empty l. - Section Old_Spec_Now_Properties. + Definition to_list := elements. + + Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l. + Proof. + induction l; simpl; intro x. + rewrite empty_iff, InA_nil. intuition. + rewrite add_iff, InA_cons, IHl. intuition. + Qed. + + Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l. + Proof. + unfold to_list; red; intros. + rewrite <- elements_iff; apply of_list_1. + Qed. + + Lemma of_list_3 : forall s, of_list (to_list s) [=] s. + Proof. + unfold to_list; red; intros. + rewrite of_list_1; symmetry; apply elements_iff. + Qed. + + (** * Fold *) + + Section Fold. Notation NoDup := (NoDupA E.eq). + Notation InA := (InA E.eq). + + (** ** Induction principles for fold (contributed by S. Lescuyer) *) + + (** In the following lemma, the step hypothesis is deliberately restricted + to the precise set s we are considering. *) + + Theorem fold_rec : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s', Empty s' -> P s' i) -> + (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pempty Pstep. + rewrite fold_1, <- fold_left_rev_right. + set (l:=rev (elements s)). + assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)). + intros; eapply Pstep; eauto. + rewrite elements_iff, <- InA_rev; auto. + assert (Hdup : NoDup l) by + (unfold l; eauto using elements_3w, NoDupA_rev). + assert (Hsame : forall x, In x s <-> InA x l) by + (unfold l; intros; rewrite elements_iff, InA_rev; intuition). + clear Pstep; clearbody l; revert s Hsame; induction l. + (* empty *) + intros s Hsame; simpl. + apply Pempty. intro x. rewrite Hsame, InA_nil; intuition. + (* step *) + intros s Hsame; simpl. + apply Pstep' with (of_list l); auto. + inversion_clear Hdup; rewrite of_list_1; auto. + red. intros. rewrite Hsame, of_list_1, InA_cons; intuition. + apply IHl. + intros; eapply Pstep'; eauto. + inversion_clear Hdup; auto. + exact (of_list_1 l). + Qed. + + (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this + case, [P] must be compatible with equality of sets *) + + Theorem fold_rec_bis : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + (P empty i) -> + (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pmorphism Pempty Pstep. + apply fold_rec; intros. + apply Pmorphism with empty; auto with set. + rewrite Add_Equal in H1; auto with set. + apply Pmorphism with (add x s'); auto with set. + Qed. + + Lemma fold_rec_nodep : + forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t), + P i -> (forall x a, In x s -> P a -> P (f x a)) -> + P (fold f s i). + Proof. + intros; apply fold_rec_bis with (P:=fun _ => P); auto. + Qed. + + (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : + the step hypothesis must here be applicable to any [x]. + At the same time, it looks more like an induction principle, + and hence can be easier to use. *) + + Lemma fold_rec_weak : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + P empty i -> + (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) -> + forall s, P s (fold f s i). + Proof. + intros; apply fold_rec_bis; auto. + Qed. + + Lemma fold_rel : + forall (A B:Type)(R : A -> B -> Type) + (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t), + R i j -> + (forall x a b, In x s -> R a b -> R (f x a) (g x b)) -> + R (fold f s i) (fold g s j). + Proof. + intros A B R f g i j s Rempty Rstep. + do 2 rewrite fold_1, <- fold_left_rev_right. + set (l:=rev (elements s)). + assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by + (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto). + clearbody l; clear Rstep s. + induction l; simpl; auto. + Qed. + + (** From the induction principle on [fold], we can deduce some general + induction principles on sets. *) + + Lemma set_induction : + forall P : t -> Type, + (forall s, Empty s -> P s) -> + (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> + forall s, P s. + Proof. + intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + Lemma set_induction_bis : + forall P : t -> Type, + (forall s s', s [=] s' -> P s -> P s') -> + P empty -> + (forall x s, ~In x s -> P s -> P (add x s)) -> + forall s, P s. + Proof. + intros. + apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + (** [fold] can be used to reconstruct the same initial set. *) + + Lemma fold_identity : forall s, fold add s empty [=] s. + Proof. + intros. + apply fold_rec with (P:=fun s acc => acc[=]s); auto with set. + intros. rewrite H2; rewrite Add_Equal in H1; auto with set. + Qed. + + (** ** Alternative (weaker) specifications for [fold] *) (** When [FSets] was first designed, the order in which Ocaml's [Set.fold] - takes the set elements was unspecified. This specification reflects this fact: + takes the set elements was unspecified. This specification reflects + this fact: *) - Lemma fold_0 : + Lemma fold_0 : forall s (A : Type) (i : A) (f : elt -> A -> A), exists l : list elt, NoDup l /\ - (forall x : elt, In x s <-> InA E.eq x l) /\ + (forall x : elt, In x s <-> InA x l) /\ fold f s i = fold_right f i l. Proof. intros; exists (rev (elements s)); split. @@ -333,26 +490,26 @@ Module WProperties (Import E : DecidableType)(M : WSfun E). apply fold_1. Qed. - (** An alternate (and previous) specification for [fold] was based on - the recursive structure of a set. It is now lemmas [fold_1] and + (** An alternate (and previous) specification for [fold] was based on + the recursive structure of a set. It is now lemmas [fold_1] and [fold_2]. *) Lemma fold_1 : - forall s (A : Type) (eqA : A -> A -> Prop) - (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + forall s (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), Empty s -> eqA (fold f s i) i. Proof. unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). rewrite H3; clear H3. generalize H H2; clear H H2; case l; simpl; intros. - refl_st. + reflexivity. elim (H e). elim (H2 e); intuition. Qed. Lemma fold_2 : forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), compat_op E.eq eqA f -> transpose eqA f -> ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). @@ -379,283 +536,238 @@ Module WProperties (Import E : DecidableType)(M : WSfun E). rewrite elements_Empty in H; rewrite H; simpl; auto. Qed. - (** Similar specifications for [cardinal]. *) + Section Fold_More. - Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. - Proof. - intros; rewrite cardinal_1; rewrite M.fold_1. - symmetry; apply fold_left_length; auto. - Qed. - - Lemma cardinal_0 : - forall s, exists l : list elt, - NoDupA E.eq l /\ - (forall x : elt, In x s <-> InA E.eq x l) /\ - cardinal s = length l. - Proof. - intros; exists (elements s); intuition; apply cardinal_1. - Qed. - - Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. - Proof. - intros; rewrite cardinal_fold; apply fold_1; auto. - Qed. - - Lemma cardinal_2 : - forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s). - Proof. - intros; do 2 rewrite cardinal_fold. - change S with ((fun _ => S) x). - apply fold_2; auto. - Qed. - - End Old_Spec_Now_Properties. - - (** * Induction principle over sets *) + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). - Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. + Lemma fold_commutes : forall i s x, + eqA (fold f s (f x i)) (f x (fold f s i)). Proof. intros. - rewrite elements_Empty, M.cardinal_1. - destruct (elements s); intuition; discriminate. - Qed. - - Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. - Proof. - intros; rewrite cardinal_Empty; auto. - Qed. - Hint Resolve cardinal_inv_1. - - Lemma cardinal_inv_2 : - forall s n, cardinal s = S n -> { x : elt | In x s }. - Proof. - intros; rewrite M.cardinal_1 in H. - generalize (elements_2 (s:=s)). - destruct (elements s); try discriminate. - exists e; auto. - Qed. - - Lemma cardinal_inv_2b : - forall s, cardinal s <> 0 -> { x : elt | In x s }. - Proof. - intro; generalize (@cardinal_inv_2 s); destruct cardinal; - [intuition|eauto]. - Qed. - - Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. - Proof. - symmetry. - remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. - induction n; intros. - apply cardinal_1; rewrite <- H; auto. - destruct (cardinal_inv_2 Heqn) as (x,H2). - revert Heqn. - rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. - rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set. - Qed. - - Add Morphism cardinal : cardinal_m. - Proof. - exact Equal_cardinal. + apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. + reflexivity. + transitivity (f x0 (f x b)); auto. Qed. - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. + (** ** Fold is a morphism *) - Lemma set_induction : - forall P : t -> Type, - (forall s : t, Empty s -> P s) -> - (forall s s' : t, P s -> forall x : elt, ~In x s -> Add x s s' -> P s') -> - forall s : t, P s. + Lemma fold_init : forall i i' s, eqA i i' -> + eqA (fold f s i) (fold f s i'). Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. - destruct (cardinal_inv_2 (sym_eq Heqn)) as (x,H0). - apply X0 with (remove x s) x; auto with set. - apply IHn; auto. - assert (S n = S (cardinal (remove x s))). - rewrite Heqn; apply cardinal_2 with x; auto with set. - inversion H; auto. - Qed. - - (** Other properties of [fold]. *) - - Section Fold. - Variables (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). - Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). - - Section Fold_1. - Variable i i':A. - - Lemma fold_empty : (fold f empty i) = i. - Proof. - apply fold_1b; auto with set. + intros. apply fold_rel with (R:=eqA); auto. Qed. Lemma fold_equal : - forall s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). Proof. - intros s; pattern s; apply set_induction; clear s; intros. - trans_st i. + intros i s; pattern s; apply set_induction; clear s; intros. + transitivity i. apply fold_1; auto. - sym_st; apply fold_1; auto. + symmetry; apply fold_1; auto. rewrite <- H0; auto. - trans_st (f x (fold f s i)). + transitivity (f x (fold f s i)). apply fold_2 with (eqA := eqA); auto. - sym_st; apply fold_2 with (eqA := eqA); auto. + symmetry; apply fold_2 with (eqA := eqA); auto. unfold Add in *; intros. rewrite <- H2; auto. Qed. - - Lemma fold_add : forall s x, ~In x s -> + + (** ** Fold and other set operators *) + + Lemma fold_empty : forall i, fold f empty i = i. + Proof. + intros i; apply fold_1b; auto with set. + Qed. + + Lemma fold_add : forall i s x, ~In x s -> eqA (fold f (add x s) i) (f x (fold f s i)). Proof. - intros; apply fold_2 with (eqA := eqA); auto. + intros; apply fold_2 with (eqA := eqA); auto with set. Qed. - Lemma add_fold : forall s x, In x s -> + Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply fold_equal; auto with set. Qed. - Lemma remove_fold_1: forall s x, In x s -> + Lemma remove_fold_1: forall i s x, In x s -> eqA (f x (fold f (remove x s) i)) (fold f s i). Proof. intros. - sym_st. + symmetry. apply fold_2 with (eqA:=eqA); auto with set. Qed. - Lemma remove_fold_2: forall s x, ~In x s -> + Lemma remove_fold_2: forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros. apply fold_equal; auto with set. Qed. - Lemma fold_commutes : forall s x, - eqA (fold f s (f x i)) (f x (fold f s i)). - Proof. - intros; pattern s; apply set_induction; clear s; intros. - trans_st (f x i). - apply fold_1; auto. - sym_st. - apply Comp; auto. - apply fold_1; auto. - trans_st (f x0 (fold f s (f x i))). - apply fold_2 with (eqA:=eqA); auto. - trans_st (f x0 (f x (fold f s i))). - trans_st (f x (f x0 (fold f s i))). - apply Comp; auto. - sym_st. - apply fold_2 with (eqA:=eqA); auto. - Qed. - - Lemma fold_init : forall s, eqA i i' -> - eqA (fold f s i) (fold f s i'). - Proof. - intros; pattern s; apply set_induction; clear s; intros. - trans_st i. - apply fold_1; auto. - trans_st i'. - sym_st; apply fold_1; auto. - trans_st (f x (fold f s i)). - apply fold_2 with (eqA:=eqA); auto. - trans_st (f x (fold f s i')). - sym_st; apply fold_2 with (eqA:=eqA); auto. - Qed. - - End Fold_1. - Section Fold_2. - Variable i:A. - - Lemma fold_union_inter : forall s s', + Lemma fold_union_inter : forall i s s', eqA (fold f (union s s') (fold f (inter s s') i)) (fold f s (fold f s' i)). Proof. intros; pattern s; apply set_induction; clear s; intros. - trans_st (fold f s' (fold f (inter s s') i)). + transitivity (fold f s' (fold f (inter s s') i)). apply fold_equal; auto with set. - trans_st (fold f s' i). + transitivity (fold f s' i). apply fold_init; auto. apply fold_1; auto with set. - sym_st; apply fold_1; auto. + symmetry; apply fold_1; auto. rename s'0 into s''. destruct (In_dec x s'). (* In x s' *) - trans_st (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. + transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. apply fold_init; auto. apply fold_2 with (eqA:=eqA); auto with set. rewrite inter_iff; intuition. - trans_st (f x (fold f s (fold f s' i))). - trans_st (fold f (union s s') (f x (fold f (inter s s') i))). + transitivity (f x (fold f s (fold f s' i))). + transitivity (fold f (union s s') (f x (fold f (inter s s') i))). apply fold_equal; auto. apply equal_sym; apply union_Equal with x; auto with set. - trans_st (f x (fold f (union s s') (fold f (inter s s') i))). + transitivity (f x (fold f (union s s') (fold f (inter s s') i))). apply fold_commutes; auto. - sym_st; apply fold_2 with (eqA:=eqA); auto. + apply Comp; auto. + symmetry; apply fold_2 with (eqA:=eqA); auto. (* ~(In x s') *) - trans_st (f x (fold f (union s s') (fold f (inter s'' s') i))). + transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))). apply fold_2 with (eqA:=eqA); auto with set. - trans_st (f x (fold f (union s s') (fold f (inter s s') i))). + transitivity (f x (fold f (union s s') (fold f (inter s s') i))). apply Comp;auto. apply fold_init;auto. apply fold_equal;auto. apply equal_sym; apply inter_Add_2 with x; auto with set. - trans_st (f x (fold f s (fold f s' i))). - sym_st; apply fold_2 with (eqA:=eqA); auto. + transitivity (f x (fold f s (fold f s' i))). + apply Comp; auto. + symmetry; apply fold_2 with (eqA:=eqA); auto. Qed. - End Fold_2. - Section Fold_3. - Variable i:A. - - Lemma fold_diff_inter : forall s s', + Lemma fold_diff_inter : forall i s s', eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). Proof. intros. - trans_st (fold f (union (diff s s') (inter s s')) - (fold f (inter (diff s s') (inter s s')) i)). - sym_st; apply fold_union_inter; auto. - trans_st (fold f s (fold f (inter (diff s s') (inter s s')) i)). + transitivity (fold f (union (diff s s') (inter s s')) + (fold f (inter (diff s s') (inter s s')) i)). + symmetry; apply fold_union_inter; auto. + transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)). apply fold_equal; auto with set. apply fold_init; auto. apply fold_1; auto with set. Qed. - Lemma fold_union: forall s s', + Lemma fold_union: forall i s s', (forall x, ~(In x s/\In x s')) -> eqA (fold f (union s s') i) (fold f s (fold f s' i)). Proof. intros. - trans_st (fold f (union s s') (fold f (inter s s') i)). + transitivity (fold f (union s s') (fold f (inter s s') i)). apply fold_init; auto. - sym_st; apply fold_1; auto with set. + symmetry; apply fold_1; auto with set. unfold Empty; intro a; generalize (H a); set_iff; tauto. apply fold_union_inter; auto. Qed. - End Fold_3. - End Fold. + End Fold_More. Lemma fold_plus : forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. Proof. - assert (st := gen_st nat). - assert (fe : compat_op E.eq (@Logic.eq _) (fun _ => S)) by (unfold compat_op; auto). - assert (fp : transpose (@Logic.eq _) (fun _:elt => S)) by (unfold transpose; auto). - intros s p; pattern s; apply set_induction; clear s; intros. - rewrite (fold_1 st p (fun _ => S) H). - rewrite (fold_1 st 0 (fun _ => S) H); trivial. - assert (forall p s', Add x s s' -> fold (fun _ => S) s' p = S (fold (fun _ => S) s p)). - change S with ((fun _ => S) x). - intros; apply fold_2; auto. - rewrite H2; auto. - rewrite (H2 0); auto. - rewrite H. - simpl; auto. - Qed. - - (** more properties of [cardinal] *) + intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto. + Qed. + + End Fold. + + (** * Cardinal *) + + (** ** Characterization of cardinal in terms of fold *) + + Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. + Proof. + intros; rewrite cardinal_1; rewrite M.fold_1. + symmetry; apply fold_left_length; auto. + Qed. + + (** ** Old specifications for [cardinal]. *) + + Lemma cardinal_0 : + forall s, exists l : list elt, + NoDupA E.eq l /\ + (forall x : elt, In x s <-> InA E.eq x l) /\ + cardinal s = length l. + Proof. + intros; exists (elements s); intuition; apply cardinal_1. + Qed. + + Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. + Proof. + intros; rewrite cardinal_fold; apply fold_1; auto. + Qed. + + Lemma cardinal_2 : + forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s). + Proof. + intros; do 2 rewrite cardinal_fold. + change S with ((fun _ => S) x). + apply fold_2; auto. + Qed. + + (** ** Cardinal and (non-)emptiness *) + + Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. + Proof. + intros. + rewrite elements_Empty, M.cardinal_1. + destruct (elements s); intuition; discriminate. + Qed. + + Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. + Proof. + intros; rewrite cardinal_Empty; auto. + Qed. + Hint Resolve cardinal_inv_1. + + Lemma cardinal_inv_2 : + forall s n, cardinal s = S n -> { x : elt | In x s }. + Proof. + intros; rewrite M.cardinal_1 in H. + generalize (elements_2 (s:=s)). + destruct (elements s); try discriminate. + exists e; auto. + Qed. + + Lemma cardinal_inv_2b : + forall s, cardinal s <> 0 -> { x : elt | In x s }. + Proof. + intro; generalize (@cardinal_inv_2 s); destruct cardinal; + [intuition|eauto]. + Qed. + + (** ** Cardinal is a morphism *) + + Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. + Proof. + symmetry. + remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. + induction n; intros. + apply cardinal_1; rewrite <- H; auto. + destruct (cardinal_inv_2 Heqn) as (x,H2). + revert Heqn. + rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. + rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set. + Qed. + + Add Morphism cardinal : cardinal_m. + Proof. + exact Equal_cardinal. + Qed. + + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. + + (** ** Cardinal and set operators *) Lemma empty_cardinal : cardinal empty = 0. Proof. @@ -773,18 +885,18 @@ Module WProperties (Import E : DecidableType)(M : WSfun E). Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2. -End WProperties. +End WProperties_fun. +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Properties] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WProperties]. *) -(** A clone of [WProperties] working on full sets. *) +Module WProperties (M:WS) := WProperties_fun M.E M. +Module Properties := WProperties. -Module Properties (M:S). - Module D := OT_as_DT M.E. - Include WProperties D M. -End Properties. - -(** Now comes some properties specific to the element ordering, +(** Now comes some properties specific to the element ordering, invalid for Weak Sets. *) Module OrdProperties (M:S). @@ -973,7 +1085,7 @@ Module OrdProperties (M:S). Lemma fold_3 : forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), compat_op E.eq eqA f -> Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). Proof. @@ -990,7 +1102,7 @@ Module OrdProperties (M:S). Lemma fold_4 : forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), compat_op E.eq eqA f -> Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). Proof. @@ -1010,7 +1122,7 @@ Module OrdProperties (M:S). no need for [(transpose eqA f)]. *) Section FoldOpt. - Variables (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f). Lemma fold_equal : @@ -1024,14 +1136,6 @@ Module OrdProperties (M:S). red; intro a; do 2 rewrite <- elements_iff; auto. Qed. - Lemma fold_init : forall i i' s, eqA i i' -> - eqA (fold f s i) (fold f s i'). - Proof. - intros; do 2 rewrite M.fold_1. - do 2 rewrite <- fold_left_rev_right. - induction (rev (elements s)); simpl; auto. - Qed. - Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v index ae51d905..56a66261 100644 --- a/theories/FSets/FSetToFiniteSet.v +++ b/theories/FSets/FSetToFiniteSet.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: FSetToFiniteSet.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: FSetToFiniteSet.v 11735 2009-01-02 17:22:31Z herbelin $ *) Require Import Ensembles Finite_sets. Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx. @@ -20,7 +20,7 @@ Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx. to the good old [Ensembles] and [Finite_sets] theory. *) Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). - Module MP:= WProperties U M. + Module MP:= WProperties_fun U M. Import M MP FM Ensembles Finite_sets. Definition mkEns : M.t -> Ensemble M.elt := @@ -30,7 +30,7 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x. Proof. - unfold In; compute; auto. + unfold In; compute; auto with extcore. Qed. Lemma Subset_Included : forall s s', s[<=]s' <-> Included _ (!!s) (!!s'). @@ -155,9 +155,7 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). End WS_to_Finite_set. -Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U). - Module D := OT_as_DT U. - Include WS_to_Finite_set D M. -End S_to_Finite_set. +Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U) := + WS_to_Finite_set U M. diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v index 71a0d584..309016ce 100644 --- a/theories/FSets/FSetWeakList.v +++ b/theories/FSets/FSetWeakList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetWeakList.v 10631 2008-03-06 18:17:24Z msozeau $ *) +(* $Id: FSetWeakList.v 11866 2009-01-28 19:10:15Z letouzey $ *) (** * Finite sets library *) @@ -746,53 +746,12 @@ Module Raw (X: DecidableType). Definition eq_dec : forall (s s':t)(Hs:NoDup s)(Hs':NoDup s'), { eq s s' }+{ ~eq s s' }. Proof. - unfold eq. - induction s; intros s'. - (* nil *) - destruct s'; [left|right]. - firstorder. - unfold not, Equal. - intros H; generalize (H e); clear H. - rewrite InA_nil, InA_cons; intuition. - (* cons *) - intros. - case_eq (mem a s'); intros H; - [ destruct (IHs (remove a s')) as [H'|H']; - [ | | left|right]|right]; - clear IHs. - inversion_clear Hs; auto. - apply remove_unique; auto. - (* In a s' /\ s [=] remove a s' *) - generalize (mem_2 H); clear H; intro H. - unfold Equal in *; intros b. - rewrite InA_cons; split. - destruct 1. - apply In_eq with a; auto. - rewrite H' in H0. - apply remove_3 with a; auto. - destruct (X.eq_dec b a); [left|right]; auto. - rewrite H'. - apply remove_2; auto. - (* In a s' /\ ~ s [=] remove a s' *) - generalize (mem_2 H); clear H; intro H. - contradict H'. - unfold Equal in *; intros b. - split; intros. - apply remove_2; auto. - inversion_clear Hs. - contradict H1; apply In_eq with b; auto. - rewrite <- H'; rewrite InA_cons; auto. - assert (In b s') by (apply remove_3 with a; auto). - rewrite <- H', InA_cons in H1; destruct H1; auto. - elim (remove_1 Hs' (X.eq_sym H1) H0). - (* ~ In a s' *) - assert (~In a s'). - red; intro H'; rewrite (mem_1 H') in H; discriminate. - contradict H0. - unfold Equal in *. - rewrite <- H0. - rewrite InA_cons; auto. - Qed. + intros. + change eq with Equal. + case_eq (equal s s'); intro H; [left | right]. + apply equal_2; auto. + intro H'; rewrite equal_1 in H; auto; discriminate. + Defined. End ForNotations. End Raw. @@ -993,6 +952,6 @@ Module Make (X: DecidableType) <: WS with Module E := X. { eq s s' }+{ ~eq s s' }. Proof. intros s s'; exact (Raw.eq_dec s.(unique) s'.(unique)). - Qed. + Defined. End Make. diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v index c56a24cf..fadd27dd 100644 --- a/theories/FSets/OrderedType.v +++ b/theories/FSets/OrderedType.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: OrderedType.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: OrderedType.v 11700 2008-12-18 11:49:10Z letouzey $ *) Require Export SetoidList. Set Implicit Arguments. @@ -19,7 +19,7 @@ Inductive Compare (X : Type) (lt eq : X -> X -> Prop) (x y : X) : Type := | EQ : eq x y -> Compare lt eq x y | GT : lt y x -> Compare lt eq x y. -Module Type OrderedType. +Module Type MiniOrderedType. Parameter Inline t : Type. @@ -29,7 +29,7 @@ Module Type OrderedType. Axiom eq_refl : forall x : t, eq x x. Axiom eq_sym : forall x y : t, eq x y -> eq y x. Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - + Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. @@ -38,15 +38,34 @@ Module Type OrderedType. Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. +End MiniOrderedType. + +Module Type OrderedType. + Include Type MiniOrderedType. + + (** A [eq_dec] can be deduced from [compare] below. But adding this + redundant field allows to see an OrderedType as a DecidableType. *) + Parameter eq_dec : forall x y, { eq x y } + { ~ eq x y }. + End OrderedType. +Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. + Include O. + + Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. + Proof. + intros; elim (compare x y); intro H; [ right | left | right ]; auto. + assert (~ eq y x); auto. + Defined. + +End MOT_to_OT. + (** * Ordered types properties *) (** Additional properties that can be derived from signature [OrderedType]. *) -Module OrderedTypeFacts (O: OrderedType). - Import O. +Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_antirefl : forall x, ~ lt x x. Proof. @@ -293,10 +312,8 @@ Ltac false_order := elimtype False; order. elim (elim_compare_gt (x:=x) (y:=y)); [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}. - Proof. - intros; elim (compare x y); [ right | left | right ]; auto. - Defined. + (** For compatibility reasons *) + Definition eq_dec := eq_dec. Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. Proof. diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/FSets/OrderedTypeAlt.v index 516df0f0..9d179995 100644 --- a/theories/FSets/OrderedTypeAlt.v +++ b/theories/FSets/OrderedTypeAlt.v @@ -11,11 +11,12 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: OrderedTypeAlt.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: OrderedTypeAlt.v 11699 2008-12-18 11:49:08Z letouzey $ *) Require Import OrderedType. -(** * An alternative (but equivalent) presentation for an Ordered Type inferface. *) +(** * An alternative (but equivalent) presentation for an Ordered Type + inferface. *) (** NB: [comparison], defined in [Datatypes.v] is [Eq|Lt|Gt] whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ] @@ -81,6 +82,12 @@ Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. rewrite compare_sym; rewrite H; auto. Defined. + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros; unfold eq. + case (x ?= y); [ left | right | right ]; auto; discriminate. + Defined. + End OrderedType_from_Alt. (** From the original presentation to this alternative one. *) diff --git a/theories/FSets/OrderedTypeEx.v b/theories/FSets/OrderedTypeEx.v index 03171396..03e3ab83 100644 --- a/theories/FSets/OrderedTypeEx.v +++ b/theories/FSets/OrderedTypeEx.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: OrderedTypeEx.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: OrderedTypeEx.v 11699 2008-12-18 11:49:08Z letouzey $ *) Require Import OrderedType. Require Import ZArith. @@ -34,6 +34,7 @@ Module Type UsualOrderedType. Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. Parameter compare : forall x y : t, Compare lt eq x y. + Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. End UsualOrderedType. (** a [UsualOrderedType] is in particular an [OrderedType]. *) @@ -68,6 +69,8 @@ Module Nat_as_OT <: UsualOrderedType. intro; constructor 3; auto. Defined. + Definition eq_dec := eq_nat_dec. + End Nat_as_OT. @@ -99,6 +102,8 @@ Module Z_as_OT <: UsualOrderedType. apply GT; unfold lt, Zlt; rewrite <- Zcompare_Gt_Lt_antisym; auto. Defined. + Definition eq_dec := Z_eq_dec. + End Z_as_OT. (** [positive] is an ordered type with respect to the usual order on natural numbers. *) @@ -140,6 +145,11 @@ Module Positive_as_OT <: UsualOrderedType. rewrite <- Pcompare_antisym; rewrite H; auto. Defined. + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros; unfold eq; decide equality. + Defined. + End Positive_as_OT. @@ -183,6 +193,11 @@ Module N_as_OT <: UsualOrderedType. destruct (Nleb x y); intuition. Defined. + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros. unfold eq. decide equality. apply Positive_as_OT.eq_dec. + Defined. + End N_as_OT. @@ -243,5 +258,12 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. apply GT; unfold lt; auto. Defined. + Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. + Proof. + intros; elim (compare x y); intro H; [ right | left | right ]; auto. + auto using lt_not_eq. + assert (~ eq y x); auto using lt_not_eq, eq_sym. + Defined. + End PairOrderedType. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index e5e6fd23..0163c01c 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Datatypes.v 11073 2008-06-08 20:24:51Z herbelin $ i*) +(*i $Id: Datatypes.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Set Implicit Arguments. @@ -59,19 +59,39 @@ Lemma andb_prop : forall a b:bool, andb a b = true -> a = true /\ b = true. Proof. destruct a; destruct b; intros; split; try (reflexivity || discriminate). Qed. -Hint Resolve andb_prop: bool v62. +Hint Resolve andb_prop: bool. Lemma andb_true_intro : forall b1 b2:bool, b1 = true /\ b2 = true -> andb b1 b2 = true. Proof. destruct b1; destruct b2; simpl in |- *; tauto || auto with bool. Qed. -Hint Resolve andb_true_intro: bool v62. +Hint Resolve andb_true_intro: bool. (** Interpretation of booleans as propositions *) Inductive eq_true : bool -> Prop := is_eq_true : eq_true true. +(** Additional rewriting lemmas about [eq_true] *) + +Lemma eq_true_ind_r : + forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true. +Proof. + intros P b H H0; destruct H0 in H; assumption. +Defined. + +Lemma eq_true_rec_r : + forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true. +Proof. + intros P b H H0; destruct H0 in H; assumption. +Defined. + +Lemma eq_true_rect_r : + forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true. +Proof. + intros P b H H0; destruct H0 in H; assumption. +Defined. + (** [nat] is the datatype of natural numbers built from [O] and successor [S]; note that the constructor name is the letter O. Numbers in [nat] can be denoted using a decimal notation; @@ -95,7 +115,7 @@ Inductive Empty_set : Set :=. Inductive identity (A:Type) (a:A) : A -> Type := refl_identity : identity (A:=A) a a. -Hint Resolve refl_identity: core v62. +Hint Resolve refl_identity: core. Implicit Arguments identity_ind [A]. Implicit Arguments identity_rec [A]. @@ -144,7 +164,7 @@ Section projections. end. End projections. -Hint Resolve pair inl inr: core v62. +Hint Resolve pair inl inr: core. Lemma surjective_pairing : forall (A B:Type) (p:A * B), p = pair (fst p) (snd p). diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 6a636ccc..ae79744f 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Logic.v 10304 2007-11-08 17:06:32Z emakarov $ i*) +(*i $Id: Logic.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Set Implicit Arguments. @@ -150,6 +150,16 @@ Proof. intros; tauto. Qed. +Lemma iff_and : forall A B : Prop, (A <-> B) -> (A -> B) /\ (B -> A). +Proof. +intros A B []; split; trivial. +Qed. + +Lemma iff_to_and : forall A B : Prop, (A <-> B) <-> (A -> B) /\ (B -> A). +Proof. +intros; tauto. +Qed. + (** [(IF_then_else P Q R)], written [IF P then Q else R] denotes either [P] and [Q], or [~P] and [Q] *) @@ -245,8 +255,8 @@ Implicit Arguments eq_ind [A]. Implicit Arguments eq_rec [A]. Implicit Arguments eq_rect [A]. -Hint Resolve I conj or_introl or_intror refl_equal: core v62. -Hint Resolve ex_intro ex_intro2: core v62. +Hint Resolve I conj or_introl or_intror refl_equal: core. +Hint Resolve ex_intro ex_intro2: core. Section Logic_lemmas. @@ -339,7 +349,7 @@ Proof. destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity. Qed. -Hint Immediate sym_eq sym_not_eq: core v62. +Hint Immediate sym_eq sym_not_eq: core. (** Basic definitions about relations and properties *) diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 9ef63cc8..43b1f634 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Peano.v 11115 2008-06-12 16:03:32Z werner $ i*) +(*i $Id: Peano.v 11735 2009-01-02 17:22:31Z herbelin $ i*) (** The type [nat] of Peano natural numbers (built from [O] and [S]) is defined in [Datatypes.v] *) @@ -47,7 +47,7 @@ Hint Resolve (f_equal pred): v62. Theorem pred_Sn : forall n:nat, n = pred (S n). Proof. - simpl; reflexivity. + simpl; reflexivity. Qed. (** Injectivity of successor *) @@ -59,13 +59,13 @@ Proof. rewrite Sn_eq_Sm; trivial. Qed. -Hint Immediate eq_add_S: core v62. +Hint Immediate eq_add_S: core. Theorem not_eq_S : forall n m:nat, n <> m -> S n <> S m. Proof. red in |- *; auto. Qed. -Hint Resolve not_eq_S: core v62. +Hint Resolve not_eq_S: core. Definition IsSucc (n:nat) : Prop := match n with @@ -80,13 +80,13 @@ Proof. unfold not; intros n H. inversion H. Qed. -Hint Resolve O_S: core v62. +Hint Resolve O_S: core. Theorem n_Sn : forall n:nat, n <> S n. Proof. induction n; auto. Qed. -Hint Resolve n_Sn: core v62. +Hint Resolve n_Sn: core. (** Addition *) @@ -105,7 +105,7 @@ Lemma plus_n_O : forall n:nat, n = n + 0. Proof. induction n; simpl in |- *; auto. Qed. -Hint Resolve plus_n_O: core v62. +Hint Resolve plus_n_O: core. Lemma plus_O_n : forall n:nat, 0 + n = n. Proof. @@ -116,7 +116,7 @@ Lemma plus_n_Sm : forall n m:nat, S (n + m) = n + S m. Proof. intros n m; induction n; simpl in |- *; auto. Qed. -Hint Resolve plus_n_Sm: core v62. +Hint Resolve plus_n_Sm: core. Lemma plus_Sn_m : forall n m:nat, S n + m = S (n + m). Proof. @@ -138,13 +138,13 @@ Fixpoint mult (n m:nat) {struct n} : nat := where "n * m" := (mult n m) : nat_scope. -Hint Resolve (f_equal2 mult): core v62. +Hint Resolve (f_equal2 mult): core. Lemma mult_n_O : forall n:nat, 0 = n * 0. Proof. induction n; simpl in |- *; auto. Qed. -Hint Resolve mult_n_O: core v62. +Hint Resolve mult_n_O: core. Lemma mult_n_Sm : forall n m:nat, n * m + n = n * S m. Proof. @@ -152,7 +152,7 @@ Proof. destruct H; rewrite <- plus_n_Sm; apply (f_equal S). pattern m at 1 3 in |- *; elim m; simpl in |- *; auto. Qed. -Hint Resolve mult_n_Sm: core v62. +Hint Resolve mult_n_Sm: core. (** Standard associated names *) @@ -165,16 +165,12 @@ Fixpoint minus (n m:nat) {struct n} : nat := match n, m with | O, _ => n | S k, O => n -(*======= - - | O, _ => n - | S k, O => S k *) | S k, S l => k - l end where "n - m" := (minus n m) : nat_scope. -(** Definition of the usual orders, the basic properties of [le] and [lt] +(** Definition of the usual orders, the basic properties of [le] and [lt] can be found in files Le and Lt *) Inductive le (n:nat) : nat -> Prop := @@ -183,21 +179,21 @@ Inductive le (n:nat) : nat -> Prop := where "n <= m" := (le n m) : nat_scope. -Hint Constructors le: core v62. -(*i equivalent to : "Hints Resolve le_n le_S : core v62." i*) +Hint Constructors le: core. +(*i equivalent to : "Hints Resolve le_n le_S : core." i*) Definition lt (n m:nat) := S n <= m. -Hint Unfold lt: core v62. +Hint Unfold lt: core. Infix "<" := lt : nat_scope. Definition ge (n m:nat) := m <= n. -Hint Unfold ge: core v62. +Hint Unfold ge: core. Infix ">=" := ge : nat_scope. Definition gt (n m:nat) := m < n. -Hint Unfold gt: core v62. +Hint Unfold gt: core. Infix ">" := gt : nat_scope. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 10555fc0..2d7e2159 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Tactics.v 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: Tactics.v 11741 2009-01-03 14:34:39Z herbelin $ i*) Require Import Notations. Require Import Logic. @@ -72,6 +72,17 @@ Ltac false_hyp H G := Ltac case_eq x := generalize (refl_equal x); pattern x at -1; case x. +(* Similar variants of destruct *) + +Tactic Notation "destruct_with_eqn" constr(x) := + destruct x as []_eqn. +Tactic Notation "destruct_with_eqn" ident(n) := + try intros until n; destruct n as []_eqn. +Tactic Notation "destruct_with_eqn" ":" ident(H) constr(x) := + destruct x as []_eqn:H. +Tactic Notation "destruct_with_eqn" ":" ident(H) ident(n) := + try intros until n; destruct n as []_eqn:H. + (* Rewriting in all hypothesis several times everywhere *) Tactic Notation "rewrite_all" constr(eq) := repeat rewrite eq in *. @@ -135,14 +146,31 @@ bapply lemma ltac:(fun H => destruct H as [H _]; apply H in J). Tactic Notation "apply" "<-" constr(lemma) "in" ident(J) := bapply lemma ltac:(fun H => destruct H as [_ H]; apply H in J). -(** A tactic simpler than auto that is useful for ending proofs "in one step" *) -Tactic Notation "now" tactic(t) := -t; -match goal with -| H : _ |- _ => solve [inversion H] -| _ => solve [trivial | reflexivity | symmetry; trivial | discriminate | split] -| _ => fail 1 "Cannot solve this goal." -end. +(** An experimental tactic simpler than auto that is useful for ending + proofs "in one step" *) + +Ltac easy := + let rec use_hyp H := + match type of H with + | _ /\ _ => exact H || destruct_hyp H + | _ => try solve [inversion H] + end + with do_intro := let H := fresh in intro H; use_hyp H + with destruct_hyp H := case H; clear H; do_intro; do_intro in + let rec use_hyps := + match goal with + | H : _ /\ _ |- _ => exact H || (destruct_hyp H; use_hyps) + | H : _ |- _ => solve [inversion H] + | _ => idtac + end in + let rec do_atom := + solve [reflexivity | symmetry; trivial] || + contradiction || + (split; do_atom) + with do_ccl := trivial; repeat do_intro; do_atom in + (use_hyps; do_ccl) || fail "Cannot solve this goal". + +Tactic Notation "now" tactic(t) := t; easy. (** A tactic to document or check what is proved at some point of a script *) Ltac now_show c := change c. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 4edc1581..2592abb5 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: SetoidList.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: SetoidList.v 11800 2009-01-18 18:34:15Z msozeau $ *) Require Export List. Require Export Sorting. @@ -69,10 +69,10 @@ Definition equivlistA l l' := forall x, InA x l <-> InA x l'. (** lists with same elements modulo [eqA] at the same place *) -Inductive eqlistA : list A -> list A -> Prop := - | eqlistA_nil : eqlistA nil nil - | eqlistA_cons : forall x x' l l', - eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). +Inductive eqlistA : list A -> list A -> Prop := + | eqlistA_nil : eqlistA nil nil + | eqlistA_cons : forall x x' l l', + eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). Hint Constructors eqlistA. @@ -445,7 +445,11 @@ Definition compat_op (f : A -> B -> B) := Definition transpose (f : A -> B -> B) := forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). -Variable st:Setoid_Theory _ eqB. +(** A version of transpose with restriction on where it should hold *) +Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) := + forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)). + +Variable st:Equivalence eqB. Variable f:A->B->B. Variable i:B. Variable Comp:compat_op f. @@ -455,17 +459,7 @@ Lemma fold_right_eqlistA : eqB (fold_right f i s) (fold_right f i s'). Proof. induction 1; simpl; auto. -refl_st. -Qed. - -Variable Ass:transpose f. - -Lemma fold_right_commutes : forall s1 s2 x, - eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). -Proof. -induction s1; simpl; auto; intros. -refl_st. -trans_st (f a (f x (fold_right f i (s1++s2)))). +reflexivity. Qed. Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y -> @@ -490,38 +484,193 @@ Proof. destruct H8; auto. elim H0. destruct H7; [left|right]; eapply InA_eqA; eauto. -Qed. +Qed. -Lemma fold_right_equivlistA : - forall s s', NoDupA s -> NoDupA s' -> +(** [ForallList2] : specifies that a certain binary predicate should + always hold when inspecting two different elements of the list. *) + +Inductive ForallList2 (R : A -> A -> Prop) : list A -> Prop := + | ForallNil : ForallList2 R nil + | ForallCons : forall a l, + (forall b, In b l -> R a b) -> + ForallList2 R l -> ForallList2 R (a::l). +Hint Constructors ForallList2. + +(** [NoDupA] can be written in terms of [ForallList2] *) + +Lemma ForallList2_NoDupA : forall l, + ForallList2 (fun a b => ~eqA a b) l <-> NoDupA l. +Proof. + induction l; split; intros; auto. + inversion_clear H. constructor; [ | rewrite <- IHl; auto ]. + rewrite InA_alt; intros (a',(Haa',Ha')). + exact (H0 a' Ha' Haa'). + inversion_clear H. constructor; [ | rewrite IHl; auto ]. + intros b Hb. + contradict H0. + rewrite InA_alt; exists b; auto. +Qed. + +Lemma ForallList2_impl : forall (R R':A->A->Prop), + (forall a b, R a b -> R' a b) -> + forall l, ForallList2 R l -> ForallList2 R' l. +Proof. + induction 2; auto. +Qed. + +(** The following definition is easier to use than [ForallList2]. *) + +Definition ForallList2_alt (R:A->A->Prop) l := + forall a b, InA a l -> InA b l -> ~eqA a b -> R a b. + +Section Restriction. +Variable R : A -> A -> Prop. + +(** [ForallList2] and [ForallList2_alt] are related, but no completely + equivalent. For proving one implication, we need to know that the + list has no duplicated elements... *) + +Lemma ForallList2_equiv1 : forall l, NoDupA l -> + ForallList2_alt R l -> ForallList2 R l. +Proof. + induction l; auto. + constructor. intros b Hb. + inversion_clear H. + apply H0; auto. + contradict H1. + apply InA_eqA with b; auto. + apply IHl. + inversion_clear H; auto. + intros b c Hb Hc Hneq. + apply H0; auto. +Qed. + +(** ... and for proving the other implication, we need to be able + to reverse and adapt relation [R] modulo [eqA]. *) + +Hypothesis R_sym : forall a b, R a b -> R b a. +Hypothesis R_compat : forall a, compat_P (R a). + +Lemma ForallList2_equiv2 : forall l, + ForallList2 R l -> ForallList2_alt R l. +Proof. + induction l. + intros _. red. intros a b Ha. inversion Ha. + inversion_clear 1 as [|? ? H_R Hl]. + intros b c Hb Hc Hneq. + inversion_clear Hb; inversion_clear Hc. + (* b,c = a : impossible *) + elim Hneq; eauto. + (* b = a, c in l *) + rewrite InA_alt in H0; destruct H0 as (d,(Hcd,Hd)). + apply R_compat with d; auto. + apply R_sym; apply R_compat with a; auto. + (* b in l, c = a *) + rewrite InA_alt in H; destruct H as (d,(Hcd,Hd)). + apply R_compat with a; auto. + apply R_sym; apply R_compat with d; auto. + (* b,c in l *) + apply (IHl Hl); auto. +Qed. + +Lemma ForallList2_equiv : forall l, NoDupA l -> + (ForallList2 R l <-> ForallList2_alt R l). +Proof. +split; [apply ForallList2_equiv2|apply ForallList2_equiv1]; auto. +Qed. + +Lemma ForallList2_equivlistA : forall l l', NoDupA l' -> + equivlistA l l' -> ForallList2 R l -> ForallList2 R l'. +Proof. +intros. +apply ForallList2_equiv1; auto. +intros a b Ha Hb Hneq. +red in H0; rewrite <- H0 in Ha,Hb. +revert a b Ha Hb Hneq. +change (ForallList2_alt R l). +apply ForallList2_equiv2; auto. +Qed. + +Variable TraR :transpose_restr R f. + +Lemma fold_right_commutes_restr : + forall s1 s2 x, ForallList2 R (s1++x::s2) -> + eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). +Proof. +induction s1; simpl; auto; intros. +reflexivity. +transitivity (f a (f x (fold_right f i (s1++s2)))). +apply Comp; auto. +apply IHs1. +inversion_clear H; auto. +apply TraR. +inversion_clear H. +apply H0. +apply in_or_app; simpl; auto. +Qed. + +Lemma fold_right_equivlistA_restr : + forall s s', NoDupA s -> NoDupA s' -> ForallList2 R s -> equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. simple induction s. destruct s'; simpl. - intros; refl_st; auto. + intros; reflexivity. unfold equivlistA; intros. - destruct (H1 a). + destruct (H2 a). assert (X : InA a nil); auto; inversion X. - intros x l Hrec s' N N' E; simpl in *. + intros x l Hrec s' N N' F E; simpl in *. assert (InA x s'). rewrite <- (E x); auto. destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). subst s'. - trans_st (f x (fold_right f i (s1++s2))). + transitivity (f x (fold_right f i (s1++s2))). apply Comp; auto. apply Hrec; auto. inversion_clear N; auto. eapply NoDupA_split; eauto. + inversion_clear F; auto. eapply equivlistA_NoDupA_split; eauto. - trans_st (f y (fold_right f i (s1++s2))). - apply Comp; auto; refl_st. - sym_st; apply fold_right_commutes. + transitivity (f y (fold_right f i (s1++s2))). + apply Comp; auto. reflexivity. + symmetry; apply fold_right_commutes_restr. + apply ForallList2_equivlistA with (x::l); auto. +Qed. + +Lemma fold_right_add_restr : + forall s' s x, NoDupA s -> NoDupA s' -> ForallList2 R s' -> ~ InA x s -> + equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). +Proof. + intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto. +Qed. + +End Restriction. + +(** we know state similar results, but without restriction on transpose. *) + +Variable Tra :transpose f. + +Lemma fold_right_commutes : forall s1 s2 x, + eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). +Proof. +induction s1; simpl; auto; intros. +reflexivity. +transitivity (f a (f x (fold_right f i (s1++s2)))); auto. +Qed. + +Lemma fold_right_equivlistA : + forall s s', NoDupA s -> NoDupA s' -> + equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). +Proof. +intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True); + try red; auto. +apply ForallList2_equiv1; try red; auto. Qed. Lemma fold_right_add : forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). -Proof. +Proof. intros; apply (@fold_right_equivlistA s' (x::s)); auto. Qed. @@ -538,7 +687,7 @@ destruct (eqA_dec x a). left; auto. destruct IHl. left; auto. -right; red; inversion_clear 1; tauto. +right; red; inversion_clear 1; contradiction. Qed. Fixpoint removeA (x : A) (l : list A){struct l} : list A := @@ -547,7 +696,7 @@ Fixpoint removeA (x : A) (l : list A){struct l} : list A := | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl) end. -Lemma removeA_filter : forall x l, +Lemma removeA_filter : forall x l, removeA x l = filter (fun y => if eqA_dec x y then false else true) l. Proof. induction l; simpl; auto. diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v index d15e2c96..31c41120 100644 --- a/theories/Logic/ClassicalDescription.v +++ b/theories/Logic/ClassicalDescription.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalDescription.v 11238 2008-07-19 09:34:03Z herbelin $ i*) +(*i $Id: ClassicalDescription.v 11481 2008-10-20 19:23:51Z herbelin $ i*) (** This file provides classical logic and definite description, which is equivalent to providing classical logic and Church's iota operator *) @@ -21,7 +21,7 @@ Set Implicit Arguments. Require Export Classical. Require Import ChoiceFacts. -Notation Local inhabited A := A. +Notation Local inhabited A := A (only parsing). Axiom constructive_definite_description : forall (A : Type) (P : A->Prop), (exists! x : A, P x) -> { x : A | P x }. diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index 8a045ec8..db92696b 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalFacts.v 11238 2008-07-19 09:34:03Z herbelin $ i*) +(*i $Id: ClassicalFacts.v 11481 2008-10-20 19:23:51Z herbelin $ i*) (** Some facts and definitions about classical logic @@ -119,7 +119,7 @@ Qed. *) -Notation Local inhabited A := A. +Notation Local inhabited A := A (only parsing). Lemma prop_ext_A_eq_A_imp_A : prop_extensionality -> forall A:Prop, inhabited A -> (A -> A) = A. diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index a7c098e8..00d63252 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Decidable.v 10500 2008-02-02 15:51:00Z letouzey $ i*) +(*i $Id: Decidable.v 11735 2009-01-02 17:22:31Z herbelin $ i*) (** Properties of decidable propositions *) @@ -80,6 +80,13 @@ Proof. unfold decidable; tauto. Qed. +Theorem not_iff : + forall A B:Prop, decidable A -> decidable B -> + ~ (A <-> B) -> (A /\ ~ B) \/ (~ A /\ B). +Proof. +unfold decidable; tauto. +Qed. + (** Results formulated with iff, used in FSetDecide. Negation are expanded since it is unclear whether setoid rewrite will always perform conversion. *) diff --git a/theories/Logic/DecidableTypeEx.v b/theories/Logic/DecidableTypeEx.v index 9c928598..9c59c519 100644 --- a/theories/Logic/DecidableTypeEx.v +++ b/theories/Logic/DecidableTypeEx.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: DecidableTypeEx.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: DecidableTypeEx.v 11699 2008-12-18 11:49:08Z letouzey $ *) Require Import DecidableType OrderedType OrderedTypeEx. Set Implicit Arguments. @@ -46,24 +46,16 @@ Module Make_UDT (M:MiniDecidableType) <: UsualDecidableType. Definition eq_dec := M.eq_dec. End Make_UDT. -(** An OrderedType can be seen as a DecidableType *) +(** An OrderedType can now directly be seen as a DecidableType *) -Module OT_as_DT (O:OrderedType) <: DecidableType. - Module OF := OrderedTypeFacts O. - Definition t := O.t. - Definition eq := O.eq. - Definition eq_refl := O.eq_refl. - Definition eq_sym := O.eq_sym. - Definition eq_trans := O.eq_trans. - Definition eq_dec := OF.eq_dec. -End OT_as_DT. +Module OT_as_DT (O:OrderedType) <: DecidableType := O. (** (Usual) Decidable Type for [nat], [positive], [N], [Z] *) -Module Nat_as_DT <: UsualDecidableType := OT_as_DT (Nat_as_OT). -Module Positive_as_DT <: UsualDecidableType := OT_as_DT (Positive_as_OT). -Module N_as_DT <: UsualDecidableType := OT_as_DT (N_as_OT). -Module Z_as_DT <: UsualDecidableType := OT_as_DT (Z_as_OT). +Module Nat_as_DT <: UsualDecidableType := Nat_as_OT. +Module Positive_as_DT <: UsualDecidableType := Positive_as_OT. +Module N_as_DT <: UsualDecidableType := N_as_OT. +Module Z_as_DT <: UsualDecidableType := Z_as_OT. (** From two decidable types, we can build a new DecidableType over their cartesian product. *) @@ -99,7 +91,7 @@ End PairDecidableType. (** Similarly for pairs of UsualDecidableType *) -Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: DecidableType. +Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. Definition t := prod D1.t D2.t. Definition eq := @eq t. Definition eq_refl := @refl_equal t. diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 880ef7e2..b935a676 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Diaconescu.v 11238 2008-07-19 09:34:03Z herbelin $ i*) +(*i $Id: Diaconescu.v 11481 2008-10-20 19:23:51Z herbelin $ i*) (** Diaconescu showed that the Axiom of Choice entails Excluded-Middle in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show @@ -267,7 +267,7 @@ End ProofIrrel_RelChoice_imp_EqEM. (** Proof sketch from Bell [Bell93] (with thanks to P. Castéran) *) -Notation Local inhabited A := A. +Notation Local inhabited A := A (only parsing). Section ExtensionalEpsilon_imp_EM. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 844bff88..d5738c82 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: EqdepFacts.v 11095 2008-06-10 19:36:10Z herbelin $ i*) +(*i $Id: EqdepFacts.v 11735 2009-01-02 17:22:31Z herbelin $ i*) (** This file defines dependent equality and shows its equivalence with equality on dependent pairs (inhabiting sigma-types). It derives @@ -53,7 +53,7 @@ Section Dependent_Equality. Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop := eq_dep_intro : eq_dep p x p x. - Hint Constructors eq_dep: core v62. + Hint Constructors eq_dep: core. Lemma eq_dep_refl : forall (p:U) (x:P p), eq_dep p x p x. Proof eq_dep_intro. @@ -63,7 +63,7 @@ Section Dependent_Equality. Proof. destruct 1; auto. Qed. - Hint Immediate eq_dep_sym: core v62. + Hint Immediate eq_dep_sym: core. Lemma eq_dep_trans : forall (p q r:U) (x:P p) (y:P q) (z:P r), @@ -135,8 +135,8 @@ Qed. (** Exported hints *) -Hint Resolve eq_dep_intro: core v62. -Hint Immediate eq_dep_sym: core v62. +Hint Resolve eq_dep_intro: core. +Hint Immediate eq_dep_sym: core. (************************************************************************) (** * Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K *) diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v new file mode 100644 index 00000000..4445b0e1 --- /dev/null +++ b/theories/Logic/FunctionalExtensionality.v @@ -0,0 +1,60 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* B}, + f = g -> forall x, f x = g x. +Proof. + intros. + rewrite H. + auto. +Qed. + +(** Statements of functional extensionality for simple and dependent functions. *) + +Axiom functional_extensionality_dep : forall {A} {B : A -> Type}, + forall (f g : forall x : A, B x), + (forall x, f x = g x) -> f = g. + +Lemma functional_extensionality {A B} (f g : A -> B) : + (forall x, f x = g x) -> f = g. +Proof. + intros ; eauto using @functional_extensionality_dep. +Qed. + +(** Apply [functional_extensionality], introducing variable x. *) + +Tactic Notation "extensionality" ident(x) := + match goal with + [ |- ?X = ?Y ] => + (apply (@functional_extensionality _ _ X Y) || + apply (@functional_extensionality_dep _ _ X Y)) ; intro x + end. + +(** Eta expansion follows from extensionality. *) + +Lemma eta_expansion_dep {A} {B : A -> Type} (f : forall x : A, B x) : + f = fun x => f x. +Proof. + intros. + extensionality x. + reflexivity. +Qed. + +Lemma eta_expansion {A B} (f : A -> B) : f = fun x => f x. +Proof. + intros A B f. apply (eta_expansion_dep f). +Qed. diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index 20dabed2..3752abcc 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BinNat.v 10806 2008-04-16 23:51:06Z letouzey $ i*) +(*i $Id: BinNat.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Require Import BinPos. Unset Boxed Definitions. @@ -393,10 +393,10 @@ Theorem Ncompare_n_Sm : Proof. intros n m; split; destruct n as [| p]; destruct m as [| q]; simpl; auto. destruct p; simpl; intros; discriminate. -pose proof (proj1 (Pcompare_p_Sq p q)); +pose proof (Pcompare_p_Sq p q) as (?,_). assert (p = q <-> Npos p = Npos q); [split; congruence | tauto]. intros H; destruct H; discriminate. -pose proof (proj2 (Pcompare_p_Sq p q)); +pose proof (Pcompare_p_Sq p q) as (_,?); assert (p = q <-> Npos p = Npos q); [split; congruence | tauto]. Qed. diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index dcdb5f92..fb32274e 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ndigits.v 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id: Ndigits.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Require Import Bool. Require Import Bvector. @@ -52,8 +52,8 @@ Proof. destruct n; destruct n'; simpl; auto. generalize p0; clear p0; induction p as [p Hrecp| p Hrecp| ]; simpl; auto. - destruct p0; simpl; trivial; intros; rewrite Hrecp; trivial. - destruct p0; simpl; trivial; intros; rewrite Hrecp; trivial. + destruct p0; trivial; rewrite Hrecp; trivial. + destruct p0; trivial; rewrite Hrecp; trivial. destruct p0 as [p| p| ]; simpl; auto. Qed. @@ -115,7 +115,7 @@ Definition xorf (f g:nat -> bool) (n:nat) := xorb (f n) (g n). Lemma xorf_eq : forall f f', eqf (xorf f f') (fun n => false) -> eqf f f'. Proof. - unfold eqf, xorf. intros. apply xorb_eq. apply H. + unfold eqf, xorf. intros. apply xorb_eq, H. Qed. Lemma xorf_assoc : @@ -166,14 +166,12 @@ Lemma Nbit_faithful_3 : (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') -> eqf (Nbit (Npos (xO p))) (Nbit a) -> Npos (xO p) = a. Proof. - destruct a. intros. cut (eqf (Nbit N0) (Nbit (Npos (xO p)))). + destruct a; intros. cut (eqf (Nbit N0) (Nbit (Npos (xO p)))). intro. rewrite (Nbit_faithful_1 (Npos (xO p)) H1). reflexivity. unfold eqf. intro. unfold eqf in H0. rewrite H0. reflexivity. - case p. intros. absurd (false = true). discriminate. - exact (H0 0). - intros. rewrite (H p0 (fun n => H0 (S n))). reflexivity. - intros. absurd (false = true). discriminate. - exact (H0 0). + destruct p. discriminate (H0 O). + rewrite (H p (fun n => H0 (S n))). reflexivity. + discriminate (H0 0). Qed. Lemma Nbit_faithful_4 : @@ -181,27 +179,26 @@ Lemma Nbit_faithful_4 : (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') -> eqf (Nbit (Npos (xI p))) (Nbit a) -> Npos (xI p) = a. Proof. - destruct a. intros. cut (eqf (Nbit N0) (Nbit (Npos (xI p)))). + destruct a; intros. cut (eqf (Nbit N0) (Nbit (Npos (xI p)))). intro. rewrite (Nbit_faithful_1 (Npos (xI p)) H1). reflexivity. - unfold eqf. intro. unfold eqf in H0. rewrite H0. reflexivity. - case p. intros. rewrite (H p0 (fun n:nat => H0 (S n))). reflexivity. - intros. absurd (true = false). discriminate. - exact (H0 0). - intros. absurd (N0 = Npos p0). discriminate. + intro. rewrite H0. reflexivity. + destruct p. rewrite (H p (fun n:nat => H0 (S n))). reflexivity. + discriminate (H0 0). cut (eqf (Nbit (Npos 1)) (Nbit (Npos (xI p0)))). - intro. exact (Nbit_faithful_1 (Npos p0) (fun n:nat => H1 (S n))). - unfold eqf in *. intro. rewrite H0. reflexivity. + intro. discriminate (Nbit_faithful_1 (Npos p0) (fun n:nat => H1 (S n))). + intro. rewrite H0. reflexivity. Qed. Lemma Nbit_faithful : forall a a':N, eqf (Nbit a) (Nbit a') -> a = a'. Proof. destruct a. exact Nbit_faithful_1. - induction p. intros a' H. apply Nbit_faithful_4. intros. cut (Npos p = Npos p'). - intro. inversion H1. reflexivity. - exact (IHp (Npos p') H0). + induction p. intros a' H. apply Nbit_faithful_4. intros. + assert (Npos p = Npos p') by exact (IHp (Npos p') H0). + inversion H1. reflexivity. assumption. - intros. apply Nbit_faithful_3. intros. cut (Npos p = Npos p'). intro. inversion H1. reflexivity. - exact (IHp (Npos p') H0). + intros. apply Nbit_faithful_3. intros. + assert (Npos p = Npos p') by exact (IHp (Npos p') H0). + inversion H1. reflexivity. assumption. exact Nbit_faithful_2. Qed. @@ -216,40 +213,37 @@ Qed. Lemma Nxor_sem_2 : forall a':N, Nbit (Nxor (Npos 1) a') 0 = negb (Nbit a' 0). Proof. - intro. case a'. trivial. - simpl. intro. - case p; trivial. + intro. destruct a'. trivial. + destruct p; trivial. Qed. Lemma Nxor_sem_3 : forall (p:positive) (a':N), Nbit (Nxor (Npos (xO p)) a') 0 = Nbit a' 0. Proof. - intros. case a'. trivial. - simpl. intro. - case p0; trivial. intro. - case (Pxor p p1); trivial. - intro. case (Pxor p p1); trivial. + intros. destruct a'. trivial. + simpl. destruct p0; trivial. + destruct (Pxor p p0); trivial. + destruct (Pxor p p0); trivial. Qed. Lemma Nxor_sem_4 : forall (p:positive) (a':N), Nbit (Nxor (Npos (xI p)) a') 0 = negb (Nbit a' 0). Proof. - intros. case a'. trivial. - simpl. intro. case p0; trivial. intro. - case (Pxor p p1); trivial. - intro. - case (Pxor p p1); trivial. + intros. destruct a'. trivial. + simpl. destruct p0; trivial. + destruct (Pxor p p0); trivial. + destruct (Pxor p p0); trivial. Qed. Lemma Nxor_sem_5 : forall a a':N, Nbit (Nxor a a') 0 = xorf (Nbit a) (Nbit a') 0. Proof. - destruct a. intro. change (Nbit a' 0 = xorb false (Nbit a' 0)). rewrite false_xorb. trivial. - case p. exact Nxor_sem_4. - intros. change (Nbit (Nxor (Npos (xO p0)) a') 0 = xorb false (Nbit a' 0)). - rewrite false_xorb. apply Nxor_sem_3. exact Nxor_sem_2. + destruct a; intro. change (Nbit a' 0 = xorb false (Nbit a' 0)). rewrite false_xorb. trivial. + destruct p. apply Nxor_sem_4. + change (Nbit (Nxor (Npos (xO p)) a') 0 = xorb false (Nbit a' 0)). + rewrite false_xorb. apply Nxor_sem_3. apply Nxor_sem_2. Qed. Lemma Nxor_sem_6 : @@ -258,28 +252,29 @@ Lemma Nxor_sem_6 : forall a a':N, Nbit (Nxor a a') (S n) = xorf (Nbit a) (Nbit a') (S n). Proof. - intros. + intros. +(* pose proof (fun p1 p2 => H (Npos p1) (Npos p2)) as H'. clear H. rename H' into H.*) generalize (fun p1 p2 => H (Npos p1) (Npos p2)); clear H; intro H. unfold xorf in *. - case a. simpl Nbit; rewrite false_xorb. reflexivity. - case a'; intros. + destruct a as [|p]. simpl Nbit; rewrite false_xorb. reflexivity. + destruct a' as [|p0]. simpl Nbit; rewrite xorb_false. reflexivity. - case p0. case p; intros; simpl Nbit in *. - rewrite <- H; simpl; case (Pxor p2 p1); trivial. - rewrite <- H; simpl; case (Pxor p2 p1); trivial. + destruct p. destruct p0; simpl Nbit in *. + rewrite <- H; simpl; case (Pxor p p0); trivial. + rewrite <- H; simpl; case (Pxor p p0); trivial. rewrite xorb_false. reflexivity. - case p; intros; simpl Nbit in *. - rewrite <- H; simpl; case (Pxor p2 p1); trivial. - rewrite <- H; simpl; case (Pxor p2 p1); trivial. + destruct p0; simpl Nbit in *. + rewrite <- H; simpl; case (Pxor p p0); trivial. + rewrite <- H; simpl; case (Pxor p p0); trivial. rewrite xorb_false. reflexivity. - simpl Nbit. rewrite false_xorb. simpl. case p; trivial. + simpl Nbit. rewrite false_xorb. destruct p0; trivial. Qed. Lemma Nxor_semantics : forall a a':N, eqf (Nbit (Nxor a a')) (xorf (Nbit a) (Nbit a')). Proof. - unfold eqf. intros. generalize a a'. elim n. exact Nxor_sem_5. - exact Nxor_sem_6. + unfold eqf. intros; generalize a, a'. induction n. + apply Nxor_sem_5. apply Nxor_sem_6; assumption. Qed. (** Consequences: @@ -289,8 +284,8 @@ Qed. Lemma Nxor_eq : forall a a':N, Nxor a a' = N0 -> a = a'. Proof. - intros. apply Nbit_faithful. apply xorf_eq. apply eqf_trans with (f' := Nbit (Nxor a a')). - apply eqf_sym. apply Nxor_semantics. + intros. apply Nbit_faithful, xorf_eq. apply eqf_trans with (f' := Nbit (Nxor a a')). + apply eqf_sym, Nxor_semantics. rewrite H. unfold eqf. trivial. Qed. @@ -298,19 +293,17 @@ Lemma Nxor_assoc : forall a a' a'':N, Nxor (Nxor a a') a'' = Nxor a (Nxor a' a''). Proof. intros. apply Nbit_faithful. - apply eqf_trans with - (f' := xorf (xorf (Nbit a) (Nbit a')) (Nbit a'')). - apply eqf_trans with (f' := xorf (Nbit (Nxor a a')) (Nbit a'')). + apply eqf_trans with (xorf (xorf (Nbit a) (Nbit a')) (Nbit a'')). + apply eqf_trans with (xorf (Nbit (Nxor a a')) (Nbit a'')). apply Nxor_semantics. apply eqf_xorf. apply Nxor_semantics. apply eqf_refl. - apply eqf_trans with - (f' := xorf (Nbit a) (xorf (Nbit a') (Nbit a''))). + apply eqf_trans with (xorf (Nbit a) (xorf (Nbit a') (Nbit a''))). apply xorf_assoc. - apply eqf_trans with (f' := xorf (Nbit a) (Nbit (Nxor a' a''))). + apply eqf_trans with (xorf (Nbit a) (Nbit (Nxor a' a''))). apply eqf_xorf. apply eqf_refl. - apply eqf_sym. apply Nxor_semantics. - apply eqf_sym. apply Nxor_semantics. + apply eqf_sym, Nxor_semantics. + apply eqf_sym, Nxor_semantics. Qed. (** Checking whether a number is odd, i.e. @@ -370,18 +363,16 @@ Qed. Lemma Nxor_bit0 : forall a a':N, Nbit0 (Nxor a a') = xorb (Nbit0 a) (Nbit0 a'). Proof. - intros. rewrite <- Nbit0_correct. rewrite (Nxor_semantics a a' 0). - unfold xorf. rewrite Nbit0_correct. rewrite Nbit0_correct. reflexivity. + intros. rewrite <- Nbit0_correct, (Nxor_semantics a a' 0). + unfold xorf. rewrite Nbit0_correct, Nbit0_correct. reflexivity. Qed. Lemma Nxor_div2 : forall a a':N, Ndiv2 (Nxor a a') = Nxor (Ndiv2 a) (Ndiv2 a'). Proof. intros. apply Nbit_faithful. unfold eqf. intro. - rewrite (Nxor_semantics (Ndiv2 a) (Ndiv2 a') n). - rewrite Ndiv2_correct. - rewrite (Nxor_semantics a a' (S n)). - unfold xorf. rewrite Ndiv2_correct. rewrite Ndiv2_correct. + rewrite (Nxor_semantics (Ndiv2 a) (Ndiv2 a') n), Ndiv2_correct, (Nxor_semantics a a' (S n)). + unfold xorf. rewrite 2! Ndiv2_correct. reflexivity. Qed. @@ -389,8 +380,9 @@ Lemma Nneg_bit0 : forall a a':N, Nbit0 (Nxor a a') = true -> Nbit0 a = negb (Nbit0 a'). Proof. - intros. rewrite <- true_xorb. rewrite <- H. rewrite Nxor_bit0. - rewrite xorb_assoc. rewrite xorb_nilpotent. rewrite xorb_false. reflexivity. + intros. + rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, xorb_nilpotent, xorb_false. + reflexivity. Qed. Lemma Nneg_bit0_1 : @@ -410,10 +402,9 @@ Lemma Nsame_bit0 : forall (a a':N) (p:positive), Nxor a a' = Npos (xO p) -> Nbit0 a = Nbit0 a'. Proof. - intros. rewrite <- (xorb_false (Nbit0 a)). cut (Nbit0 (Npos (xO p)) = false). - intro. rewrite <- H0. rewrite <- H. rewrite Nxor_bit0. rewrite <- xorb_assoc. - rewrite xorb_nilpotent. rewrite false_xorb. reflexivity. - reflexivity. + intros. rewrite <- (xorb_false (Nbit0 a)). + assert (H0: Nbit0 (Npos (xO p)) = false) by reflexivity. + rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb. reflexivity. Qed. (** a lexicographic order on bits, starting from the lowest bit *) @@ -434,42 +425,40 @@ Lemma Nbit0_less : forall a a', Nbit0 a = false -> Nbit0 a' = true -> Nless a a' = true. Proof. - intros. elim (Ndiscr (Nxor a a')). intro H1. elim H1. intros p H2. unfold Nless in |- *. - rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity. - intros. cut (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 a a') in H5. - rewrite H in H5. rewrite H0 in H5. discriminate H5. - rewrite H4. reflexivity. - intro. simpl in |- *. rewrite H. rewrite H0. reflexivity. - intro H1. cut (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 a a') in H2. - rewrite H in H2. rewrite H0 in H2. discriminate H2. - rewrite H1. reflexivity. + intros. destruct (Ndiscr (Nxor a a')) as [(p,H2)|H1]. unfold Nless. + rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity. + assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity). + rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1. + simpl. rewrite H, H0. reflexivity. + assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). + rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2. Qed. Lemma Nbit0_gt : forall a a', Nbit0 a = true -> Nbit0 a' = false -> Nless a a' = false. Proof. - intros. elim (Ndiscr (Nxor a a')). intro H1. elim H1. intros p H2. unfold Nless in |- *. - rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity. - intros. cut (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 a a') in H5. - rewrite H in H5. rewrite H0 in H5. discriminate H5. - rewrite H4. reflexivity. - intro. simpl in |- *. rewrite H. rewrite H0. reflexivity. - intro H1. unfold Nless in |- *. rewrite H1. reflexivity. + intros. destruct (Ndiscr (Nxor a a')) as [(p,H2)|H1]. unfold Nless. + rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity. + assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity). + rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1. + simpl. rewrite H, H0. reflexivity. + assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). + rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2. Qed. Lemma Nless_not_refl : forall a, Nless a a = false. Proof. - intro. unfold Nless in |- *. rewrite (Nxor_nilpotent a). reflexivity. + intro. unfold Nless. rewrite (Nxor_nilpotent a). reflexivity. Qed. Lemma Nless_def_1 : forall a a', Nless (Ndouble a) (Ndouble a') = Nless a a'. Proof. - simple induction a. simple induction a'. reflexivity. + destruct a; destruct a'. reflexivity. trivial. - simple induction a'. unfold Nless in |- *. simpl in |- *. elim p; trivial. - unfold Nless in |- *. simpl in |- *. intro. case (Pxor p p0). reflexivity. + unfold Nless. simpl. destruct p; trivial. + unfold Nless. simpl. destruct (Pxor p p0). reflexivity. trivial. Qed. @@ -477,10 +466,10 @@ Lemma Nless_def_2 : forall a a', Nless (Ndouble_plus_one a) (Ndouble_plus_one a') = Nless a a'. Proof. - simple induction a. simple induction a'. reflexivity. + destruct a; destruct a'. reflexivity. trivial. - simple induction a'. unfold Nless in |- *. simpl in |- *. elim p; trivial. - unfold Nless in |- *. simpl in |- *. intro. case (Pxor p p0). reflexivity. + unfold Nless. simpl. destruct p; trivial. + unfold Nless. simpl. destruct (Pxor p p0). reflexivity. trivial. Qed. @@ -500,79 +489,71 @@ Qed. Lemma Nless_z : forall a, Nless a N0 = false. Proof. - simple induction a. reflexivity. - unfold Nless in |- *. intro. rewrite (Nxor_neutral_right (Npos p)). elim p; trivial. + induction a. reflexivity. + unfold Nless. rewrite (Nxor_neutral_right (Npos p)). induction p; trivial. Qed. Lemma N0_less_1 : forall a, Nless N0 a = true -> {p : positive | a = Npos p}. Proof. - simple induction a. intro. discriminate H. - intros. split with p. reflexivity. + destruct a. intros. discriminate. + intros. exists p. reflexivity. Qed. Lemma N0_less_2 : forall a, Nless N0 a = false -> a = N0. Proof. - simple induction a. trivial. - unfold Nless in |- *. simpl in |- *. - cut (forall p:positive, Nless_aux N0 (Npos p) p = false -> False). - intros. elim (H p H0). - simple induction p. intros. discriminate H0. - intros. exact (H H0). - intro. discriminate H. + induction a as [|p]; intro H. trivial. + elimtype False. induction p as [|p IHp|]; discriminate || simpl; auto using IHp. Qed. Lemma Nless_trans : forall a a' a'', Nless a a' = true -> Nless a' a'' = true -> Nless a a'' = true. Proof. - intro a. pattern a; apply N_ind_double. - intros. case_eq (Nless N0 a''). trivial. - intro H1. rewrite (N0_less_2 a'' H1) in H0. rewrite (Nless_z a') in H0. discriminate H0. - intros a0 H a'. pattern a'; apply N_ind_double. - intros. rewrite (Nless_z (Ndouble a0)) in H0. discriminate H0. - intros a1 H0 a'' H1. rewrite (Nless_def_1 a0 a1) in H1. - pattern a''; apply N_ind_double; clear a''. - intro. rewrite (Nless_z (Ndouble a1)) in H2. discriminate H2. - intros. rewrite (Nless_def_1 a1 a2) in H3. rewrite (Nless_def_1 a0 a2). - exact (H a1 a2 H1 H3). - intros. apply Nless_def_3. - intros a1 H0 a'' H1. pattern a''; apply N_ind_double. - intro. rewrite (Nless_z (Ndouble_plus_one a1)) in H2. discriminate H2. - intros. rewrite (Nless_def_4 a1 a2) in H3. discriminate H3. - intros. apply Nless_def_3. - intros a0 H a'. pattern a'; apply N_ind_double. - intros. rewrite (Nless_z (Ndouble_plus_one a0)) in H0. discriminate H0. - intros. rewrite (Nless_def_4 a0 a1) in H1. discriminate H1. - intros a1 H0 a'' H1. pattern a''; apply N_ind_double. - intro. rewrite (Nless_z (Ndouble_plus_one a1)) in H2. discriminate H2. - intros. rewrite (Nless_def_4 a1 a2) in H3. discriminate H3. - rewrite (Nless_def_2 a0 a1) in H1. intros. rewrite (Nless_def_2 a1 a2) in H3. - rewrite (Nless_def_2 a0 a2). exact (H a1 a2 H1 H3). + induction a as [|a IHa|a IHa] using N_ind_double; intros a' a'' H H0. + destruct (Nless N0 a'') as []_eqn:Heqb. trivial. + rewrite (N0_less_2 a'' Heqb), (Nless_z a') in H0. discriminate H0. + induction a' as [|a' _|a' _] using N_ind_double. + rewrite (Nless_z (Ndouble a)) in H. discriminate H. + rewrite (Nless_def_1 a a') in H. + induction a'' using N_ind_double. + rewrite (Nless_z (Ndouble a')) in H0. discriminate H0. + rewrite (Nless_def_1 a' a'') in H0. rewrite (Nless_def_1 a a''). + exact (IHa _ _ H H0). + apply Nless_def_3. + induction a'' as [|a'' _|a'' _] using N_ind_double. + rewrite (Nless_z (Ndouble_plus_one a')) in H0. discriminate H0. + rewrite (Nless_def_4 a' a'') in H0. discriminate H0. + apply Nless_def_3. + induction a' as [|a' _|a' _] using N_ind_double. + rewrite (Nless_z (Ndouble_plus_one a)) in H. discriminate H. + rewrite (Nless_def_4 a a') in H. discriminate H. + induction a'' using N_ind_double. + rewrite (Nless_z (Ndouble_plus_one a')) in H0. discriminate H0. + rewrite (Nless_def_4 a' a'') in H0. discriminate H0. + rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H. + rewrite (Nless_def_2 a a''). exact (IHa _ _ H H0). Qed. Lemma Nless_total : forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}. Proof. - intro a. - pattern a; apply N_rec_double; clear a. - intro. case_eq (Nless N0 a'). intro H. left. left. auto. - intro H. right. rewrite (N0_less_2 a' H). reflexivity. - intros a0 H a'. - pattern a'; apply N_rec_double; clear a'. - case_eq (Nless N0 (Ndouble a0)). intro H0. left. right. auto. - intro H0. right. exact (N0_less_2 _ H0). - intros a1 H0. rewrite Nless_def_1. rewrite Nless_def_1. elim (H a1). intro H1. - left. assumption. - intro H1. right. rewrite H1. reflexivity. - intros a1 H0. left. left. apply Nless_def_3. - intros a0 H a'. - pattern a'; apply N_rec_double; clear a'. - left. right. case a0; reflexivity. - intros a1 H0. left. right. apply Nless_def_3. - intros a1 H0. rewrite Nless_def_2. rewrite Nless_def_2. elim (H a1). intro H1. - left. assumption. - intro H1. right. rewrite H1. reflexivity. + induction a using N_rec_double; intro a'. + destruct (Nless N0 a') as []_eqn:Heqb. left. left. auto. + right. rewrite (N0_less_2 a' Heqb). reflexivity. + induction a' as [|a' _|a' _] using N_rec_double. + destruct (Nless N0 (Ndouble a)) as []_eqn:Heqb. left. right. auto. + right. exact (N0_less_2 _ Heqb). + rewrite 2!Nless_def_1. destruct (IHa a') as [ | ->]. + left. assumption. + right. reflexivity. + left. left. apply Nless_def_3. + induction a' as [|a' _|a' _] using N_rec_double. + left. right. destruct a; reflexivity. + left. right. apply Nless_def_3. + rewrite 2!Nless_def_2. destruct (IHa a') as [ | ->]. + left. assumption. + right. reflexivity. Qed. (** Number of digits in a number *) @@ -621,7 +602,7 @@ Proof. induction n; intros. rewrite (V0_eq _ bv); simpl; auto. rewrite (VSn_eq _ _ bv); simpl. -generalize (IHn (Vtail _ _ bv)); clear IHn. +specialize IHn with (Vtail _ _ bv). destruct (Vhead _ _ bv); destruct (Bv2N n (Vtail bool n bv)); simpl; auto with arith. @@ -701,7 +682,7 @@ Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)), Proof. intros. unfold Blow. -pattern bv at 1; rewrite (VSn_eq _ _ bv). +rewrite (VSn_eq _ _ bv) at 1. simpl. destruct (Bv2N n (Vtail bool n bv)); simpl; destruct (Vhead bool n bv); auto. @@ -750,9 +731,9 @@ Lemma Nxor_BVxor : forall n (bv bv' : Bvector n), Proof. induction n. intros. -rewrite (V0_eq _ bv); rewrite (V0_eq _ bv'); simpl; auto. +rewrite (V0_eq _ bv), (V0_eq _ bv'); simpl; auto. intros. -rewrite (VSn_eq _ _ bv); rewrite (VSn_eq _ _ bv'); simpl; auto. +rewrite (VSn_eq _ _ bv), (VSn_eq _ _ bv'); simpl; auto. rewrite IHn. destruct (Vhead bool n bv); destruct (Vhead bool n bv'); destruct (Bv2N n (Vtail bool n bv)); destruct (Bv2N n (Vtail bool n bv')); simpl; auto. diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v index 29e18548..0f71f2cc 100644 --- a/theories/Numbers/Integer/Abstract/ZBase.v +++ b/theories/Numbers/Integer/Abstract/ZBase.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZBase.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: ZBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export Decidable. Require Export ZAxioms. @@ -36,14 +36,14 @@ Proof NZpred_succ. Theorem Zeq_refl : forall n : Z, n == n. Proof (proj1 NZeq_equiv). -Theorem Zeq_symm : forall n m : Z, n == m -> m == n. +Theorem Zeq_sym : forall n m : Z, n == m -> m == n. Proof (proj2 (proj2 NZeq_equiv)). Theorem Zeq_trans : forall n m p : Z, n == m -> m == p -> n == p. Proof (proj1 (proj2 NZeq_equiv)). -Theorem Zneq_symm : forall n m : Z, n ~= m -> m ~= n. -Proof NZneq_symm. +Theorem Zneq_sym : forall n m : Z, n ~= m -> m ~= n. +Proof NZneq_sym. Theorem Zsucc_inj : forall n1 n2 : Z, S n1 == S n2 -> n1 == n2. Proof NZsucc_inj. diff --git a/theories/Numbers/Integer/Abstract/ZDomain.v b/theories/Numbers/Integer/Abstract/ZDomain.v index 15beb2b9..9a17e151 100644 --- a/theories/Numbers/Integer/Abstract/ZDomain.v +++ b/theories/Numbers/Integer/Abstract/ZDomain.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZDomain.v 10934 2008-05-15 21:58:20Z letouzey $ i*) +(*i $Id: ZDomain.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export NumPrelude. @@ -49,7 +49,7 @@ assert (x == y); [rewrite Exx'; now rewrite Eyy' | rewrite <- H2; assert (H3 : e x y); [now apply -> eq_equiv_e | now inversion H3]]]. Qed. -Theorem neq_symm : forall n m, n # m -> m # n. +Theorem neq_sym : forall n m, n # m -> m # n. Proof. intros n m H1 H2; symmetry in H2; false_hyp H2 H1. Qed. diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v index e3f1d9aa..c7996ffd 100644 --- a/theories/Numbers/Integer/Abstract/ZMulOrder.v +++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZMulOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: ZMulOrder.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export ZAddOrder. @@ -173,7 +173,7 @@ Notation Zmul_neg := Zlt_mul_0 (only parsing). Theorem Zle_0_mul : forall n m : Z, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0. Proof. -assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_symm). +assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_sym). intros n m. repeat rewrite Zlt_eq_cases. repeat rewrite R. rewrite Zlt_0_mul, Zeq_mul_0. pose proof (Zlt_trichotomy n 0); pose proof (Zlt_trichotomy m 0). tauto. @@ -184,7 +184,7 @@ Notation Zmul_nonneg := Zle_0_mul (only parsing). Theorem Zle_mul_0 : forall n m : Z, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m. Proof. -assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_symm). +assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_sym). intros n m. repeat rewrite Zlt_eq_cases. repeat rewrite R. rewrite Zlt_mul_0, Zeq_mul_0. pose proof (Zlt_trichotomy n 0); pose proof (Zlt_trichotomy m 0). tauto. diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v index cb920124..e5e950ac 100644 --- a/theories/Numbers/Integer/BigZ/BigZ.v +++ b/theories/Numbers/Integer/BigZ/BigZ.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: BigZ.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: BigZ.v 11576 2008-11-10 19:13:15Z msozeau $ i*) Require Export BigN. Require Import ZMulOrder. @@ -104,8 +104,6 @@ exact sub_opp. exact add_opp. Qed. -Typeclasses unfold NZadd NZmul NZsub NZeq. - Add Ring BigZr : BigZring. (** Todo: tactic translating from [BigZ] to [Z] + omega *) diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v index 6305156b..98ad4c64 100644 --- a/theories/Numbers/Integer/BigZ/ZMake.v +++ b/theories/Numbers/Integer/BigZ/ZMake.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZMake.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: ZMake.v 11576 2008-11-10 19:13:15Z msozeau $ i*) Require Import ZArith. Require Import BigNumPrelude. @@ -30,7 +30,6 @@ Module Make (N:NType) <: ZType. | Neg : N.t -> t_. Definition t := t_. - Typeclasses unfold t. Definition zero := Pos N.zero. Definition one := Pos N.one. diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v index 8b3d815d..9427b37b 100644 --- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v +++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZNatPairs.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: ZNatPairs.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Import NSub. (* The most complete file for natural numbers *) Require Export ZMulOrder. (* The most complete file for integers *) @@ -110,7 +110,7 @@ Proof. unfold reflexive, Zeq. reflexivity. Qed. -Theorem ZE_symm : symmetric Z Zeq. +Theorem ZE_sym : symmetric Z Zeq. Proof. unfold symmetric, Zeq; now symmetry. Qed. @@ -127,7 +127,7 @@ Qed. Theorem NZeq_equiv : equiv Z Zeq. Proof. -unfold equiv; repeat split; [apply ZE_refl | apply ZE_trans | apply ZE_symm]. +unfold equiv; repeat split; [apply ZE_refl | apply ZE_trans | apply ZE_sym]. Qed. Add Relation Z Zeq diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v index 8b01e353..bd4d6232 100644 --- a/theories/Numbers/NatInt/NZBase.v +++ b/theories/Numbers/NatInt/NZBase.v @@ -8,14 +8,14 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZBase.v 10934 2008-05-15 21:58:20Z letouzey $ i*) +(*i $Id: NZBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Import NZAxioms. Module NZBasePropFunct (Import NZAxiomsMod : NZAxiomsSig). Open Local Scope NatIntScope. -Theorem NZneq_symm : forall n m : NZ, n ~= m -> m ~= n. +Theorem NZneq_sym : forall n m : NZ, n ~= m -> m ~= n. Proof. intros n m H1 H2; symmetry in H2; false_hyp H2 H1. Qed. diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index 15004824..d0e2faf8 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: NZOrder.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Import NZAxioms. Require Import NZMul. @@ -118,7 +118,7 @@ Qed. Theorem NZneq_succ_diag_r : forall n : NZ, n ~= S n. Proof. -intro n; apply NZneq_symm; apply NZneq_succ_diag_l. +intro n; apply NZneq_sym; apply NZneq_succ_diag_l. Qed. Theorem NZnlt_succ_diag_l : forall n : NZ, ~ S n < n. diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v index f58b87d8..91ae5b70 100644 --- a/theories/Numbers/Natural/Abstract/NAdd.v +++ b/theories/Numbers/Natural/Abstract/NAdd.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NAdd.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: NAdd.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export NBase. @@ -103,7 +103,7 @@ Qed. Theorem succ_add_discr : forall n m : N, m ~= S (n + m). Proof. intro n; induct m. -apply neq_symm. apply neq_succ_0. +apply neq_sym. apply neq_succ_0. intros m IH H. apply succ_inj in H. rewrite add_succ_r in H. unfold not in IH; now apply IH. Qed. diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v index 3e4032b5..85e2c2ab 100644 --- a/theories/Numbers/Natural/Abstract/NBase.v +++ b/theories/Numbers/Natural/Abstract/NBase.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NBase.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: NBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export Decidable. Require Export NAxioms. @@ -48,14 +48,14 @@ Proof pred_0. Theorem Neq_refl : forall n : N, n == n. Proof (proj1 NZeq_equiv). -Theorem Neq_symm : forall n m : N, n == m -> m == n. +Theorem Neq_sym : forall n m : N, n == m -> m == n. Proof (proj2 (proj2 NZeq_equiv)). Theorem Neq_trans : forall n m p : N, n == m -> m == p -> n == p. Proof (proj1 (proj2 NZeq_equiv)). -Theorem neq_symm : forall n m : N, n ~= m -> m ~= n. -Proof NZneq_symm. +Theorem neq_sym : forall n m : N, n ~= m -> m ~= n. +Proof NZneq_sym. Theorem succ_inj : forall n1 n2 : N, S n1 == S n2 -> n1 == n2. Proof NZsucc_inj. @@ -111,7 +111,7 @@ Qed. Theorem neq_0_succ : forall n : N, 0 ~= S n. Proof. -intro n; apply neq_symm; apply neq_succ_0. +intro n; apply neq_sym; apply neq_succ_0. Qed. (* Next, we show that all numbers are nonnegative and recover regular induction diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index e15e4672..0a8f5f1e 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NDefOps.v 11039 2008-06-02 23:26:13Z letouzey $ i*) +(*i $Id: NDefOps.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Import Bool. (* To get the orb and negb function *) Require Export NStrongRec. @@ -243,7 +243,7 @@ Definition E2 := prod_rel Neq Neq. Add Relation (prod N N) E2 reflexivity proved by (prod_rel_refl N N Neq Neq E_equiv E_equiv) -symmetry proved by (prod_rel_symm N N Neq Neq E_equiv E_equiv) +symmetry proved by (prod_rel_sym N N Neq Neq E_equiv E_equiv) transitivity proved by (prod_rel_trans N N Neq Neq E_equiv E_equiv) as E2_rel. diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v index 031dbdea..c6a6da48 100644 --- a/theories/Numbers/Natural/Abstract/NStrongRec.v +++ b/theories/Numbers/Natural/Abstract/NStrongRec.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NStrongRec.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: NStrongRec.v 11674 2008-12-12 19:48:40Z letouzey $ i*) (** This file defined the strong (course-of-value, well-founded) recursion and proves its properties *) @@ -81,9 +81,9 @@ Proof. intros n1 n2 H. unfold g. now apply strong_rec_wd. Qed. -Theorem NtoA_eq_symm : symmetric (N -> A) (fun_eq Neq Aeq). +Theorem NtoA_eq_sym : symmetric (N -> A) (fun_eq Neq Aeq). Proof. -apply fun_eq_symm. +apply fun_eq_sym. exact (proj2 (proj2 NZeq_equiv)). exact (proj2 (proj2 Aeq_equiv)). Qed. @@ -97,7 +97,7 @@ exact (proj1 (proj2 Aeq_equiv)). Qed. Add Relation (N -> A) (fun_eq Neq Aeq) - symmetry proved by NtoA_eq_symm + symmetry proved by NtoA_eq_sym transitivity proved by NtoA_eq_trans as NtoA_eq_rel. diff --git a/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v index 41c255b1..16007656 100644 --- a/theories/Numbers/Natural/BigN/BigN.v +++ b/theories/Numbers/Natural/BigN/BigN.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BigN.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: BigN.v 11576 2008-11-10 19:13:15Z msozeau $ i*) (** * Natural numbers in base 2^31 *) @@ -78,8 +78,6 @@ exact mul_assoc. exact mul_add_distr_r. Qed. -Typeclasses unfold NZadd NZsub NZmul. - Add Ring BigNr : BigNring. (** Todo: tactic translating from [BigN] to [Z] + omega *) diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml index 4d6b45c5..04c7b96d 100644 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ b/theories/Numbers/Natural/BigN/NMake_gen.ml @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: NMake_gen.ml 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: NMake_gen.ml 11576 2008-11-10 19:13:15Z msozeau $ i*) (*S NMake_gen.ml : this file generates NMake.v *) @@ -139,7 +139,6 @@ let _ = pr ""; pr " Definition %s := %s_." t t; pr ""; - pr " Typeclasses unfold %s." t; pr " Definition w_0 := w0_op.(znz_0)."; pr ""; diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v index fdccf214..95d8b366 100644 --- a/theories/Numbers/NumPrelude.v +++ b/theories/Numbers/NumPrelude.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NumPrelude.v 10943 2008-05-19 08:45:13Z letouzey $ i*) +(*i $Id: NumPrelude.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export Setoid. @@ -212,7 +212,7 @@ unfold reflexive, prod_rel. destruct x; split; [apply (proj1 EA_equiv) | apply (proj1 EB_equiv)]; simpl. Qed. -Lemma prod_rel_symm : symmetric (A * B) prod_rel. +Lemma prod_rel_sym : symmetric (A * B) prod_rel. Proof. unfold symmetric, prod_rel. destruct x; destruct y; @@ -229,7 +229,7 @@ Qed. Theorem prod_rel_equiv : equiv (A * B) prod_rel. Proof. -unfold equiv; split; [exact prod_rel_refl | split; [exact prod_rel_trans | exact prod_rel_symm]]. +unfold equiv; split; [exact prod_rel_refl | split; [exact prod_rel_trans | exact prod_rel_sym]]. Qed. End RelationOnProduct. diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index a1a78acc..29494069 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -5,19 +5,19 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* $Id: Basics.v 11709 2008-12-20 11:42:15Z msozeau $ *) -(* Standard functions and combinators. - * Proofs about them require functional extensionality and can be found in [Combinators]. - * - * Author: Matthieu Sozeau - * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud - * 91405 Orsay, France *) +(** Standard functions and combinators. + + Proofs about them require functional extensionality and can be found in [Combinators]. -(* $Id: Basics.v 11046 2008-06-03 22:48:06Z msozeau $ *) + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - Université Paris Sud + 91405 Orsay, France *) -(** The polymorphic identity function. *) +(** The polymorphic identity function is defined in [Datatypes]. *) -Definition id {A} := fun x : A => x. +Implicit Arguments id [[A]]. (** Function composition. *) diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v index e267fbbe..ae9749de 100644 --- a/theories/Program/Combinators.v +++ b/theories/Program/Combinators.v @@ -5,15 +5,16 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* $Id: Combinators.v 11709 2008-12-20 11:42:15Z msozeau $ *) -(* Proofs about standard combinators, exports functional extensionality. - * - * Author: Matthieu Sozeau - * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud - * 91405 Orsay, France *) +(** Proofs about standard combinators, exports functional extensionality. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + 91405 Orsay, France *) Require Import Coq.Program.Basics. -Require Export Coq.Program.FunctionalExtensionality. +Require Export FunctionalExtensionality. Open Scope program_scope. @@ -40,7 +41,8 @@ Proof. reflexivity. Qed. -Hint Rewrite @compose_id_left @compose_id_right @compose_assoc : core. +Hint Rewrite @compose_id_left @compose_id_right : core. +Hint Rewrite <- @compose_assoc : core. (** [flip] is involutive. *) diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index c776070a..99d54755 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-emacs-U") -*- *) +(* -*- coq-prog-name: "~/research/coq/trunk/bin/coqtop.byte"; coq-prog-args: ("-emacs-U"); compile-command: "make -C ../.. TIME='time'" -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* replace_hyp H (JMeq_eq H)). + on_JMeq ltac:(fun H => apply JMeq_eq in H). (** Repeat it for every possible hypothesis. *) @@ -185,7 +189,6 @@ Ltac simplify_eqs := (** A tactic that tries to remove trivial equality guards in induction hypotheses coming from [dependent induction]/[generalize_eqs] invocations. *) - Ltac simpl_IH_eq H := match type of H with | @JMeq _ ?x _ _ -> _ => @@ -224,9 +227,291 @@ Ltac do_simpl_IHs_eqs := Ltac simpl_IHs_eqs := repeat do_simpl_IHs_eqs. -Ltac simpl_depind := subst* ; autoinjections ; try discriminates ; +(** We split substitution tactics in the two directions depending on which + names we want to keep corresponding to the generalization performed by the + [generalize_eqs] tactic. *) + +Ltac subst_left_no_fail := + repeat (match goal with + [ H : ?X = ?Y |- _ ] => subst X + end). + +Ltac subst_right_no_fail := + repeat (match goal with + [ H : ?X = ?Y |- _ ] => subst Y + end). + +Ltac inject_left H := + progress (inversion H ; subst_left_no_fail ; clear_dups) ; clear H. + +Ltac inject_right H := + progress (inversion H ; subst_right_no_fail ; clear_dups) ; clear H. + +Ltac autoinjections_left := repeat autoinjection ltac:inject_left. +Ltac autoinjections_right := repeat autoinjection ltac:inject_right. + +Ltac simpl_depind := subst_no_fail ; autoinjections ; try discriminates ; + simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. + +Ltac simpl_depind_l := subst_left_no_fail ; autoinjections_left ; try discriminates ; simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. +Ltac simpl_depind_r := subst_right_no_fail ; autoinjections_right ; try discriminates ; + simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. + +(** Support for the [Equations] command. + These tactics implement the necessary machinery to solve goals produced by the + [Equations] command relative to dependent pattern-matching. + It is completely inspired from the "Eliminating Dependent Pattern-Matching" paper by + Goguen, McBride and McKinna. *) + + +(** The NoConfusionPackage class provides a method for making progress on proving a property + [P] implied by an equality on an inductive type [I]. The type of [noConfusion] for a given + [P] should be of the form [ Π Δ, (x y : I Δ) (x = y) -> NoConfusion P x y ], where + [NoConfusion P x y] for constructor-headed [x] and [y] will give a formula ending in [P]. + This gives a general method for simplifying by discrimination or injectivity of constructors. + + Some actual instances are defined later in the file using the more primitive [discriminate] and + [injection] tactics on which we can always fall back. + *) + +Class NoConfusionPackage (I : Type) := { NoConfusion : Π P : Prop, Type ; noConfusion : Π P, NoConfusion P }. + +(** The [DependentEliminationPackage] provides the default dependent elimination principle to + be used by the [equations] resolver. It is especially useful to register the dependent elimination + principles for things in [Prop] which are not automatically generated. *) + +Class DependentEliminationPackage (A : Type) := + { elim_type : Type ; elim : elim_type }. + +(** A higher-order tactic to apply a registered eliminator. *) + +Ltac elim_tac tac p := + let ty := type of p in + let eliminator := eval simpl in (elim (A:=ty)) in + tac p eliminator. + +(** Specialization to do case analysis or induction. + Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register + generated induction principles. *) + +Ltac elim_case p := elim_tac ltac:(fun p el => destruct p using el) p. +Ltac elim_ind p := elim_tac ltac:(fun p el => induction p using el) p. + +(** The [BelowPackage] class provides the definition of a [Below] predicate for some datatype, + allowing to talk about course-of-value recursion on it. *) + +Class BelowPackage (A : Type) := { + Below : A -> Type ; + below : Π (a : A), Below a }. + +(** The [Recursor] class defines a recursor on a type, based on some definition of [Below]. *) + +Class Recursor (A : Type) (BP : BelowPackage A) := + { rec_type : A -> Type ; rec : Π (a : A), rec_type a }. + +(** Lemmas used by the simplifier, mainly rephrasings of [eq_rect], [eq_ind]. *) + +Lemma solution_left : Π A (B : A -> Type) (t : A), B t -> (Π x, x = t -> B x). +Proof. intros; subst. apply X. Defined. + +Lemma solution_right : Π A (B : A -> Type) (t : A), B t -> (Π x, t = x -> B x). +Proof. intros; subst; apply X. Defined. + +Lemma deletion : Π A B (t : A), B -> (t = t -> B). +Proof. intros; assumption. Defined. + +Lemma simplification_heq : Π A B (x y : A), (x = y -> B) -> (JMeq x y -> B). +Proof. intros; apply X; apply (JMeq_eq H). Defined. + +Lemma simplification_existT2 : Π A (P : A -> Type) B (p : A) (x y : P p), + (x = y -> B) -> (existT P p x = existT P p y -> B). +Proof. intros. apply X. apply inj_pair2. exact H. Defined. + +Lemma simplification_existT1 : Π A (P : A -> Type) B (p q : A) (x : P p) (y : P q), + (p = q -> existT P p x = existT P q y -> B) -> (existT P p x = existT P q y -> B). +Proof. intros. injection H. intros ; auto. Defined. + +Lemma simplification_K : Π A (x : A) (B : x = x -> Type), B (refl_equal x) -> (Π p : x = x, B p). +Proof. intros. rewrite (UIP_refl A). assumption. Defined. + +(** This hint database and the following tactic can be used with [autosimpl] to + unfold everything to [eq_rect]s. *) + +Hint Unfold solution_left solution_right deletion simplification_heq + simplification_existT1 simplification_existT2 + eq_rect_r eq_rec eq_ind : equations. + +(** Simply unfold as much as possible. *) + +Ltac unfold_equations := repeat progress autosimpl with equations. + +(** The tactic [simplify_equations] is to be used when a program generated using [Equations] + is in the goal. It simplifies it as much as possible, possibly using [K] if needed. *) + +Ltac simplify_equations := repeat (unfold_equations ; simplify_eqs). + +(** We will use the [block_induction] definition to separate the goal from the + equalities generated by the tactic. *) + +Definition block_dep_elim {A : Type} (a : A) := a. + +(** Using these we can make a simplifier that will perform the unification + steps needed to put the goal in normalised form (provided there are only + constructor forms). Compare with the lemma 16 of the paper. + We don't have a [noCycle] procedure yet. *) + +Ltac simplify_one_dep_elim_term c := + match c with + | @JMeq _ _ _ _ -> _ => refine (simplification_heq _ _ _ _ _) + | ?t = ?t -> _ => intros _ || refine (simplification_K _ t _ _) + | eq (existT _ _ _) (existT _ _ _) -> _ => + refine (simplification_existT2 _ _ _ _ _ _ _) || + refine (simplification_existT1 _ _ _ _ _ _ _ _) + | ?x = ?y -> _ => (* variables case *) + (let hyp := fresh in intros hyp ; + move hyp before x ; + generalize dependent x ; refine (solution_left _ _ _ _) ; intros until 0) || + (let hyp := fresh in intros hyp ; + move hyp before y ; + generalize dependent y ; refine (solution_right _ _ _ _) ; intros until 0) + | @eq ?A ?t ?u -> ?P => apply (noConfusion (I:=A) P) + | ?f ?x = ?g ?y -> _ => let H := fresh in progress (intros H ; injection H ; clear H) + | ?t = ?u -> _ => let hyp := fresh in + intros hyp ; elimtype False ; discriminate + | ?x = ?y -> _ => let hyp := fresh in + intros hyp ; (try (clear hyp ; (* If non dependent, don't clear it! *) fail 1)) ; + case hyp ; clear hyp + | block_dep_elim ?T => fail 1 (* Do not put any part of the rhs in the hyps *) + | _ => intro + end. + +Ltac simplify_one_dep_elim := + match goal with + | [ |- ?gl ] => simplify_one_dep_elim_term gl + end. + +(** Repeat until no progress is possible. By construction, it should leave the goal with + no remaining equalities generated by the [generalize_eqs] tactic. *) + +Ltac simplify_dep_elim := repeat simplify_one_dep_elim. + +(** To dependent elimination on some hyp. *) + +Ltac depelim id := + generalize_eqs id ; destruct id ; simplify_dep_elim. + +(** Do dependent elimination of the last hypothesis, but not simplifying yet + (used internally). *) + +Ltac destruct_last := + on_last_hyp ltac:(fun id => simpl in id ; generalize_eqs id ; destruct id). + +(** The rest is support tactics for the [Equations] command. *) + +(** Notation for inaccessible patterns. *) + +Definition inaccessible_pattern {A : Type} (t : A) := t. + +Notation "?( t )" := (inaccessible_pattern t). + +(** To handle sections, we need to separate the context in two parts: + variables introduced by the section and the rest. We introduce a dummy variable + between them to indicate that. *) + +CoInductive end_of_section := the_end_of_the_section. + +Ltac set_eos := let eos := fresh "eos" in + assert (eos:=the_end_of_the_section). + +(** We have a specialized [reverse_local] tactic to reverse the goal until the begining of the + section variables *) + +Ltac reverse_local := + match goal with + | [ H : ?T |- _ ] => + match T with + | end_of_section => idtac | _ => revert H ; reverse_local end + | _ => idtac + end. + +(** Do as much as possible to apply a method, trying to get the arguments right. + !!Unsafe!! We use [auto] for the [_nocomp] variant of [Equations], in which case some + non-dependent arguments of the method can remain after [apply]. *) + +Ltac simpl_intros m := ((apply m || refine m) ; auto) || (intro ; simpl_intros m). + +(** Hopefully the first branch suffices. *) + +Ltac try_intros m := + solve [ intros ; unfold block_dep_elim ; refine m || apply m ] || + solve [ unfold block_dep_elim ; simpl_intros m ]. + +(** To solve a goal by inversion on a particular target. *) + +Ltac solve_empty target := + do_nat target intro ; elimtype False ; destruct_last ; simplify_dep_elim. + +Ltac simplify_method tac := repeat (tac || simplify_one_dep_elim) ; reverse_local. + +(** Solving a method call: we can solve it by splitting on an empty family member + or we must refine the goal until the body can be applied. *) + +Ltac solve_method rec := + match goal with + | [ H := ?body : nat |- _ ] => subst H ; clear ; abstract (simplify_method idtac ; solve_empty body) + | [ H := [ ?body ] : ?T |- _ ] => clear H ; simplify_method ltac:(exact body) ; rec ; try_intros (body:T) + end. + +(** Impossible cases, by splitting on a given target. *) + +Ltac solve_split := + match goal with + | [ |- let split := ?x : nat in _ ] => clear ; abstract (intros _ ; solve_empty x) + end. + +(** If defining recursive functions, the prototypes come first. *) + +Ltac intro_prototypes := + match goal with + | [ |- Π x : _, _ ] => intro ; intro_prototypes + | _ => idtac + end. + +Ltac do_case p := destruct p || elim_case p || (case p ; clear p). +Ltac do_ind p := induction p || elim_ind p. + +Ltac dep_elimify := match goal with [ |- ?T ] => change (block_dep_elim T) end. + +Ltac un_dep_elimify := unfold block_dep_elim in *. + +Ltac case_last := dep_elimify ; + on_last_hyp ltac:(fun p => + let ty := type of p in + match ty with + | ?x = ?x => revert p ; refine (simplification_K _ x _ _) + | ?x = ?y => revert p + | _ => simpl in p ; generalize_eqs p ; do_case p + end). + +Ltac nonrec_equations := + solve [solve_equations (case_last) (solve_method idtac)] || solve [ solve_split ] + || fail "Unnexpected equations goal". + +Ltac recursive_equations := + solve [solve_equations (case_last) (solve_method ltac:intro)] || solve [ solve_split ] + || fail "Unnexpected recursive equations goal". + +(** The [equations] tactic is the toplevel tactic for solving goals generated + by [Equations]. *) + +Ltac equations := set_eos ; + match goal with + | [ |- Π x : _, _ ] => intro ; recursive_equations + | _ => nonrec_equations + end. + (** The following tactics allow to do induction on an already instantiated inductive predicate by first generalizing it and adding the proper equalities to the context, in a maner similar to the BasicElim tactic of "Elimination with a motive" by Conor McBride. *) @@ -235,43 +520,49 @@ Ltac simpl_depind := subst* ; autoinjections ; try discriminates ; and starts a dependent induction using this tactic. *) Ltac do_depind tac H := - generalize_eqs_vars H ; tac H ; repeat progress simpl_depind. + (try intros until H) ; dep_elimify ; generalize_eqs_vars H ; tac H ; simplify_dep_elim ; un_dep_elimify. (** A variant where generalized variables should be given by the user. *) Ltac do_depind' tac H := - generalize_eqs H ; tac H ; repeat progress simpl_depind. + (try intros until H) ; dep_elimify ; generalize_eqs H ; tac H ; simplify_dep_elim ; un_dep_elimify. -(** Calls [destruct] on the generalized hypothesis, results should be similar to inversion. *) +(** 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. *) Tactic Notation "dependent" "destruction" ident(H) := - do_depind ltac:(fun hyp => destruct hyp ; intros) H ; subst*. + do_depind' ltac:(fun hyp => do_case hyp) H. Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) := - do_depind ltac:(fun hyp => destruct hyp using c ; intros) H. + do_depind' ltac:(fun hyp => destruct hyp using c) H. (** This tactic also generalizes the goal by the given variables before the induction. *) Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) := - do_depind' ltac:(fun hyp => revert l ; destruct hyp ; intros) H. + do_depind' ltac:(fun hyp => revert l ; do_case hyp) H. Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := - do_depind' ltac:(fun hyp => revert l ; destruct hyp using c ; intros) H. + do_depind' ltac:(fun hyp => revert l ; destruct hyp using c) H. (** Then we have wrappers for usual calls to induction. One can customize the induction tactic by - writting another wrapper calling do_depind. *) + writting another wrapper calling do_depind. We suppose the hyp has to be generalized before + calling [induction]. *) Tactic Notation "dependent" "induction" ident(H) := - do_depind ltac:(fun hyp => induction hyp ; intros) H. + do_depind ltac:(fun hyp => do_ind hyp) H. Tactic Notation "dependent" "induction" ident(H) "using" constr(c) := - do_depind ltac:(fun hyp => induction hyp using c ; intros) H. + do_depind ltac:(fun hyp => induction hyp using c) H. (** This tactic also generalizes the goal by the given variables before the induction. *) Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) := - do_depind' ltac:(fun hyp => generalize l ; clear l ; induction hyp ; intros) H. + do_depind' ltac:(fun hyp => generalize l ; clear l ; do_ind hyp) H. Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := - do_depind' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c ; intros) H. + do_depind' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c) H. +Ltac simplify_IH_hyps := repeat + match goal with + | [ hyp : _ |- _ ] => specialize_hypothesis hyp + end. \ No newline at end of file diff --git a/theories/Program/FunctionalExtensionality.v b/theories/Program/FunctionalExtensionality.v deleted file mode 100644 index b5ad5b4d..00000000 --- a/theories/Program/FunctionalExtensionality.v +++ /dev/null @@ -1,109 +0,0 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* B), - f = g -> forall x, f x = g x. -Proof. - intros. - rewrite H. - auto. -Qed. - -(** Statements of functional equality for simple and dependent functions. *) - -Axiom fun_extensionality_dep : forall A, forall B : (A -> Type), - forall (f g : forall x : A, B x), - (forall x, f x = g x) -> f = g. - -Lemma fun_extensionality : forall A B (f g : A -> B), - (forall x, f x = g x) -> f = g. -Proof. - intros ; apply fun_extensionality_dep. - assumption. -Qed. - -Hint Resolve fun_extensionality fun_extensionality_dep : program. - -(** Apply [fun_extensionality], introducing variable x. *) - -Tactic Notation "extensionality" ident(x) := - match goal with - [ |- ?X = ?Y ] => apply (@fun_extensionality _ _ X Y) || apply (@fun_extensionality_dep _ _ X Y) ; intro x - end. - -(** Eta expansion follows from extensionality. *) - -Lemma eta_expansion_dep : forall A (B : A -> Type) (f : forall x : A, B x), - f = fun x => f x. -Proof. - intros. - extensionality x. - reflexivity. -Qed. - -Lemma eta_expansion : forall A B (f : A -> B), - f = fun x => f x. -Proof. - intros ; apply eta_expansion_dep. -Qed. - -(** The two following lemmas allow to unfold a well-founded fixpoint definition without - restriction using the functional extensionality axiom. *) - -(** For a function defined with Program using a well-founded order. *) - -Program Lemma fix_sub_eq_ext : - forall (A : Set) (R : A -> A -> Prop) (Rwf : well_founded R) - (P : A -> Set) - (F_sub : forall x : A, (forall (y : A | R y x), P y) -> P x), - forall x : A, - Fix_sub A R Rwf P F_sub x = - F_sub x (fun (y : A | R y x) => Fix A R Rwf P F_sub y). -Proof. - intros ; apply Fix_eq ; auto. - intros. - assert(f = g). - extensionality y ; apply H. - rewrite H0 ; auto. -Qed. - -(** For a function defined with Program using a measure. *) - -Program Lemma fix_sub_measure_eq_ext : - forall (A : Type) (f : A -> nat) (P : A -> Type) - (F_sub : forall x : A, (forall (y : A | f y < f x), P y) -> P x), - forall x : A, - Fix_measure_sub A f P F_sub x = - F_sub x (fun (y : A | f y < f x) => Fix_measure_sub A f P F_sub y). -Proof. - intros ; apply Fix_measure_eq ; auto. - intros. - assert(f0 = g). - extensionality y ; apply H. - rewrite H0 ; auto. -Qed. - - diff --git a/theories/Program/Program.v b/theories/Program/Program.v index b6c3031e..7d0c3948 100644 --- a/theories/Program/Program.v +++ b/theories/Program/Program.v @@ -1,3 +1,12 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (ex (fun y => p)))) (at level 200, x ident, y ident, right associativity) : type_scope. @@ -53,7 +53,7 @@ Notation " 'exists' x y z , p" := (ex (fun x => (ex (fun y => (ex (fun z => p))) Notation " 'exists' x y z w , p" := (ex (fun x => (ex (fun y => (ex (fun z => (ex (fun w => p)))))))) (at level 200, x ident, y ident, z ident, w ident, right associativity) : type_scope. -Tactic Notation "exist" constr(x) := exists x. -Tactic Notation "exist" constr(x) constr(y) := exists x ; exists y. -Tactic Notation "exist" constr(x) constr(y) constr(z) := exists x ; exists y ; exists z. -Tactic Notation "exist" constr(x) constr(y) constr(z) constr(w) := exists x ; exists y ; exists z ; exists w. +Tactic Notation "exists" constr(x) := exists x. +Tactic Notation "exists" constr(x) constr(y) := exists x ; exists y. +Tactic Notation "exists" constr(x) constr(y) constr(z) := exists x ; exists y ; exists z. +Tactic Notation "exists" constr(x) constr(y) constr(z) constr(w) := exists x ; exists y ; exists z ; exists w. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index bb5054b4..499629a6 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -6,11 +6,24 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Tactics.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: Tactics.v 11709 2008-12-20 11:42:15Z msozeau $ i*) (** This module implements various tactics used to simplify the goals produced by Program, which are also generally useful. *) +(** The [do] tactic but using a Coq-side nat. *) + +Ltac do_nat n tac := + match n with + | 0 => idtac + | S ?n' => tac ; do_nat n' tac + end. + +(** Do something on the last hypothesis, or fail *) + +Ltac on_last_hyp tac := + match goal with [ H : _ |- _ ] => tac H || fail 1 end. + (** Destructs one pair, without care regarding naming. *) Ltac destruct_one_pair := @@ -80,7 +93,7 @@ Ltac clear_dup := | [ H' : ?Y |- _ ] => match H with | H' => fail 2 - | _ => conv X Y ; (clear H' || clear H) + | _ => unify X Y ; (clear H' || clear H) end end end. @@ -91,7 +104,7 @@ Ltac clear_dups := repeat clear_dup. Ltac subst_no_fail := repeat (match goal with - [ H : ?X = ?Y |- _ ] => subst X || subst Y + [ H : ?X = ?Y |- _ ] => subst X || subst Y end). Tactic Notation "subst" "*" := subst_no_fail. @@ -108,6 +121,26 @@ Ltac on_application f tac T := | context [f ?x ?y] => tac (f x y) | context [f ?x] => tac (f x) end. + +(** A variant of [apply] using [refine], doing as much conversion as necessary. *) + +Ltac rapply p := + refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _) || + refine (p _ _ _ _ _) || + refine (p _ _ _ _) || + refine (p _ _ _) || + refine (p _ _) || + refine (p _) || + refine p. (** Tactical [on_call f tac] applies [tac] on any application of [f] in the hypothesis or goal. *) @@ -154,13 +187,14 @@ Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(i (** Try to inject any potential constructor equality hypothesis. *) -Ltac autoinjection := - let tac H := progress (inversion H ; subst ; clear_dups) ; clear H in - match goal with - | [ H : ?f ?a = ?f' ?a' |- _ ] => tac H - end. +Ltac autoinjection tac := + match goal with + | [ H : ?f ?a = ?f' ?a' |- _ ] => tac H + end. + +Ltac inject H := progress (inversion H ; subst*; clear_dups) ; clear H. -Ltac autoinjections := repeat autoinjection. +Ltac autoinjections := repeat (clear_dups ; autoinjection ltac:inject). (** Destruct an hypothesis by first copying it to avoid dependencies. *) diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v index fcd85f41..b08093bf 100644 --- a/theories/Program/Utils.v +++ b/theories/Program/Utils.v @@ -6,7 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Utils.v 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: Utils.v 11709 2008-12-20 11:42:15Z msozeau $ i*) + +(** Various syntaxic shortands that are useful with [Program]. *) Require Export Coq.Program.Tactics. diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index b6ba5d44..12bdf3a7 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -1,3 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A -> Prop. @@ -146,3 +156,196 @@ Section Well_founded_measure. End Well_founded_measure. Extraction Inline Fix_measure_F_sub Fix_measure_sub. + +Set Implicit Arguments. + +(** Reasoning about well-founded fixpoints on measures. *) + +Section Measure_well_founded. + + (* Measure relations are well-founded if the underlying relation is well-founded. *) + + Variables T M: Set. + Variable R: M -> M -> Prop. + Hypothesis wf: well_founded R. + Variable m: T -> M. + + Definition MR (x y: T): Prop := R (m x) (m y). + + Lemma measure_wf: well_founded MR. + Proof with auto. + unfold well_founded. + cut (forall a: M, (fun mm: M => forall a0: T, m a0 = mm -> Acc MR a0) a). + intros. + apply (H (m a))... + apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)). + intros. + apply Acc_intro. + intros. + unfold MR in H1. + rewrite H0 in H1. + apply (H (m y))... + Defined. + +End Measure_well_founded. + +Section Fix_measure_rects. + + Variable A: Set. + Variable m: A -> nat. + Variable P: A -> Type. + Variable f: forall (x : A), (forall y: { y: A | m y < m x }, P (proj1_sig y)) -> P x. + + Lemma F_unfold x r: + Fix_measure_F_sub A m P f x r = + f (fun y => Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv r (proj2_sig y))). + Proof. intros. case r; auto. Qed. + + (* Fix_measure_F_sub_rect lets one prove a property of + functions defined using Fix_measure_F_sub by showing + that property to be invariant over single application of the + function body (f in our case). *) + + Lemma Fix_measure_F_sub_rect + (Q: forall x, P x -> Type) + (inv: forall x: A, + (forall (y: A) (H: MR lt m y x) (a: Acc lt (m y)), + Q y (Fix_measure_F_sub A m P f y a)) -> + forall (a: Acc lt (m x)), + Q x (f (fun y: {y: A | m y < m x} => + Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv a (proj2_sig y))))) + : forall x a, Q _ (Fix_measure_F_sub A m P f x a). + Proof with auto. + intros Q inv. + set (R := fun (x: A) => forall a, Q _ (Fix_measure_F_sub A m P f x a)). + cut (forall x, R x)... + apply (well_founded_induction_type (measure_wf lt_wf m)). + subst R. + simpl. + intros. + rewrite F_unfold... + Qed. + + (* Let's call f's second parameter its "lowers" function, since it + provides it access to results for inputs with a lower measure. + + In preparation of lemma similar to Fix_measure_F_sub_rect, but + for Fix_measure_sub, we first + need an extra hypothesis stating that the function body has the + same result for different "lowers" functions (g and h below) as long + as those produce the same results for lower inputs, regardless + of the lt proofs. *) + + Hypothesis equiv_lowers: + forall x0 (g h: forall x: {y: A | m y < m x0}, P (proj1_sig x)), + (forall x p p', g (exist (fun y: A => m y < m x0) x p) = h (exist _ x p')) -> + f g = f h. + + (* From equiv_lowers, it follows that + [Fix_measure_F_sub A m P f x] applications do not not + depend on the Acc proofs. *) + + Lemma eq_Fix_measure_F_sub x (a a': Acc lt (m x)): + Fix_measure_F_sub A m P f x a = + Fix_measure_F_sub A m P f x a'. + Proof. + intros x a. + pattern x, (Fix_measure_F_sub A m P f x a). + apply Fix_measure_F_sub_rect. + intros. + rewrite F_unfold. + apply equiv_lowers. + intros. + apply H. + assumption. + Qed. + + (* Finally, Fix_measure_F_rect lets one prove a property of + functions defined using Fix_measure_F by showing that + property to be invariant over single application of the function + body (f). *) + + Lemma Fix_measure_sub_rect + (Q: forall x, P x -> Type) + (inv: forall + (x: A) + (H: forall (y: A), MR lt m y x -> Q y (Fix_measure_sub A m P f y)) + (a: Acc lt (m x)), + Q x (f (fun y: {y: A | m y < m x} => Fix_measure_sub A m P f (proj1_sig y)))) + : forall x, Q _ (Fix_measure_sub A m P f x). + Proof with auto. + unfold Fix_measure_sub. + intros. + apply Fix_measure_F_sub_rect. + intros. + assert (forall y: A, MR lt m y x0 -> Q y (Fix_measure_F_sub A m P f y (lt_wf (m y))))... + set (inv x0 X0 a). clearbody q. + rewrite <- (equiv_lowers (fun y: {y: A | m y < m x0} => Fix_measure_F_sub A m P f (proj1_sig y) (lt_wf (m (proj1_sig y)))) (fun y: {y: A | m y < m x0} => Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv a (proj2_sig y))))... + intros. + apply eq_Fix_measure_F_sub. + Qed. + +End Fix_measure_rects. + +(** Tactic to fold a definitions based on [Fix_measure_sub]. *) + +Ltac fold_sub f := + match goal with + | [ |- ?T ] => + match T with + appcontext C [ @Fix_measure_sub _ _ _ _ ?arg ] => + let app := context C [ f arg ] in + change app + end + end. + +(** This module provides the fixpoint equation provided one assumes + functional extensionality. *) + +Module WfExtensionality. + + Require Import FunctionalExtensionality. + + (** The two following lemmas allow to unfold a well-founded fixpoint definition without + restriction using the functional extensionality axiom. *) + + (** For a function defined with Program using a well-founded order. *) + + Program Lemma fix_sub_eq_ext : + forall (A : Set) (R : A -> A -> Prop) (Rwf : well_founded R) + (P : A -> Set) + (F_sub : forall x : A, (forall (y : A | R y x), P y) -> P x), + forall x : A, + Fix_sub A R Rwf P F_sub x = + F_sub x (fun (y : A | R y x) => Fix A R Rwf P F_sub y). + Proof. + intros ; apply Fix_eq ; auto. + intros. + assert(f = g). + extensionality y ; apply H. + rewrite H0 ; auto. + Qed. + + (** For a function defined with Program using a measure. *) + + Program Lemma fix_sub_measure_eq_ext : + forall (A : Type) (f : A -> nat) (P : A -> Type) + (F_sub : forall x : A, (forall (y : A | f y < f x), P y) -> P x), + forall x : A, + Fix_measure_sub A f P F_sub x = + F_sub x (fun (y : A | f y < f x) => Fix_measure_sub A f P F_sub y). + Proof. + intros ; apply Fix_measure_eq ; auto. + intros. + assert(f0 = g). + extensionality y ; apply H. + rewrite H0 ; auto. + Qed. + + (** Tactic to unfold once a definition based on [Fix_measure_sub]. *) + + Ltac unfold_sub f fargs := + set (call:=fargs) ; unfold f in call ; unfold call ; clear call ; + rewrite fix_sub_measure_eq_ext ; repeat fold_sub fargs ; simpl proj1_sig. + +End WfExtensionality. diff --git a/theories/QArith/Qpower.v b/theories/QArith/Qpower.v index 8672592d..efaefbb7 100644 --- a/theories/QArith/Qpower.v +++ b/theories/QArith/Qpower.v @@ -221,7 +221,7 @@ repeat rewrite Zpos_mult_morphism. repeat rewrite Z2P_correct. repeat rewrite Zpower_pos_1_r; ring. apply Zpower_pos_pos; red; auto. -repeat apply Zmult_lt_0_compat; auto; +repeat apply Zmult_lt_0_compat; red; auto; apply Zpower_pos_pos; red; auto. (* xO *) rewrite IHp, <-Pplus_diag. diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index 0638ca8f..d0916b09 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -6,15 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Operators_Properties.v 9598 2007-02-06 19:45:52Z herbelin $ i*) +(*i $Id: Operators_Properties.v 11481 2008-10-20 19:23:51Z herbelin $ i*) -(****************************************************************************) -(* Bruno Barras *) -(****************************************************************************) +(************************************************************************) +(** * Some properties of the operators on relations *) +(************************************************************************) +(** * Initial version by Bruno Barras *) +(************************************************************************) Require Import Relation_Definitions. Require Import Relation_Operators. - +Require Import Setoid. Section Properties. @@ -25,6 +27,8 @@ Section Properties. Section Clos_Refl_Trans. + (** Correctness of the reflexive-transitive closure operator *) + Lemma clos_rt_is_preorder : preorder A (clos_refl_trans A R). Proof. apply Build_preorder. @@ -33,6 +37,8 @@ Section Properties. exact (rt_trans A R). Qed. + (** Idempotency of the reflexive-transitive closure operator *) + Lemma clos_rt_idempotent : incl (clos_refl_trans A (clos_refl_trans A R)) (clos_refl_trans A R). Proof. @@ -42,32 +48,13 @@ Section Properties. apply rt_trans with y; auto with sets. Qed. - Lemma clos_refl_trans_ind_left : - forall (A:Type) (R:A -> A -> Prop) (M:A) (P:A -> Prop), - P M -> - (forall P0 N:A, clos_refl_trans A R M P0 -> P P0 -> R P0 N -> P N) -> - forall a:A, clos_refl_trans A R M a -> P a. - Proof. - intros. - generalize H H0. - clear H H0. - elim H1; intros; auto with sets. - apply H2 with x; auto with sets. - - apply H3. - apply H0; auto with sets. - - intros. - apply H5 with P0; auto with sets. - apply rt_trans with y; auto with sets. - Qed. - - End Clos_Refl_Trans. - Section Clos_Refl_Sym_Trans. + (** Reflexive-transitive closure is included in the + reflexive-symmetric-transitive closure *) + Lemma clos_rt_clos_rst : inclusion A (clos_refl_trans A R) (clos_refl_sym_trans A R). Proof. @@ -76,6 +63,8 @@ Section Properties. apply rst_trans with y; auto with sets. Qed. + (** Correctness of the reflexive-symmetric-transitive closure *) + Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans A R). Proof. apply Build_equivalence. @@ -84,6 +73,8 @@ Section Properties. exact (rst_sym A R). Qed. + (** Idempotency of the reflexive-symmetric-transitive closure operator *) + Lemma clos_rst_idempotent : incl (clos_refl_sym_trans A (clos_refl_sym_trans A R)) (clos_refl_sym_trans A R). @@ -92,7 +83,294 @@ Section Properties. induction 1; auto with sets. apply rst_trans with y; auto with sets. Qed. - + End Clos_Refl_Sym_Trans. + Section Equivalences. + + (** *** Equivalences between the different definition of the reflexive, + symmetric, transitive closures *) + + (** *** Contributed by P. Casteran *) + + (** Direct transitive closure vs left-step extension *) + + Lemma t1n_trans : forall x y, clos_trans_1n A R x y -> clos_trans A R x y. + Proof. + induction 1. + left; assumption. + right with y; auto. + left; auto. + Qed. + + Lemma trans_t1n : forall x y, clos_trans A R x y -> clos_trans_1n A R x y. + Proof. + induction 1. + left; assumption. + generalize IHclos_trans2; clear IHclos_trans2; induction IHclos_trans1. + right with y; auto. + right with y; auto. + eapply IHIHclos_trans1; auto. + apply t1n_trans; auto. + Qed. + + Lemma t1n_trans_equiv : forall x y, + clos_trans A R x y <-> clos_trans_1n A R x y. + Proof. + split. + apply trans_t1n. + apply t1n_trans. + Qed. + + (** Direct transitive closure vs right-step extension *) + + Lemma tn1_trans : forall x y, clos_trans_n1 A R x y -> clos_trans A R x y. + Proof. + induction 1. + left; assumption. + right with y; auto. + left; assumption. + Qed. + + Lemma trans_tn1 : forall x y, clos_trans A R x y -> clos_trans_n1 A R x y. + Proof. + induction 1. + left; assumption. + elim IHclos_trans2. + intro y0; right with y. + auto. + auto. + intros. + right with y0; auto. + Qed. + + Lemma tn1_trans_equiv : forall x y, + clos_trans A R x y <-> clos_trans_n1 A R x y. + Proof. + split. + apply trans_tn1. + apply tn1_trans. + Qed. + + (** Direct reflexive-transitive closure is equivalent to + transitivity by left-step extension *) + + Lemma R_rt1n : forall x y, R x y -> clos_refl_trans_1n A R x y. + Proof. + intros x y H. + right with y;[assumption|left]. + Qed. + + Lemma R_rtn1 : forall x y, R x y -> clos_refl_trans_n1 A R x y. + Proof. + intros x y H. + right with x;[assumption|left]. + Qed. + + Lemma rt1n_trans : forall x y, + clos_refl_trans_1n A R x y -> clos_refl_trans A R x y. + Proof. + induction 1. + constructor 2. + constructor 3 with y; auto. + constructor 1; auto. + Qed. + + Lemma trans_rt1n : forall x y, + clos_refl_trans A R x y -> clos_refl_trans_1n A R x y. + Proof. + induction 1. + apply R_rt1n; assumption. + left. + generalize IHclos_refl_trans2; clear IHclos_refl_trans2; + induction IHclos_refl_trans1; auto. + + right with y; auto. + eapply IHIHclos_refl_trans1; auto. + apply rt1n_trans; auto. + Qed. + + Lemma rt1n_trans_equiv : forall x y, + clos_refl_trans A R x y <-> clos_refl_trans_1n A R x y. + Proof. + split. + apply trans_rt1n. + apply rt1n_trans. + Qed. + + (** Direct reflexive-transitive closure is equivalent to + transitivity by right-step extension *) + + Lemma rtn1_trans : forall x y, + clos_refl_trans_n1 A R x y -> clos_refl_trans A R x y. + Proof. + induction 1. + constructor 2. + constructor 3 with y; auto. + constructor 1; assumption. + Qed. + + Lemma trans_rtn1 : forall x y, + clos_refl_trans A R x y -> clos_refl_trans_n1 A R x y. + Proof. + induction 1. + apply R_rtn1; auto. + left. + elim IHclos_refl_trans2; auto. + intros. + right with y0; auto. + Qed. + + Lemma rtn1_trans_equiv : forall x y, + clos_refl_trans A R x y <-> clos_refl_trans_n1 A R x y. + Proof. + split. + apply trans_rtn1. + apply rtn1_trans. + Qed. + + (** Induction on the left transitive step *) + + Lemma clos_refl_trans_ind_left : + forall (x:A) (P:A -> Prop), P x -> + (forall y z:A, clos_refl_trans A R x y -> P y -> R y z -> P z) -> + forall z:A, clos_refl_trans A R x z -> P z. + Proof. + intros. + revert H H0. + induction H1; intros; auto with sets. + apply H1 with x; auto with sets. + + apply IHclos_refl_trans2. + apply IHclos_refl_trans1; auto with sets. + + intros. + apply H0 with y0; auto with sets. + apply rt_trans with y; auto with sets. + Qed. + + (** Induction on the right transitive step *) + + Lemma rt1n_ind_right : forall (P : A -> Prop) (z:A), + P z -> + (forall x y, R x y -> clos_refl_trans_1n A R y z -> P y -> P x) -> + forall x, clos_refl_trans_1n A R x z -> P x. + induction 3; auto. + apply H0 with y; auto. + Qed. + + Lemma clos_refl_trans_ind_right : forall (P : A -> Prop) (z:A), + P z -> + (forall x y, R x y -> P y -> clos_refl_trans A R y z -> P x) -> + forall x, clos_refl_trans A R x z -> P x. + intros. + rewrite rt1n_trans_equiv in H1. + elim H1 using rt1n_ind_right; auto. + intros; rewrite <- rt1n_trans_equiv in *. + eauto. + Qed. + + (** Direct reflexive-symmetric-transitive closure is equivalent to + transitivity by symmetric left-step extension *) + + Lemma rts1n_rts : forall x y, + clos_refl_sym_trans_1n A R x y -> clos_refl_sym_trans A R x y. + Proof. + induction 1. + constructor 2. + constructor 4 with y; auto. + case H;[constructor 1|constructor 3; constructor 1]; auto. + Qed. + + Lemma rts_1n_trans : forall x y, clos_refl_sym_trans_1n A R x y -> + forall z, clos_refl_sym_trans_1n A R y z -> + clos_refl_sym_trans_1n A R x z. + induction 1. + auto. + intros; right with y; eauto. + Qed. + + Lemma rts1n_sym : forall x y, clos_refl_sym_trans_1n A R x y -> + clos_refl_sym_trans_1n A R y x. + Proof. + intros x y H; elim H. + constructor 1. + intros x0 y0 z D H0 H1; apply rts_1n_trans with y0; auto. + right with x0. + tauto. + left. + Qed. + + Lemma rts_rts1n : forall x y, + clos_refl_sym_trans A R x y -> clos_refl_sym_trans_1n A R x y. + induction 1. + constructor 2 with y; auto. + constructor 1. + constructor 1. + apply rts1n_sym; auto. + eapply rts_1n_trans; eauto. + Qed. + + Lemma rts_rts1n_equiv : forall x y, + clos_refl_sym_trans A R x y <-> clos_refl_sym_trans_1n A R x y. + Proof. + split. + apply rts_rts1n. + apply rts1n_rts. + Qed. + + (** Direct reflexive-symmetric-transitive closure is equivalent to + transitivity by symmetric right-step extension *) + + Lemma rtsn1_rts : forall x y, + clos_refl_sym_trans_n1 A R x y -> clos_refl_sym_trans A R x y. + Proof. + induction 1. + constructor 2. + constructor 4 with y; auto. + case H;[constructor 1|constructor 3; constructor 1]; auto. + Qed. + + Lemma rtsn1_trans : forall y z, clos_refl_sym_trans_n1 A R y z-> + forall x, clos_refl_sym_trans_n1 A R x y -> + clos_refl_sym_trans_n1 A R x z. + Proof. + induction 1. + auto. + intros. + right with y0; eauto. + Qed. + + Lemma rtsn1_sym : forall x y, clos_refl_sym_trans_n1 A R x y -> + clos_refl_sym_trans_n1 A R y x. + Proof. + intros x y H; elim H. + constructor 1. + intros y0 z D H0 H1. apply rtsn1_trans with y0; auto. + right with z. + tauto. + left. + Qed. + + Lemma rts_rtsn1 : forall x y, + clos_refl_sym_trans A R x y -> clos_refl_sym_trans_n1 A R x y. + Proof. + induction 1. + constructor 2 with x; auto. + constructor 1. + constructor 1. + apply rtsn1_sym; auto. + eapply rtsn1_trans; eauto. + Qed. + + Lemma rts_rtsn1_equiv : forall x y, + clos_refl_sym_trans A R x y <-> clos_refl_sym_trans_n1 A R x y. + Proof. + split. + apply rts_rtsn1. + apply rtsn1_rts. + Qed. + + End Equivalences. + End Properties. diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index 87cd1e6f..027a9e6c 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -6,68 +6,119 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Relation_Operators.v 10681 2008-03-16 13:40:45Z msozeau $ i*) +(*i $Id: Relation_Operators.v 11481 2008-10-20 19:23:51Z herbelin $ i*) -(****************************************************************************) -(* Bruno Barras, Cristina Cornes *) -(* *) -(* Some of these definitons were taken from : *) -(* Constructing Recursion Operators in Type Theory *) -(* L. Paulson JSC (1986) 2, 325-355 *) -(****************************************************************************) +(************************************************************************) +(** * Bruno Barras, Cristina Cornes *) +(** * *) +(** * Some of these definitions were taken from : *) +(** * Constructing Recursion Operators in Type Theory *) +(** * L. Paulson JSC (1986) 2, 325-355 *) +(************************************************************************) Require Import Relation_Definitions. Require Import List. -(** Some operators to build relations *) +(** * Some operators to build relations *) + +(** ** Transitive closure *) Section Transitive_Closure. Variable A : Type. Variable R : relation A. - + + (** Definition by direct transitive closure *) + Inductive clos_trans (x: A) : A -> Prop := - | t_step : forall y:A, R x y -> clos_trans x y - | t_trans : - forall y z:A, clos_trans x y -> clos_trans y z -> clos_trans x z. + | t_step (y:A) : R x y -> clos_trans x y + | t_trans (y z:A) : clos_trans x y -> clos_trans y z -> clos_trans x z. + + (** Alternative definition by transitive extension on the left *) + + Inductive clos_trans_1n (x: A) : A -> Prop := + | t1n_step (y:A) : R x y -> clos_trans_1n x y + | t1n_trans (y z:A) : R x y -> clos_trans_1n y z -> clos_trans_1n x z. + + (** Alternative definition by transitive extension on the right *) + + Inductive clos_trans_n1 (x: A) : A -> Prop := + | tn1_step (y:A) : R x y -> clos_trans_n1 x y + | tn1_trans (y z:A) : R y z -> clos_trans_n1 x y -> clos_trans_n1 x z. + End Transitive_Closure. +(** ** Reflexive-transitive closure *) Section Reflexive_Transitive_Closure. Variable A : Type. Variable R : relation A. - Inductive clos_refl_trans (x:A) : A -> Prop:= - | rt_step : forall y:A, R x y -> clos_refl_trans x y + (** Definition by direct reflexive-transitive closure *) + + Inductive clos_refl_trans (x:A) : A -> Prop := + | rt_step (y:A) : R x y -> clos_refl_trans x y | rt_refl : clos_refl_trans x x - | rt_trans : - forall y z:A, + | rt_trans (y z:A) : clos_refl_trans x y -> clos_refl_trans y z -> clos_refl_trans x z. + + (** Alternative definition by transitive extension on the left *) + + Inductive clos_refl_trans_1n (x: A) : A -> Prop := + | rt1n_refl : clos_refl_trans_1n x x + | rt1n_trans (y z:A) : + R x y -> clos_refl_trans_1n y z -> clos_refl_trans_1n x z. + + (** Alternative definition by transitive extension on the right *) + + Inductive clos_refl_trans_n1 (x: A) : A -> Prop := + | rtn1_refl : clos_refl_trans_n1 x x + | rtn1_trans (y z:A) : + R y z -> clos_refl_trans_n1 x y -> clos_refl_trans_n1 x z. + End Reflexive_Transitive_Closure. +(** ** Reflexive-symmetric-transitive closure *) Section Reflexive_Symetric_Transitive_Closure. Variable A : Type. Variable R : relation A. + (** Definition by direct reflexive-symmetric-transitive closure *) + Inductive clos_refl_sym_trans : relation A := - | rst_step : forall x y:A, R x y -> clos_refl_sym_trans x y - | rst_refl : forall x:A, clos_refl_sym_trans x x - | rst_sym : - forall x y:A, clos_refl_sym_trans x y -> clos_refl_sym_trans y x - | rst_trans : - forall x y z:A, + | rst_step (x y:A) : R x y -> clos_refl_sym_trans x y + | rst_refl (x:A) : clos_refl_sym_trans x x + | rst_sym (x y:A) : clos_refl_sym_trans x y -> clos_refl_sym_trans y x + | rst_trans (x y z:A) : clos_refl_sym_trans x y -> clos_refl_sym_trans y z -> clos_refl_sym_trans x z. + + (** Alternative definition by symmetric-transitive extension on the left *) + + Inductive clos_refl_sym_trans_1n (x: A) : A -> Prop := + | rts1n_refl : clos_refl_sym_trans_1n x x + | rts1n_trans (y z:A) : R x y \/ R y x -> + clos_refl_sym_trans_1n y z -> clos_refl_sym_trans_1n x z. + + (** Alternative definition by symmetric-transitive extension on the right *) + + Inductive clos_refl_sym_trans_n1 (x: A) : A -> Prop := + | rtsn1_refl : clos_refl_sym_trans_n1 x x + | rtsn1_trans (y z:A) : R y z \/ R z y -> + clos_refl_sym_trans_n1 x y -> clos_refl_sym_trans_n1 x z. + End Reflexive_Symetric_Transitive_Closure. +(** ** Converse of a relation *) -Section Transposee. +Section Converse. Variable A : Type. Variable R : relation A. Definition transp (x y:A) := R y x. -End Transposee. +End Converse. +(** ** Union of relations *) Section Union. Variable A : Type. @@ -76,6 +127,7 @@ Section Union. Definition union (x y:A) := R1 x y \/ R2 x y. End Union. +(** ** Disjoint union of relations *) Section Disjoint_Union. Variables A B : Type. @@ -83,16 +135,15 @@ Variable leA : A -> A -> Prop. Variable leB : B -> B -> Prop. Inductive le_AsB : A + B -> A + B -> Prop := - | le_aa : forall x y:A, leA x y -> le_AsB (inl _ x) (inl _ y) - | le_ab : forall (x:A) (y:B), le_AsB (inl _ x) (inr _ y) - | le_bb : forall x y:B, leB x y -> le_AsB (inr _ x) (inr _ y). + | le_aa (x y:A) : leA x y -> le_AsB (inl _ x) (inl _ y) + | le_ab (x:A) (y:B) : le_AsB (inl _ x) (inr _ y) + | le_bb (x y:B) : leB x y -> le_AsB (inr _ x) (inr _ y). End Disjoint_Union. - +(** ** Lexicographic order on dependent pairs *) Section Lexicographic_Product. - (* Lexicographic order on dependent pairs *) Variable A : Type. Variable B : A -> Type. @@ -106,8 +157,10 @@ Section Lexicographic_Product. | right_lex : forall (x:A) (y y':B x), leB x y y' -> lexprod (existS B x y) (existS B x y'). + End Lexicographic_Product. +(** ** Product of relations *) Section Symmetric_Product. Variable A : Type. @@ -123,16 +176,15 @@ Section Symmetric_Product. End Symmetric_Product. +(** ** Multiset of two relations *) Section Swap. Variable A : Type. Variable R : A -> A -> Prop. Inductive swapprod : A * A -> A * A -> Prop := - | sp_noswap : forall x x':A * A, symprod A A R R x x' -> swapprod x x' - | sp_swap : - forall (x y:A) (p:A * A), - symprod A A R R (x, y) p -> swapprod (y, x) p. + | sp_noswap x y (p:A * A) : symprod A A R R (x, y) p -> swapprod (x, y) p + | sp_swap x y (p:A * A) : symprod A A R R (x, y) p -> swapprod (y, x) p. End Swap. @@ -144,16 +196,14 @@ Section Lexicographic_Exponentiation. Let List := list A. Inductive Ltl : List -> List -> Prop := - | Lt_nil : forall (a:A) (x:List), Ltl Nil (a :: x) - | Lt_hd : forall a b:A, leA a b -> forall x y:list A, Ltl (a :: x) (b :: y) - | Lt_tl : forall (a:A) (x y:List), Ltl x y -> Ltl (a :: x) (a :: y). - + | Lt_nil (a:A) (x:List) : Ltl Nil (a :: x) + | Lt_hd (a b:A) : leA a b -> forall x y:list A, Ltl (a :: x) (b :: y) + | Lt_tl (a:A) (x y:List) : Ltl x y -> Ltl (a :: x) (a :: y). Inductive Desc : List -> Prop := | d_nil : Desc Nil - | d_one : forall x:A, Desc (x :: Nil) - | d_conc : - forall (x y:A) (l:List), + | d_one (x:A) : Desc (x :: Nil) + | d_conc (x y:A) (l:List) : leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil). Definition Pow : Set := sig Desc. diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index d6975e91..e7fe82b2 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -6,38 +6,53 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Setoid.v 10765 2008-04-08 16:15:23Z msozeau $: i*) +(*i $Id: Setoid.v 11720 2008-12-28 07:12:15Z letouzey $: i*) Require Export Coq.Classes.SetoidTactics. (** For backward compatibility *) -Definition Setoid_Theory := @Equivalence. -Definition Build_Setoid_Theory := @Build_Equivalence. -Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x := - Eval compute in reflexivity. -Definition Seq_sym A Aeq (s : Setoid_Theory A Aeq) : forall x y:A, Aeq x y -> Aeq y x := - Eval compute in symmetry. -Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z := - Eval compute in transitivity. +Definition Setoid_Theory := @Equivalence. +Definition Build_Setoid_Theory := @Build_Equivalence. -(** Some tactics for manipulating Setoid Theory not officially - declared as Setoid. *) +Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x. + unfold Setoid_Theory. intros ; reflexivity. +Defined. + +Definition Seq_sym A Aeq (s : Setoid_Theory A Aeq) : forall x y:A, Aeq x y -> Aeq y x. + unfold Setoid_Theory. intros ; symmetry ; assumption. +Defined. -Ltac trans_st x := match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => - apply (Seq_trans _ _ H) with x; auto - end. +Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z. + unfold Setoid_Theory. intros ; transitivity y ; assumption. +Defined. -Ltac sym_st := match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => - apply (Seq_sym _ _ H); auto - end. +(** Some tactics for manipulating Setoid Theory not officially + declared as Setoid. *) -Ltac refl_st := match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => - apply (Seq_refl _ _ H); auto - end. +Ltac trans_st x := + idtac "trans_st on Setoid_Theory is OBSOLETE"; + idtac "use transitivity on Equivalence instead"; + match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + apply (Seq_trans _ _ H) with x; auto + end. + +Ltac sym_st := + idtac "sym_st on Setoid_Theory is OBSOLETE"; + idtac "use symmetry on Equivalence instead"; + match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + apply (Seq_sym _ _ H); auto + end. + +Ltac refl_st := + idtac "refl_st on Setoid_Theory is OBSOLETE"; + idtac "use reflexivity on Equivalence instead"; + match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + apply (Seq_refl _ _ H); auto + end. Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A). Proof. diff --git a/theories/Setoids/Setoid_Prop.v b/theories/Setoids/Setoid_Prop.v deleted file mode 100644 index 7300937e..00000000 --- a/theories/Setoids/Setoid_Prop.v +++ /dev/null @@ -1,79 +0,0 @@ - -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* iff ==> iff as Impl_Morphism. -Proof. - unfold impl; tauto. -Qed. - -(** [and] is a morphism *) - -Add Morphism and with signature iff ==> iff ==> iff as And_Morphism. - tauto. -Qed. - -(** [or] is a morphism *) - -Add Morphism or with signature iff ==> iff ==> iff as Or_Morphism. -Proof. - tauto. -Qed. - -(** [not] is a morphism *) - -Add Morphism not with signature iff ==> iff as Not_Morphism. -Proof. - tauto. -Qed. - -(** The same examples on [impl] *) - -Add Morphism and with signature impl ++> impl ++> impl as And_Morphism2. -Proof. - unfold impl; tauto. -Qed. - -Add Morphism or with signature impl ++> impl ++> impl as Or_Morphism2. -Proof. - unfold impl; tauto. -Qed. - -Add Morphism not with signature impl --> impl as Not_Morphism2. -Proof. - unfold impl; tauto. -Qed. - diff --git a/theories/Setoids/Setoid_tac.v b/theories/Setoids/Setoid_tac.v deleted file mode 100644 index cdc4eafe..00000000 --- a/theories/Setoids/Setoid_tac.v +++ /dev/null @@ -1,595 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* reflexive _ Aeq -> X_Relation_Class X - | AsymmetricReflexive : X -> forall A Aeq, reflexive A Aeq -> X_Relation_Class X - | SymmetricAreflexive : forall A Aeq, symmetric A Aeq -> X_Relation_Class X - | AsymmetricAreflexive : X -> forall A (Aeq : relation A), X_Relation_Class X - | Leibniz : Type -> X_Relation_Class X. - -Inductive variance : Set := - Covariant - | Contravariant. - -Definition Argument_Class := X_Relation_Class variance. -Definition Relation_Class := X_Relation_Class unit. - -Inductive Reflexive_Relation_Class : Type := - RSymmetric : - forall A Aeq, symmetric A Aeq -> reflexive _ Aeq -> Reflexive_Relation_Class - | RAsymmetric : - forall A Aeq, reflexive A Aeq -> Reflexive_Relation_Class - | RLeibniz : Type -> Reflexive_Relation_Class. - -Inductive Areflexive_Relation_Class : Type := - | ASymmetric : forall A Aeq, symmetric A Aeq -> Areflexive_Relation_Class - | AAsymmetric : forall A (Aeq : relation A), Areflexive_Relation_Class. - -Implicit Type Hole Out: Relation_Class. - -Definition relation_class_of_argument_class : Argument_Class -> Relation_Class. - destruct 1. - exact (SymmetricReflexive _ s r). - exact (AsymmetricReflexive tt r). - exact (SymmetricAreflexive _ s). - exact (AsymmetricAreflexive tt Aeq). - exact (Leibniz _ T). -Defined. - -Definition carrier_of_relation_class : forall X, X_Relation_Class X -> Type. - destruct 1. - exact A. - exact A. - exact A. - exact A. - exact T. -Defined. - -Definition relation_of_relation_class : - forall X R, @carrier_of_relation_class X R -> carrier_of_relation_class R -> Prop. - destruct R. - exact Aeq. - exact Aeq. - exact Aeq. - exact Aeq. - exact (@eq T). -Defined. - -Lemma about_carrier_of_relation_class_and_relation_class_of_argument_class : - forall R, - carrier_of_relation_class (relation_class_of_argument_class R) = - carrier_of_relation_class R. - destruct R; reflexivity. -Defined. - -Inductive nelistT (A : Type) : Type := - singl : A -> nelistT A - | necons : A -> nelistT A -> nelistT A. - -Definition Arguments := nelistT Argument_Class. - -Implicit Type In: Arguments. - -Definition function_type_of_morphism_signature : - Arguments -> Relation_Class -> Type. - intros In Out. - induction In. - exact (carrier_of_relation_class a -> carrier_of_relation_class Out). - exact (carrier_of_relation_class a -> IHIn). -Defined. - -Definition make_compatibility_goal_aux: - forall In Out - (f g: function_type_of_morphism_signature In Out), Prop. - intros; induction In; simpl in f, g. - induction a; simpl in f, g. - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x, relation_of_relation_class Out (f x) (g x)). - induction a; simpl in f, g. - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> IHIn (f x1) (g x2)). - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> IHIn (f x1) (g x2)). - exact (forall x, IHIn (f x) (g x)). -Defined. - -Definition make_compatibility_goal := - (fun In Out f => make_compatibility_goal_aux In Out f f). - -Record Morphism_Theory In Out : Type := - { Function : function_type_of_morphism_signature In Out; - Compat : make_compatibility_goal In Out Function }. - - -(** The [iff] relation class *) - -Definition Iff_Relation_Class : Relation_Class. - eapply (@SymmetricReflexive unit _ iff). - exact iff_sym. - exact iff_refl. -Defined. - -(** The [impl] relation class *) - -Definition impl (A B: Prop) := A -> B. - -Theorem impl_refl: reflexive _ impl. -Proof. - hnf; unfold impl; tauto. -Qed. - -Definition Impl_Relation_Class : Relation_Class. - eapply (@AsymmetricReflexive unit tt _ impl). - exact impl_refl. -Defined. - -(** Every function is a morphism from Leibniz+ to Leibniz *) - -Definition list_of_Leibniz_of_list_of_types: nelistT Type -> Arguments. - induction 1. - exact (singl (Leibniz _ a)). - exact (necons (Leibniz _ a) IHX). -Defined. - -Definition morphism_theory_of_function : - forall (In: nelistT Type) (Out: Type), - let In' := list_of_Leibniz_of_list_of_types In in - let Out' := Leibniz _ Out in - function_type_of_morphism_signature In' Out' -> - Morphism_Theory In' Out'. - intros. - exists X. - induction In; unfold make_compatibility_goal; simpl. - reflexivity. - intro; apply (IHIn (X x)). -Defined. - -(** Every predicate is a morphism from Leibniz+ to Iff_Relation_Class *) - -Definition morphism_theory_of_predicate : - forall (In: nelistT Type), - let In' := list_of_Leibniz_of_list_of_types In in - function_type_of_morphism_signature In' Iff_Relation_Class -> - Morphism_Theory In' Iff_Relation_Class. - intros. - exists X. - induction In; unfold make_compatibility_goal; simpl. - intro; apply iff_refl. - intro; apply (IHIn (X x)). -Defined. - -(** * Utility functions to prove that every transitive relation is a morphism *) - -Definition equality_morphism_of_symmetric_areflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(sym: symmetric _ Aeq)(trans: transitive _ Aeq), - let ASetoidClass := SymmetricAreflexive _ sym in - (Morphism_Theory (necons ASetoidClass (singl ASetoidClass)) Iff_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; split; eauto. -Defined. - -Definition equality_morphism_of_symmetric_reflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(refl: reflexive _ Aeq)(sym: symmetric _ Aeq) - (trans: transitive _ Aeq), let ASetoidClass := SymmetricReflexive _ sym refl in - (Morphism_Theory (necons ASetoidClass (singl ASetoidClass)) Iff_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; split; eauto. -Defined. - -Definition equality_morphism_of_asymmetric_areflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(trans: transitive _ Aeq), - let ASetoidClass1 := AsymmetricAreflexive Contravariant Aeq in - let ASetoidClass2 := AsymmetricAreflexive Covariant Aeq in - (Morphism_Theory (necons ASetoidClass1 (singl ASetoidClass2)) Impl_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; unfold impl; eauto. -Defined. - -Definition equality_morphism_of_asymmetric_reflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(refl: reflexive _ Aeq)(trans: transitive _ Aeq), - let ASetoidClass1 := AsymmetricReflexive Contravariant refl in - let ASetoidClass2 := AsymmetricReflexive Covariant refl in - (Morphism_Theory (necons ASetoidClass1 (singl ASetoidClass2)) Impl_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; unfold impl; eauto. -Defined. - -(** * The CIC part of the reflexive tactic ([setoid_rewrite]) *) - -Inductive rewrite_direction : Type := - | Left2Right - | Right2Left. - -Implicit Type dir: rewrite_direction. - -Definition variance_of_argument_class : Argument_Class -> option variance. - destruct 1. - exact None. - exact (Some v). - exact None. - exact (Some v). - exact None. -Defined. - -Definition opposite_direction := - fun dir => - match dir with - | Left2Right => Right2Left - | Right2Left => Left2Right - end. - -Lemma opposite_direction_idempotent: - forall dir, (opposite_direction (opposite_direction dir)) = dir. -Proof. - destruct dir; reflexivity. -Qed. - -Inductive check_if_variance_is_respected : - option variance -> rewrite_direction -> rewrite_direction -> Prop := - | MSNone : forall dir dir', check_if_variance_is_respected None dir dir' - | MSCovariant : forall dir, check_if_variance_is_respected (Some Covariant) dir dir - | MSContravariant : - forall dir, - check_if_variance_is_respected (Some Contravariant) dir (opposite_direction dir). - -Definition relation_class_of_reflexive_relation_class: - Reflexive_Relation_Class -> Relation_Class. - induction 1. - exact (SymmetricReflexive _ s r). - exact (AsymmetricReflexive tt r). - exact (Leibniz _ T). -Defined. - -Definition relation_class_of_areflexive_relation_class: - Areflexive_Relation_Class -> Relation_Class. - induction 1. - exact (SymmetricAreflexive _ s). - exact (AsymmetricAreflexive tt Aeq). -Defined. - -Definition carrier_of_reflexive_relation_class := - fun R => carrier_of_relation_class (relation_class_of_reflexive_relation_class R). - -Definition carrier_of_areflexive_relation_class := - fun R => carrier_of_relation_class (relation_class_of_areflexive_relation_class R). - -Definition relation_of_areflexive_relation_class := - fun R => relation_of_relation_class (relation_class_of_areflexive_relation_class R). - -Inductive Morphism_Context Hole dir : Relation_Class -> rewrite_direction -> Type := - | App : - forall In Out dir', - Morphism_Theory In Out -> Morphism_Context_List Hole dir dir' In -> - Morphism_Context Hole dir Out dir' - | ToReplace : Morphism_Context Hole dir Hole dir - | ToKeep : - forall S dir', - carrier_of_reflexive_relation_class S -> - Morphism_Context Hole dir (relation_class_of_reflexive_relation_class S) dir' - | ProperElementToKeep : - forall S dir' (x: carrier_of_areflexive_relation_class S), - relation_of_areflexive_relation_class S x x -> - Morphism_Context Hole dir (relation_class_of_areflexive_relation_class S) dir' -with Morphism_Context_List Hole dir : - rewrite_direction -> Arguments -> Type -:= - fcl_singl : - forall S dir' dir'', - check_if_variance_is_respected (variance_of_argument_class S) dir' dir'' -> - Morphism_Context Hole dir (relation_class_of_argument_class S) dir' -> - Morphism_Context_List Hole dir dir'' (singl S) - | fcl_cons : - forall S L dir' dir'', - check_if_variance_is_respected (variance_of_argument_class S) dir' dir'' -> - Morphism_Context Hole dir (relation_class_of_argument_class S) dir' -> - Morphism_Context_List Hole dir dir'' L -> - Morphism_Context_List Hole dir dir'' (necons S L). - -Scheme Morphism_Context_rect2 := Induction for Morphism_Context Sort Type -with Morphism_Context_List_rect2 := Induction for Morphism_Context_List Sort Type. - -Definition product_of_arguments : Arguments -> Type. - induction 1. - exact (carrier_of_relation_class a). - exact (prod (carrier_of_relation_class a) IHX). -Defined. - -Definition get_rewrite_direction: rewrite_direction -> Argument_Class -> rewrite_direction. - intros dir R. - destruct (variance_of_argument_class R). - destruct v. - exact dir. (* covariant *) - exact (opposite_direction dir). (* contravariant *) - exact dir. (* symmetric relation *) -Defined. - -Definition directed_relation_of_relation_class: - forall dir (R: Relation_Class), - carrier_of_relation_class R -> carrier_of_relation_class R -> Prop. - destruct 1. - exact (@relation_of_relation_class unit). - intros; exact (relation_of_relation_class _ X0 X). -Defined. - -Definition directed_relation_of_argument_class: - forall dir (R: Argument_Class), - carrier_of_relation_class R -> carrier_of_relation_class R -> Prop. - intros dir R. - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class R). - exact (directed_relation_of_relation_class dir (relation_class_of_argument_class R)). -Defined. - - -Definition relation_of_product_of_arguments: - forall dir In, - product_of_arguments In -> product_of_arguments In -> Prop. - induction In. - simpl. - exact (directed_relation_of_argument_class (get_rewrite_direction dir a) a). - - simpl; intros. - destruct X; destruct X0. - apply and. - exact - (directed_relation_of_argument_class (get_rewrite_direction dir a) a c c0). - exact (IHIn p p0). -Defined. - -Definition apply_morphism: - forall In Out (m: function_type_of_morphism_signature In Out) - (args: product_of_arguments In), carrier_of_relation_class Out. - intros. - induction In. - exact (m args). - simpl in m, args. - destruct args. - exact (IHIn (m c) p). -Defined. - -Theorem apply_morphism_compatibility_Right2Left: - forall In Out (m1 m2: function_type_of_morphism_signature In Out) - (args1 args2: product_of_arguments In), - make_compatibility_goal_aux _ _ m1 m2 -> - relation_of_product_of_arguments Right2Left _ args1 args2 -> - directed_relation_of_relation_class Right2Left _ - (apply_morphism _ _ m2 args1) - (apply_morphism _ _ m1 args2). - induction In; intros. - simpl in m1, m2, args1, args2, H0 |- *. - destruct a; simpl in H; hnf in H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - rewrite H0; apply H; exact H0. - - simpl in m1, m2, args1, args2, H0 |- *. - destruct args1; destruct args2; simpl. - destruct H0. - simpl in H. - destruct a; simpl in H. - apply IHIn. - apply H; exact H0. - exact H1. - destruct v. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - destruct v. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - rewrite H0; apply IHIn. - apply H. - exact H1. -Qed. - -Theorem apply_morphism_compatibility_Left2Right: - forall In Out (m1 m2: function_type_of_morphism_signature In Out) - (args1 args2: product_of_arguments In), - make_compatibility_goal_aux _ _ m1 m2 -> - relation_of_product_of_arguments Left2Right _ args1 args2 -> - directed_relation_of_relation_class Left2Right _ - (apply_morphism _ _ m1 args1) - (apply_morphism _ _ m2 args2). -Proof. - induction In; intros. - simpl in m1, m2, args1, args2, H0 |- *. - destruct a; simpl in H; hnf in H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - rewrite H0; apply H; exact H0. - - simpl in m1, m2, args1, args2, H0 |- *. - destruct args1; destruct args2; simpl. - destruct H0. - simpl in H. - destruct a; simpl in H. - apply IHIn. - apply H; exact H0. - exact H1. - destruct v. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - destruct v; simpl in H, H0; apply H; exact H0. - exact H1. - rewrite H0; apply IHIn. - apply H. - exact H1. -Qed. - -Definition interp : - forall Hole dir Out dir', carrier_of_relation_class Hole -> - Morphism_Context Hole dir Out dir' -> carrier_of_relation_class Out. - intros Hole dir Out dir' H t. - elim t using - (@Morphism_Context_rect2 Hole dir (fun S _ _ => carrier_of_relation_class S) - (fun _ L fcl => product_of_arguments L)); - intros. - exact (apply_morphism _ _ (Function m) X). - exact H. - exact c. - exact x. - simpl; - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - split. - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - exact X0. -Defined. - -(* CSC: interp and interp_relation_class_list should be mutually defined, since - the proof term of each one contains the proof term of the other one. However - I cannot do that interactively (I should write the Fix by hand) *) -Definition interp_relation_class_list : - forall Hole dir dir' (L: Arguments), carrier_of_relation_class Hole -> - Morphism_Context_List Hole dir dir' L -> product_of_arguments L. - intros Hole dir dir' L H t. - elim t using - (@Morphism_Context_List_rect2 Hole dir (fun S _ _ => carrier_of_relation_class S) - (fun _ L fcl => product_of_arguments L)); - intros. - exact (apply_morphism _ _ (Function m) X). - exact H. - exact c. - exact x. - simpl; - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - split. - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - exact X0. -Defined. - -Theorem setoid_rewrite: - forall Hole dir Out dir' (E1 E2: carrier_of_relation_class Hole) - (E: Morphism_Context Hole dir Out dir'), - (directed_relation_of_relation_class dir Hole E1 E2) -> - (directed_relation_of_relation_class dir' Out (interp E1 E) (interp E2 E)). -Proof. - intros. - elim E using - (@Morphism_Context_rect2 Hole dir - (fun S dir'' E => directed_relation_of_relation_class dir'' S (interp E1 E) (interp E2 E)) - (fun dir'' L fcl => - relation_of_product_of_arguments dir'' _ - (interp_relation_class_list E1 fcl) - (interp_relation_class_list E2 fcl))); intros. - change (directed_relation_of_relation_class dir'0 Out0 - (apply_morphism _ _ (Function m) (interp_relation_class_list E1 m0)) - (apply_morphism _ _ (Function m) (interp_relation_class_list E2 m0))). - destruct dir'0. - apply apply_morphism_compatibility_Left2Right. - exact (Compat m). - exact H0. - apply apply_morphism_compatibility_Right2Left. - exact (Compat m). - exact H0. - - exact H. - - unfold interp, Morphism_Context_rect2. - (* CSC: reflexivity used here *) - destruct S; destruct dir'0; simpl; (apply r || reflexivity). - - destruct dir'0; exact r. - - destruct S; unfold directed_relation_of_argument_class; simpl in H0 |- *; - unfold get_rewrite_direction; simpl. - destruct dir'0; destruct dir''; - (exact H0 || - unfold directed_relation_of_argument_class; simpl; apply s; exact H0). - (* the following mess with generalize/clear/intros is to help Coq resolving *) - (* second order unification problems. *) - generalize m c H0; clear H0 m c; inversion c; - generalize m c; clear m c; rewrite <- H1; rewrite <- H2; intros; - (exact H3 || rewrite (opposite_direction_idempotent dir'0); apply H3). - destruct dir'0; destruct dir''; - (exact H0 || - unfold directed_relation_of_argument_class; simpl; apply s; exact H0). - (* the following mess with generalize/clear/intros is to help Coq resolving *) - (* second order unification problems. *) - generalize m c H0; clear H0 m c; inversion c; - generalize m c; clear m c; rewrite <- H1; rewrite <- H2; intros; - (exact H3 || rewrite (opposite_direction_idempotent dir'0); apply H3). - destruct dir'0; destruct dir''; (exact H0 || hnf; symmetry; exact H0). - - change - (directed_relation_of_argument_class (get_rewrite_direction dir'' S) S - (eq_rect _ (fun T : Type => T) (interp E1 m) _ - (about_carrier_of_relation_class_and_relation_class_of_argument_class S)) - (eq_rect _ (fun T : Type => T) (interp E2 m) _ - (about_carrier_of_relation_class_and_relation_class_of_argument_class S)) /\ - relation_of_product_of_arguments dir'' _ - (interp_relation_class_list E1 m0) (interp_relation_class_list E2 m0)). - split. - clear m0 H1; destruct S; simpl in H0 |- *; unfold get_rewrite_direction; simpl. - destruct dir''; destruct dir'0; (exact H0 || hnf; apply s; exact H0). - inversion c. - rewrite <- H3; exact H0. - rewrite (opposite_direction_idempotent dir'0); exact H0. - destruct dir''; destruct dir'0; (exact H0 || hnf; apply s; exact H0). - inversion c. - rewrite <- H3; exact H0. - rewrite (opposite_direction_idempotent dir'0); exact H0. - destruct dir''; destruct dir'0; (exact H0 || hnf; symmetry; exact H0). - exact H1. - Qed. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 4c560c6b..228a882a 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zdiv.v 10999 2008-05-27 15:55:22Z letouzey $ i*) +(*i $Id: Zdiv.v 11477 2008-10-20 15:16:14Z letouzey $ i*) (* Contribution by Claude Marché and Xavier Urbain *) @@ -901,66 +901,63 @@ Proof. intros; rewrite Zmult_mod, Zmod_mod, <- Zmult_mod; auto. Qed. -(** For a specific number n, equality modulo n is hence a nice setoid - equivalence, compatible with the usual operations. Due to restrictions - with Coq setoids, we cannot state this in a section, but it works - at least with a module. *) +(** For a specific number N, equality modulo N is hence a nice setoid + equivalence, compatible with [+], [-] and [*]. *) -Module Type SomeNumber. - Parameter n:Z. -End SomeNumber. +Definition eqm N a b := (a mod N = b mod N). -Module EqualityModulo (M:SomeNumber). +Lemma eqm_refl N : forall a, (eqm N) a a. +Proof. unfold eqm; auto. Qed. - Definition eqm a b := (a mod M.n = b mod M.n). - Infix "==" := eqm (at level 70). +Lemma eqm_sym N : forall a b, (eqm N) a b -> (eqm N) b a. +Proof. unfold eqm; auto. Qed. - Lemma eqm_refl : forall a, a == a. - Proof. unfold eqm; auto. Qed. +Lemma eqm_trans N : forall a b c, + (eqm N) a b -> (eqm N) b c -> (eqm N) a c. +Proof. unfold eqm; eauto with *. Qed. - Lemma eqm_sym : forall a b, a == b -> b == a. - Proof. unfold eqm; auto. Qed. +Add Parametric Relation N : Z (eqm N) + reflexivity proved by (eqm_refl N) + symmetry proved by (eqm_sym N) + transitivity proved by (eqm_trans N) as eqm_setoid. - Lemma eqm_trans : forall a b c, a == b -> b == c -> a == c. - Proof. unfold eqm; eauto with *. Qed. - - Add Relation Z eqm - reflexivity proved by eqm_refl - symmetry proved by eqm_sym - transitivity proved by eqm_trans as eqm_setoid. - - Add Morphism Zplus : Zplus_eqm. - Proof. +Add Parametric Morphism N : Zplus + with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zplus_eqm. +Proof. unfold eqm; intros; rewrite Zplus_mod, H, H0, <- Zplus_mod; auto. - Qed. +Qed. - Add Morphism Zminus : Zminus_eqm. - Proof. +Add Parametric Morphism N : Zminus + with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zminus_eqm. +Proof. unfold eqm; intros; rewrite Zminus_mod, H, H0, <- Zminus_mod; auto. - Qed. +Qed. - Add Morphism Zmult : Zmult_eqm. - Proof. +Add Parametric Morphism N : Zmult + with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zmult_eqm. +Proof. unfold eqm; intros; rewrite Zmult_mod, H, H0, <- Zmult_mod; auto. - Qed. +Qed. - Add Morphism Zopp : Zopp_eqm. - Proof. - intros; change (-x == -y) with (0-x == 0-y). +Add Parametric Morphism N : Zopp + with signature (eqm N) ==> (eqm N) as Zopp_eqm. +Proof. + intros; change ((eqm N) (-x) (-y)) with ((eqm N) (0-x) (0-y)). rewrite H; red; auto. - Qed. - - Lemma Zmod_eqm : forall a, a mod M.n == a. - Proof. - unfold eqm; intros; apply Zmod_mod. - Qed. +Qed. - (* Zmod and Zdiv are not full morphisms with respect to eqm. - For instance, take n=2. Then 3 == 1 but we don't have - 1 mod 3 == 1 mod 1 nor 1/3 == 1/1. - *) +Lemma Zmod_eqm N : forall a, (eqm N) (a mod N) a. +Proof. + intros; exact (Zmod_mod a N). +Qed. -End EqualityModulo. +(* NB: Zmod and Zdiv are not morphisms with respect to eqm. + For instance, let (==) be (eqm 2). Then we have (3 == 1) but: + ~ (3 mod 3 == 1 mod 3) + ~ (1 mod 3 == 1 mod 1) + ~ (3/3 == 1/3) + ~ (1/3 == 1/1) +*) Lemma Zdiv_Zdiv : forall a b c, 0<=b -> 0<=c -> (a/b)/c = a/(b*c). Proof. diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v index 726fb45a..ffc3e70f 100644 --- a/theories/ZArith/auxiliary.v +++ b/theories/ZArith/auxiliary.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: auxiliary.v 9302 2006-10-27 21:21:17Z barras $ i*) +(*i $Id: auxiliary.v 11739 2009-01-02 19:33:19Z herbelin $ i*) (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) @@ -91,46 +91,6 @@ Proof. rewrite Zplus_opp_r; trivial. Qed. -(**********************************************************************) -(** * Factorization lemmas *) - -Theorem Zred_factor0 : forall n:Z, n = n * 1. - intro x; rewrite (Zmult_1_r x); reflexivity. -Qed. - -Theorem Zred_factor1 : forall n:Z, n + n = n * 2. -Proof. - exact Zplus_diag_eq_mult_2. -Qed. - -Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m). -Proof. - intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x); - rewrite <- Zmult_plus_distr_r; trivial with arith. -Qed. - -Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m). -Proof. - intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x); - rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; - trivial with arith. -Qed. - -Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p). -Proof. - intros x y z; symmetry in |- *; apply Zmult_plus_distr_r. -Qed. - -Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m. -Proof. - intros x y; rewrite <- Zmult_0_r_reverse; auto with arith. -Qed. - -Theorem Zred_factor6 : forall n:Z, n = n + 0. -Proof. - intro; rewrite Zplus_0_r; trivial with arith. -Qed. - Theorem Zle_mult_approx : forall n m p:Z, n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p. Proof. diff --git a/tools/beautify-archive b/tools/beautify-archive new file mode 100755 index 00000000..aac6f3e0 --- /dev/null +++ b/tools/beautify-archive @@ -0,0 +1,52 @@ +#!/bin/sh + +#This script compiles and beautifies an archive, check the correctness +#of beautified files, then replace the original files by the +#beautified ones, keeping a copy of original files in $OLDARCHIVE. +#The script assumes: +#- that the archive provides a Makefile built by coq_makefile, +#- that coqc is in the path or that variables COQTOP and COQBIN are set. + +OLDARCHIVE=old_files +NEWARCHIVE=beautify_files +BEAUTIFYSUFFIX=.beautified + +if [ -e $OLDARCHIVE ]; then + echo "Warning: $OLDARCHIVE directory found, the files are maybe already beautified"; + sleep 5; +fi +echo ---- Producing beautified files in the beautification directory ------- +if [ -e $NEWARCHIVE ]; then rm -r $NEWARCHIVE; fi +if [ -e /tmp/$OLDARCHIVE.$$ ]; then rm -r /tmp/$OLDARCHIVE.$$; fi +cp -pr . /tmp/$OLDARCHIVE.$$ +cp -pr /tmp/$OLDARCHIVE.$$ $NEWARCHIVE +cd $NEWARCHIVE +rm description || true +make clean +make COQFLAGS='-beautify -q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)' || \ + { echo ---- Failed to beautify; exit 1; } +echo -------- Upgrading files in the beautification directory -------------- +beaufiles=`find . -name \*.v$BEAUTIFYSUFFIX` +for i in $beaufiles; do + j=`dirname $i`/`basename $i .v$BEAUTIFYSUFFIX`.v + echo Upgrading $j in the beautification directory + mv -u -f $i $j +done +echo ---- Recompiling beautified files in the beautification directory ----- +make clean +make || { echo ---- Failed to recompile; exit 1; } +echo ----- Saving old files in directory $OLDARCHIVE ------------------------- +/bin/rm -r ../$OLDARCHIVE +mv /tmp/$OLDARCHIVE.$$ ../$OLDARCHIVE +echo Saving $OLDARCHIVE files done +echo --------- Upgrading files in current directory ------------------------ +vfiles=`find . -name \*.v` +cd .. +for i in $vfiles; do + echo Upgrading $i in current directory + mv -u -f $NEWARCHIVE/$i $i +done +echo -------- Beautification completed ------------------------------------- +echo Old files are in directory '"$OLDARCHIVE"' +echo New files are in current directory +echo You can now remove the beautification directory '"$NEWARCHIVE"' diff --git a/tools/coq_makefile.ml4 b/tools/coq_makefile.ml4 index d1d0d854..3fbf71dd 100644 --- a/tools/coq_makefile.ml4 +++ b/tools/coq_makefile.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coq_makefile.ml4 11255 2008-07-24 16:57:13Z notin $ *) +(* $Id: coq_makefile.ml4 11771 2009-01-09 18:00:56Z notin $ *) (* créer un Makefile pour un développement Coq automatiquement *) @@ -29,6 +29,7 @@ let some_mlfile = ref false let opt = ref "-opt" let impredicative_set = ref false +let no_install = ref false let print x = output_string !output_channel x let printf x = Printf.fprintf !output_channel x @@ -38,6 +39,14 @@ let rec print_list sep = function | x :: l -> print x; print sep; print_list sep l | [] -> () +let list_iter_i f = + let rec aux i = function [] -> () | a::l -> f i a; aux (i+1) l in aux 1 + +let best_ocamlc = + if Coq_config.best = "opt" then "ocamlc.opt" else "ocamlc" +let best_ocamlopt = + if Coq_config.best = "opt" then "ocamlopt.opt" else "ocamlopt" + let section s = let l = String.length s in let sep = String.make (l+5) '#' @@ -58,10 +67,11 @@ let usage () = coq_makefile [subdirectory] .... [file.v] ... [file.ml] ... [-custom command dependencies file] ... [-I dir] ... [-R physicalpath logicalpath] - ... [VARIABLE = value] ... [-opt|-byte] [-f file] [-o file] [-h] [--help] + ... [VARIABLE = value] ... [-opt|-byte] [-impredicative-set] [-no-install] + [-f file] [-o file] [-h] [--help] [file.v]: Coq file to be compiled -[file.ml]: ML file to be compiled +[file.ml]: Objective Caml file to be compiled [subdirectory] : subdirectory that should be \"made\" [-custom command dependencies file]: add target \"file\" with command \"command\" and dependencies \"dependencies\" @@ -73,26 +83,118 @@ coq_makefile [subdirectory] .... [file.v] ... [file.ml] ... [-custom [-byte]: compile with byte-code version of coq [-opt]: compile with native-code version of coq [-impredicative-set]: compile with option -impredicative-set of coq +[-no-install]: build a makefile with no install target [-f file]: take the contents of file as arguments [-o file]: output should go in file file [-h]: print this usage summary [--help]: equivalent to [-h]\n"; exit 1 -let standard sds sps = +let is_genrule r = + let genrule = Str.regexp("%") in + Str.string_match genrule r 0 + +let absolute_dir dir = + let current = Sys.getcwd () in + Sys.chdir dir; + let dir' = Sys.getcwd () in + Sys.chdir current; + dir' + +let is_prefix dir1 dir2 = + let l1 = String.length dir1 in + let l2 = String.length dir2 in + dir1 = dir2 or (l1 < l2 & String.sub dir2 0 l1 = dir1 & dir2.[l1] = '/') + +let canonize f = + let l = String.length f in + if l > 2 && f.[0] = '.' && f.[1] = '/' then + let n = let i = ref 2 in while !i < l && f.[!i] = '/' do incr i done; !i in + String.sub f n (l-n) + else f + +let is_absolute_prefix dir dir' = + is_prefix (absolute_dir dir) (absolute_dir dir') + +let is_included dir = function + | RInclude (dir',_) -> is_absolute_prefix dir' dir + | Include dir' -> absolute_dir dir = absolute_dir dir' + | _ -> false + +let has_top_file = function + | ML s | V s -> s = Filename.basename s + | _ -> false + +let physical_dir_of_logical_dir ldir = + let pdir = String.copy ldir in + for i = 0 to String.length ldir - 1 do + if pdir.[i] = '.' then pdir.[i] <- '/'; + done; + pdir + +let standard ()= print "byte:\n"; print "\t$(MAKE) all \"OPT:=-byte\"\n\n"; print "opt:\n"; if !opt = "" then print "\t@echo \"WARNING: opt is disabled\"\n"; - print "\t$(MAKE) all \"OPT:="; print !opt; print "\"\n\n"; + print "\t$(MAKE) all \"OPT:="; print !opt; print "\"\n\n" + +let is_prefix_of_file dir f = + is_prefix dir (absolute_dir (Filename.dirname f)) + +let classify_files_by_root var files (inc_i,inc_r) = + if not (List.exists (fun (pdir,_,_) -> pdir = ".") inc_r) then + begin + (* Files in the scope of a -R option (assuming they are disjoint) *) + list_iter_i (fun i (pdir,ldir,abspdir) -> + if List.exists (is_prefix_of_file abspdir) files then + printf "%s%d:=$(patsubst %s/%%,%%,$(filter %s/%%,$(%s)))\n" + var i pdir pdir var) + inc_r; + (* Files not in the scope of a -R option *) + let pat_of_dir (pdir,_,_) = pdir^"/%" in + let pdir_patterns = String.concat " " (List.map pat_of_dir inc_r) in + printf "%s0:=$(filter-out %s,$(%s))\n" var pdir_patterns var + end + +let install_include_by_root var files (_,inc_r) = + try + (* All files caught by a -R . option (assuming it is the only one) *) + let ldir = List.assoc "." (List.map (fun (p,l,_) -> (p,l)) inc_r) in + let pdir = physical_dir_of_logical_dir ldir in + printf "\t(for i in $(%s); do \\\n" var; + printf "\t install -D $$i $(COQLIB)/user-contrib/%s/$$i; \\\n" pdir; + printf "\t done)\n" + with Not_found -> + (* Files in the scope of a -R option (assuming they are disjoint) *) + list_iter_i (fun i (pdir,ldir,abspdir) -> + if List.exists (is_prefix_of_file abspdir) files then + begin + let pdir' = physical_dir_of_logical_dir ldir in + printf "\t(cd %s; for i in $(%s%d); do \\\n" pdir var i; + printf "\t install -D $$i $(COQLIB)/user-contrib/%s/$$i; \\\n" pdir'; + printf "\t done)\n" + end) inc_r; + (* Files not in the scope of a -R option *) + printf "\t(for i in $(%s0); do \\\n" var; + printf "\t install -D $$i $(COQLIB)/user-contrib/$(INSTALLDEFAULTROOT)/$$i; \\\n"; + printf "\t done)\n" + +let install (vfiles,mlfiles,_,sds) inc = print "install:\n"; - print "\tmkdir -p `$(COQC) -where`/user-contrib\n"; - if !some_vfile then print "\tcp -f $(VOFILES) `$(COQC) -where`/user-contrib\n"; - if !some_mlfile then print "\tcp -f *.cmo `$(COQC) -where`/user-contrib\n"; + print "\tmkdir -p $(COQLIB)/user-contrib\n"; + if !some_vfile then install_include_by_root "VOFILES" vfiles inc; + if !some_mlfile then install_include_by_root "CMOFILES" mlfiles inc; + if !some_mlfile then install_include_by_root "CMIFILES" mlfiles inc; + if Coq_config.has_natdynlink && !some_mlfile then + install_include_by_root "CMXSFILES" mlfiles inc; List.iter - (fun x -> print "\t(cd "; print x; print " ; $(MAKE) install)\n") + (fun x -> + printf "\t(cd %s; $(MAKE) INSTALLDEFAULTROOT=$(INSTALLDEFAULTROOT)/%s install)\n" x x) sds; - print "\n"; + print "\n" + +let make_makefile sds = if !make_name <> "" then begin printf "%s: %s\n" !makefile_name !make_name; printf "\tmv -f %s %s.bak\n" !makefile_name !makefile_name; @@ -102,16 +204,22 @@ let standard sds sps = (fun x -> print "\t(cd "; print x; print " ; $(MAKE) Makefile)\n") sds; print "\n"; - end; + end + +let clean sds sps = print "clean:\n"; - print "\trm -f *.cmo *.cmi *.cmx *.o $(VOFILES) $(VIFILES) $(GFILES) *~\n"; - print "\trm -f all.ps all-gal.ps all.glob $(VFILES:.v=.glob) $(HTMLFILES) \ + print "\trm -f $(VOFILES) $(VIFILES) $(GFILES) *~\n"; + print "\trm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(HTMLFILES) \ $(GHTMLFILES) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) $(VFILES:.v=.v.d)\n"; if !some_mlfile then print "\trm -f $(CMOFILES) $(MLFILES:.ml=.cmi) $(MLFILES:.ml=.ml.d)\n"; + if Coq_config.has_natdynlink && !some_mlfile then + print "\trm -f $(CMXSFILES) $(CMXSFILES:.cmxs=.o)\n"; print "\t- rm -rf html\n"; List.iter - (fun (file,_,_) -> print "\t- rm -f "; print file; print "\n") + (fun (file,_,_) -> + if not (is_genrule file) then + (print "\t- rm -f "; print file; print "\n")) sps; List.iter (fun x -> print "\t(cd "; print x; print " ; $(MAKE) clean)\n") @@ -122,19 +230,26 @@ let standard sds sps = List.iter (fun x -> print "\t(cd "; print x; print " ; $(MAKE) archclean)\n") sds; - print "\n\n" + print "\n\n"; + print "printenv: \n\t@echo CAMLC =\t$(CAMLC)\n\t@echo CAMLOPTC =\t$(CAMLOPTC)\n"; + print "\t@echo CAMLP4LIB =\t$(CAMLP4LIB)\n\n" -let includes () = +let header_includes () = () + +let footer_includes () = if !some_vfile then print "-include $(VFILES:.v=.v.d)\n.SECONDARY: $(VFILES:.v=.v.d)\n\n"; if !some_mlfile then print "-include $(MLFILES:.ml=.ml.d)\n.SECONDARY: $(MLFILES:.ml=.ml.d)\n\n" let implicit () = let ml_rules () = print "%.cmi: %.mli\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; - print "%.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) $<\n\n"; - print "%.cmx: %.ml\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) $<\n\n"; + print "%.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) -c $(PP) $<\n\n"; + print "%.cmx: %.ml\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -c $(PP) $<\n\n"; + print "%.cmxs: %.ml\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $(PP) $<\n\n"; + print "%.cmo: %.ml4\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; + print "%.cmx: %.ml4\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; print "%.ml.d: %.ml\n"; - print "\t$(CAMLBIN)ocamldep -slash $(ZFLAGS) $(PP) \"$<\" > \"$@\"\n\n" + print "\t$(CAMLBIN)ocamldep -slash $(COQSRCLIBS) $(PP) \"$<\" > \"$@\"\n\n" and v_rule () = print "%.vo %.glob: %.v\n\t$(COQC) -dump-glob $*.glob $(COQDEBUG) $(COQFLAGS) $*\n\n"; print "%.vi: %.v\n\t$(COQC) -i $(COQDEBUG) $(COQFLAGS) $*\n\n"; @@ -149,34 +264,10 @@ let implicit () = if !some_mlfile then ml_rules (); if !some_vfile then v_rule () -let variables l = - let rec var_aux = function - | [] -> () - | Def(v,def) :: r -> print v; print "="; print def; print "\n"; var_aux r - | _ :: r -> var_aux r - in +let variables defs = + let var_aux (v,def) = print v; print "="; print def; print "\n" in section "Variables definitions."; - print "CAMLP4:=$(notdir $(CAMLP4LIB))\n"; - if Coq_config.local then - (print "COQSRC:=$(COQTOP)\n"; - print "COQSRCLIBS:=-I $(COQTOP)/kernel -I $(COQTOP)/lib \\ - -I $(COQTOP)/library -I $(COQTOP)/parsing \\ - -I $(COQTOP)/pretyping -I $(COQTOP)/interp \\ - -I $(COQTOP)/proofs -I $(COQTOP)/tactics \\ - -I $(COQTOP)/toplevel -I $(COQTOP)/contrib/cc \\ - -I $(COQTOP)/contrib/dp -I $(COQTOP)/contrib/extraction \\ - -I $(COQTOP)/contrib/field -I $(COQTOP)/contrib/firstorder \\ - -I $(COQTOP)/contrib/fourier -I $(COQTOP)/contrib/funind \\ - -I $(COQTOP)/contrib/interface -I $(COQTOP)/contrib/jprover \\ - -I $(COQTOP)/contrib/micromega -I $(COQTOP)/contrib/omega \\ - -I $(COQTOP)/contrib/ring -I $(COQTOP)/contrib/romega \\ - -I $(COQTOP)/contrib/rtauto -I $(COQTOP)/contrib/setoid_ring \\ - -I $(COQTOP)/contrib/subtac -I $(COQTOP)/contrib/xml \\ - -I $(CAMLP4LIB)\n") - else - (print "COQSRC:=$(shell $(COQBIN)coqc -where)\n"; - print "COQSRCLIBS:=-I $(COQSRC)\n"); - print "ZFLAGS:=$(OCAMLLIBS) $(COQSRCLIBS)\n"; + print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n"; if !opt = "-byte" then print "override OPT:=-byte\n" else @@ -184,81 +275,62 @@ let variables l = if !impredicative_set = true then print "OTHERFLAGS=-impredicative-set\n"; (* Coq executables and relative variables *) print "COQFLAGS:=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n"; + print "ifdef CAMLBIN\n COQMKTOPFLAGS:=-camlbin $(CAMLBIN) -camlp4bin $(CAMLP4BIN)\nendif\n"; print "COQC:=$(COQBIN)coqc\n"; print "COQDEP:=$(COQBIN)coqdep -c\n"; print "GALLINA:=$(COQBIN)gallina\n"; print "COQDOC:=$(COQBIN)coqdoc\n"; + print "COQMKTOP:=$(COQBIN)coqmktop\n"; (* Caml executables and relative variables *) - printf "CAMLC:=$(CAMLBIN)ocamlc -rectypes -c\n"; - printf "CAMLOPTC:=$(CAMLBIN)ocamlopt -rectypes -c\n"; - printf "CAMLLINK:=$(CAMLBIN)ocamlc -rectypes\n"; - printf "CAMLOPTLINK:=$(CAMLBIN)ocamlopt -rectypes\n"; + printf "CAMLC:=$(CAMLBIN)%s -rectypes\n" best_ocamlc; + printf "CAMLOPTC:=$(CAMLBIN)%s -rectypes\n" best_ocamlopt; + printf "CAMLLINK:=$(CAMLBIN)%s -rectypes\n" best_ocamlc; + printf "CAMLOPTLINK:=$(CAMLBIN)%s -rectypes\n" best_ocamlopt; print "GRAMMARS:=grammar.cma\n"; print "CAMLP4EXTEND:=pa_extend.cmo pa_macro.cmo q_MLast.cmo\n"; - - (if Coq_config.local then - print "PP:=-pp \"$(CAMLBIN)$(CAMLP4)o -I . -I $(COQTOP)/parsing $(CAMLP4EXTEND) $(GRAMMARS) -impl\"\n" - else - print "PP:=-pp \"$(CAMLBIN)$(CAMLP4)o -I . -I $(COQSRC) $(CAMLP4EXTEND) $(GRAMMARS) -impl\"\n"); - var_aux l; + print "CAMLP4OPTIONS:=\n"; + List.iter var_aux defs; + print "PP:=-pp \"$(CAMLP4BIN)$(CAMLP4)o -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl\"\n"; print "\n" -let absolute_dir dir = - let current = Sys.getcwd () in - Sys.chdir dir; - let dir' = Sys.getcwd () in - Sys.chdir current; - dir' - -let is_prefix dir1 dir2 = - let l1 = String.length dir1 in - let l2 = String.length dir2 in - dir1 = dir2 or (l1 < l2 & String.sub dir2 0 l1 = dir1 & dir2.[l1] = '/') +let parameters () = + print "# \n"; + print "# This Makefile may take 3 arguments passed as environment variables:\n"; + print "# - COQBIN to specify the directory where Coq binaries resides;\n"; + print "# - CAMLBIN and CAMLP4BIN to give the path for the OCaml and Camlp4/5 binaries.\n"; + print "COQLIB:=$(shell $(COQBIN)coqtop -where | sed -e 's/\\\\/\\\\\\\\/g')\n"; + print "CAMLP4:=\"$(shell $(COQBIN)coqtop -config | awk -F = '/CAMLP4=/{print $$2}')\"\n"; + print "ifndef CAMLP4BIN\n CAMLP4BIN:=$(CAMLBIN)\nendif\n\n"; + print "CAMLP4LIB:=$(shell $(CAMLP4BIN)$(CAMLP4) -where)\n\n" -let is_included dir = function - | RInclude (dir',_) -> is_prefix (absolute_dir dir') (absolute_dir dir) - | Include dir' -> absolute_dir dir = absolute_dir dir' - | _ -> false - -let dir_of_target t = - match t with - | RInclude (dir,_) -> dir - | Include dir -> dir - | _ -> assert false - -let include_dirs l = - let rec split_includes l = - match l with - | [] -> [], [] - | Include _ as i :: rem -> - let ri, rr = split_includes rem in - (i :: ri), rr - | RInclude _ as r :: rem -> - let ri, rr = split_includes rem in - ri, (r :: rr) - | _ :: rem -> split_includes rem - in - let rec parse_includes l = - match l with - | [] -> [] - | Include x :: rem -> ("-I " ^ x) :: parse_includes rem - | RInclude (p,l) :: rem -> - let l' = if l = "" then "\"\"" else l in - ("-R " ^ p ^ " " ^ l') :: parse_includes rem - | _ :: rem -> parse_includes rem - in - let l' = if List.exists (is_included ".") l then l else Include "." :: l in - let inc_i, inc_r = split_includes l' in - let inc_i' = List.filter (fun i -> not (List.exists (fun i' -> is_included (dir_of_target i) i') inc_r)) inc_i in +let include_dirs (inc_i,inc_r) = + let parse_includes l = List.map (fun (x,_) -> "-I " ^ x) l in + let parse_rec_includes l = + List.map (fun (p,l,_) -> + let l' = if l = "" then "\"\"" else l in "-R " ^ p ^ " " ^ l') + l in + let inc_i' = List.filter (fun (i,_) -> not (List.exists (fun (i',_,_) -> is_absolute_prefix i' i) inc_r)) inc_i in let str_i = parse_includes inc_i in let str_i' = parse_includes inc_i' in - let str_r = parse_includes inc_r in - section "Libraries definition."; - print "CAMLP4LIB:=$(shell $(CAMLBIN)camlp5 -where 2> /dev/null || $(CAMLBIN)camlp4 -where)\n"; + let str_r = parse_rec_includes inc_r in + section "Libraries definitions."; print "OCAMLLIBS:=-I $(CAMLP4LIB) "; print_list "\\\n " str_i; print "\n"; + print "COQSRCLIBS:=-I $(COQLIB)/kernel -I $(COQLIB)/lib \\ + -I $(COQLIB)/library -I $(COQLIB)/parsing \\ + -I $(COQLIB)/pretyping -I $(COQLIB)/interp \\ + -I $(COQLIB)/proofs -I $(COQLIB)/tactics \\ + -I $(COQLIB)/toplevel -I $(COQLIB)/contrib/cc -I $(COQLIB)/contrib/dp \\ + -I $(COQLIB)/contrib/extraction -I $(COQLIB)/contrib/field \\ + -I $(COQLIB)/contrib/firstorder -I $(COQLIB)/contrib/fourier \\ + -I $(COQLIB)/contrib/funind -I $(COQLIB)/contrib/interface \\ + -I $(COQLIB)/contrib/micromega -I $(COQLIB)/contrib/omega \\ + -I $(COQLIB)/contrib/ring -I $(COQLIB)/contrib/romega \\ + -I $(COQLIB)/contrib/rtauto -I $(COQLIB)/contrib/setoid_ring \\ + -I $(COQLIB)/contrib/subtac -I $(COQLIB)/contrib/xml\n"; print "COQLIBS:="; print_list "\\\n " str_i'; print " "; print_list "\\\n " str_r; print "\n"; print "COQDOCLIBS:="; print_list "\\\n " str_r; print "\n\n" + let rec special = function | [] -> [] | Special (file,deps,com) :: r -> (file,deps,com) :: (special r) @@ -272,15 +344,10 @@ let custom sps = if sps <> [] then section "Custom targets."; List.iter pr_sp sps -let subdirs l = - let rec subdirs_aux = function - | [] -> [] - | Subdir x :: r -> x :: (subdirs_aux r) - | _ :: r -> subdirs_aux r - and pr_subdir s = +let subdirs sds = + let pr_subdir s = print s; print ":\n\tcd "; print s; print " ; $(MAKE) all\n\n" in - let sds = subdirs_aux l in if sds <> [] then section "Subdirectories."; List.iter pr_subdir sds; section "Special targets."; @@ -288,30 +355,31 @@ let subdirs l = print_list " " ("all" :: "opt" :: "byte" :: "archclean" :: "clean" :: "install" :: "depend" :: "html" :: sds); - print "\n\n"; - sds - - -let all_target l = - let rec parse_arguments l = - match l with - | ML n :: r -> let v,m,o = parse_arguments r in (v,n::m,o) - | Subdir n :: r -> let v,m,o = parse_arguments r in (v,m,n::o) - | V n :: r -> let v,m,o = parse_arguments r in (n::v,m,o) - | Special (n,_,_) :: r -> let v,m,o = parse_arguments r in (v,m,n::o) - | Include _ :: r -> parse_arguments r - | RInclude _ :: r -> parse_arguments r - | Def _ :: r -> parse_arguments r - | [] -> [],[],[] - in - let - vfiles, mlfiles, other_targets = parse_arguments l - in - section "Definition of the \"all\" target."; + print "\n\n" + +let rec split_arguments = function + | V n :: r -> + let (v,m,o,s),i,d = split_arguments r in ((canonize n::v,m,o,s),i,d) + | ML n :: r -> + let (v,m,o,s),i,d = split_arguments r in ((v,canonize n::m,o,s),i,d) + | Special (n,dep,c) :: r -> + let (v,m,o,s),i,d = split_arguments r in ((v,m,(n,dep,c)::o,s),i,d) + | Subdir n :: r -> + let (v,m,o,s),i,d = split_arguments r in ((v,m,o,n::s),i,d) + | Include p :: r -> + let t,(i,r),d = split_arguments r in (t,((p,absolute_dir p)::i,r),d) + | RInclude (p,l) :: r -> + let t,(i,r),d = split_arguments r in (t,(i,(p,l,absolute_dir p)::r),d) + | Def (v,def) :: r -> + let t,i,d = split_arguments r in (t,i,(v,def)::d) + | [] -> ([],[],[],[]),([],[]),[] + +let main_targets vfiles mlfiles other_targets inc = if !some_vfile then begin print "VFILES:="; print_list "\\\n " vfiles; print "\n"; print "VOFILES:=$(VFILES:.v=.vo)\n"; + classify_files_by_root "VOFILES" vfiles inc; print "GLOBFILES:=$(VFILES:.v=.glob)\n"; print "VIFILES:=$(VFILES:.v=.vi)\n"; print "GFILES:=$(VFILES:.v=.g)\n"; @@ -322,10 +390,18 @@ let all_target l = begin print "MLFILES:="; print_list "\\\n " mlfiles; print "\n"; print "CMOFILES:=$(MLFILES:.ml=.cmo)\n"; + classify_files_by_root "CMOFILES" mlfiles inc; + print "CMIFILES:=$(MLFILES:.ml=.cmi)\n"; + classify_files_by_root "CMIFILES" mlfiles inc; + print "CMXFILES:=$(MLFILES:.ml=.cmx)\n"; + print "CMXSFILES:=$(MLFILES:.ml=.cmxs)\n"; + classify_files_by_root "CMXSFILES" mlfiles inc; + print "OFILES:=$(MLFILES:.ml=.o)\n"; end; print "\nall: "; if !some_vfile then print "$(VOFILES) "; if !some_mlfile then print "$(CMOFILES) "; + if Coq_config.has_natdynlink && !some_mlfile then print "$(CMXSFILES) "; print_list "\\\n " other_targets; print "\n"; if !some_vfile then begin @@ -341,8 +417,20 @@ let all_target l = print "\t$(COQDOC) -toc -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n"; print "all-gal.ps: $(VFILES)\n"; print "\t$(COQDOC) -toc -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n"; + print "all.pdf: $(VFILES)\n"; + print "\t$(COQDOC) -toc -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n"; + print "all-gal.pdf: $(VFILES)\n"; + print "\t$(COQDOC) -toc -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n"; print "\n\n" end + +let all_target (vfiles, mlfiles, sps, sds) inc = + let special_targets = List.filter (fun (n,_,_) -> not (is_genrule n)) sps in + let other_targets = List.map (fun x,_,_ -> x) special_targets @ sds in + section "Definition of the \"all\" target."; + main_targets vfiles mlfiles other_targets inc; + custom sps; + subdirs sds let parse f = let rec string = parser @@ -379,14 +467,14 @@ let rec process_cmd_line = function opt := "-opt"; process_cmd_line r | "-impredicative-set" :: r -> impredicative_set := true; process_cmd_line r + | "-no-install" :: r -> + no_install := true; process_cmd_line r | "-custom" :: com :: dependencies :: file :: r -> let check_dep f = if Filename.check_suffix f ".v" then some_vfile := true - else if Filename.check_suffix f ".ml" then + else if (Filename.check_suffix f ".ml") || (Filename.check_suffix f ".ml4") then some_mlfile := true - else - () in List.iter check_dep (Str.split (Str.regexp "[ \t]+") dependencies); Special (file,dependencies,com) :: (process_cmd_line r) @@ -411,11 +499,14 @@ let rec process_cmd_line = function if Filename.check_suffix f ".v" then begin some_vfile := true; V f :: (process_cmd_line r) - end else if Filename.check_suffix f ".ml" then begin - some_mlfile := true; - ML f :: (process_cmd_line r) - end else - Subdir f :: (process_cmd_line r) + end else if (Filename.check_suffix f ".ml") || (Filename.check_suffix f ".ml4") then begin + some_mlfile := true; + ML f :: (process_cmd_line r) + end else if (Filename.check_suffix f ".mli") then begin + Printf.eprintf "Warning: no need for .mli files, skipped %s\n" f; + process_cmd_line r + end else + Subdir f :: (process_cmd_line r) let banner () = print @@ -462,24 +553,61 @@ let directories_deps l = in iter ([],[]) l +let ensure_root_dir l = + if List.exists (is_included ".") l or not (List.exists has_top_file l) then + l + else + Include "." :: l + +let warn_install_at_root_directory (vfiles,mlfiles,_,_) (inc_i,inc_r) = + let inc_r_top = List.filter (fun (_,ldir,_) -> ldir = "") inc_r in + let inc_top = List.map (fun (p,_,a) -> (p,a)) inc_r_top @ inc_i in + let files = vfiles @ mlfiles in + if not !no_install && + List.exists (fun f -> List.mem_assoc (Filename.dirname f) inc_top) files + then + Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R %sis recommended\n" + (if inc_r_top = [] then "" else "with non trivial logical root ") + +let check_overlapping_include (inc_i,inc_r) = + let pwd = Sys.getcwd () in + let rec aux = function + | [] -> () + | (pdir,_,abspdir)::l -> + if not (is_prefix pwd abspdir) then + Printf.eprintf "Warning: in option -R, %s is not a subdirectoty of the current directory\n" pdir; + List.iter (fun (pdir',_,abspdir') -> + if is_prefix abspdir abspdir' or is_prefix abspdir' abspdir then + Printf.eprintf "Warning: in options -R, %s and %s overlap\n" pdir pdir') l; + List.iter (fun (pdir',abspdir') -> + if is_prefix abspdir abspdir' or is_prefix abspdir' abspdir then + Printf.eprintf "Warning: in option -I, %s overlap with %s in option -R\n" pdir' pdir) inc_i + in aux inc_r + let do_makefile args = let l = process_cmd_line args in - banner (); - warning (); - command_line args; - include_dirs l; - variables l; - all_target l; - let sps = special l in - custom sps; - let sds = subdirs l in - implicit (); - standard sds sps; - (* TEST directories_deps l; *) - includes (); - warning (); - if not (!output_channel == stdout) then close_out !output_channel; - exit 0 + let l = ensure_root_dir l in + let (_,_,sps,sds as targets), inc, defs = split_arguments l in + warn_install_at_root_directory targets inc; + check_overlapping_include inc; + banner (); + header_includes (); + warning (); + command_line args; + parameters (); + include_dirs inc; + variables defs; + all_target targets inc; + implicit (); + standard (); + if not !no_install then install targets inc; + clean sds sps; + make_makefile sds; + (* TEST directories_deps l; *) + footer_includes (); + warning (); + if not (!output_channel == stdout) then close_out !output_channel; + exit 0 let main () = let args = @@ -489,4 +617,3 @@ let main () = do_makefile args let _ = Printexc.catch main () - diff --git a/tools/coqdep.ml b/tools/coqdep.ml index b4b161f5..4febe9d1 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coqdep.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: coqdep.ml 11749 2009-01-05 14:01:04Z notin $ *) open Printf open Coqdep_lexer @@ -15,8 +15,6 @@ open Unix let stderr = Pervasives.stderr let stdout = Pervasives.stdout -let coqlib = ref Coq_config.coqlib - let option_c = ref false let option_D = ref false let option_w = ref false @@ -24,7 +22,6 @@ let option_i = ref false let option_sort = ref false let option_glob = ref false let option_slash = ref false -let option_boot = ref false let suffixe = ref ".vo" let suffixe_spec = ref ".vi" @@ -245,7 +242,11 @@ let traite_fichier_Coq verbose f = addQueue deja_vu_ml s; try let mldir = Hashtbl.find mlKnown s in - printf " %s.cmo" (file_name ([String.uncapitalize s],mldir)) + let filename = file_name ([String.uncapitalize s],mldir) in + if Coq_config.has_natdynlink then + printf " %s.cmo %s.cmxs" filename filename + else + printf " %s.cmo" filename with Not_found -> () end) sl @@ -501,14 +502,14 @@ let rec parse = function | "-D" :: ll -> option_D := true; parse ll | "-w" :: ll -> option_w := true; parse ll | "-i" :: ll -> option_i := true; parse ll - | "-boot" :: ll -> option_boot := true; parse ll + | "-boot" :: ll -> Flags.boot := true; parse ll | "-sort" :: ll -> option_sort := true; parse ll | "-glob" :: ll -> option_glob := true; parse ll | "-I" :: r :: ll -> add_dir add_known r []; parse ll | "-I" :: [] -> usage () | "-R" :: r :: ln :: ll -> add_rec_dir add_known r [ln]; parse ll | "-R" :: ([] | [_]) -> usage () - | "-coqlib" :: (r :: ll) -> coqlib := r; parse ll + | "-coqlib" :: (r :: ll) -> Flags.coqlib_spec := true; Flags.coqlib := r; parse ll | "-coqlib" :: [] -> usage () | "-suffix" :: (s :: ll) -> suffixe := s ; suffixe_spec := s; parse ll | "-suffix" :: [] -> usage () @@ -519,13 +520,14 @@ let rec parse = function let coqdep () = if Array.length Sys.argv < 2 then usage (); parse (List.tl (Array.to_list Sys.argv)); - if !option_boot then begin + if !Flags.boot then begin add_rec_dir add_known "theories" ["Coq"]; add_rec_dir add_known "contrib" ["Coq"] - end else begin - add_rec_dir add_coqlib_known (!coqlib//"theories") ["Coq"]; - add_rec_dir add_coqlib_known (!coqlib//"contrib") ["Coq"]; - add_dir add_coqlib_known (!coqlib//"user-contrib") [] + end else begin + let coqlib = Envars.coqlib () in + add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"]; + add_rec_dir add_coqlib_known (coqlib//"contrib") ["Coq"]; + add_dir add_coqlib_known (coqlib//"user-contrib") [] end; List.iter (fun (f,_,d) -> Hashtbl.add mliKnown f d) !mliAccu; List.iter (fun (f,_,d) -> Hashtbl.add mlKnown f d) !mlAccu; diff --git a/tools/coqdoc/cdglobals.ml b/tools/coqdoc/cdglobals.ml index 3339b1db..5bcbed64 100644 --- a/tools/coqdoc/cdglobals.ml +++ b/tools/coqdoc/cdglobals.ml @@ -10,7 +10,7 @@ (*s Output options *) -type target_language = LaTeX | HTML | TeXmacs +type target_language = LaTeX | HTML | TeXmacs | Raw let target_language = ref HTML @@ -57,6 +57,7 @@ let externals = ref true let coqlib = ref "http://coq.inria.fr/library/" let coqlib_path = ref Coq_config.coqlib let raw_comments = ref false +let interpolate = ref false let charset = ref "iso-8859-1" let inputenc = ref "" diff --git a/tools/coqdoc/coqdoc.css b/tools/coqdoc/coqdoc.css index 65c39b7a..a9a99706 100644 --- a/tools/coqdoc/coqdoc.css +++ b/tools/coqdoc/coqdoc.css @@ -25,7 +25,7 @@ body { padding: 0px 0px; padding: 10px; overflow: hidden; font-size: 100%; - line-height: 80% } + line-height: 100% } #main a.idref:visited {color : #416DFF; text-decoration : none; } #main a.idref:link {color : #416DFF; text-decoration : none; } @@ -43,8 +43,6 @@ body { padding: 0px 0px; #main .section { background-color:#90bdff; font-size : 175% } -#main code { font-family: monospace } - #main .doc { margin: 0px; padding: 10px; font-family: sans-serif; @@ -55,7 +53,13 @@ body { padding: 0px 0px; background-color: #90bdff; border-style: plain} -#main .doc code { font-family: monospace} +.inlinecode { + display: inline; + font-family: monospace } + +.code { + display: block; + font-family: monospace } /* Pied de page */ @@ -66,3 +70,29 @@ body { padding: 0px 0px; #footer a:link { text-decoration: none; color: #888888; } +.id { display: inline; } + +.id[type="constructor"] { + color: rgb(60%,0%,0%); +} + +.id[type="var"] { + color: rgb(40%,0%,40%); +} + +.id[type="definition"] { + color: rgb(0%,40%,0%); +} + +.id[type="lemma"] { + color: rgb(0%,40%,0%); +} + +.id[type="inductive"] { + color: rgb(0%,0%,80%); +} + +.id[type="keyword"] { + color : #cf1d1d; +/* color: black; */ +} diff --git a/tools/coqdoc/coqdoc.sty b/tools/coqdoc/coqdoc.sty index d31314c5..ef4f4119 100644 --- a/tools/coqdoc/coqdoc.sty +++ b/tools/coqdoc/coqdoc.sty @@ -27,6 +27,11 @@ %HEVEA\renewcommand{\medskip}{} %HEVEA\renewcommand{\bigskip}{} + +%HEVEA\newcommand{\lnot}{\coqwkw{not}} +%HEVEA\newcommand{\lor}{\coqwkw{or}} +%HEVEA\newcommand{\land}{\&} + % own name \newcommand{\coqdoc}{\textsf{coqdoc}} @@ -39,7 +44,7 @@ \newcommand{\coqdockw}[1]{\texttt{#1}} % macro for typesetting variable identifiers -\newcommand{\coqdocid}[1]{\textit{#1}} +\newcommand{\coqdocvar}[1]{\textit{#1}} % macro for typesetting constant identifiers \newcommand{\coqdoccst}[1]{\textsf{#1}} @@ -57,52 +62,93 @@ % macro for typesetting constructor identifiers \newcommand{\coqdocconstr}[1]{\textsf{#1}} +% macro for typesetting tactic identifiers +\newcommand{\coqdoctac}[1]{\texttt{#1}} + + +% Environment encompassing code fragments +% !!! CAUTION: This environment may have empty contents +\newenvironment{coqdoccode}{}{} + % newline and indentation %BEGIN LATEX -\newcommand{\coqdoceol}{\setlength\parskip{0pt}\par} -\newcommand{\coqdocindent}[1]{\noindent\kern#1} -%END LATEX -%HEVEA\newcommand{\coqdoceol}{\begin{rawhtml}
\end{rawhtml}} -%HEVEA\newcommand{\coqdocindent}[1]{\hspace{#1}\hspace{#1}} +% Base indentation length +\newlength{\coqdocbaseindent} +\setlength{\coqdocbaseindent}{0em} + +% Beginning of a line without any Coq indentation +\newcommand{\coqdocnoindent}{\noindent\kern\coqdocbaseindent} +% Beginning of a line with a given Coq indentation +\newcommand{\coqdocindent}[1]{\noindent\kern\coqdocbaseindent\noindent\kern#1} +% End-of-the-line +\newcommand{\coqdoceol}{\hspace*{\fill}\setlength\parskip{0pt}\par} +% Empty lines (in code only) +\newcommand{\coqdocemptyline}{\vskip 0.4em plus 0.1em minus 0.1em} % macro for typesetting the title of a module implementation \newcommand{\coqdocmodule}[1]{\chapter{Module #1}\markboth{Module #1}{} } \usepackage{ifpdf} \ifpdf - \usepackage[pdftex]{hyperref} + \RequirePackage{hyperref} \hypersetup{raiselinks=true,colorlinks=true,linkcolor=black} - \usepackage[all]{hypcap} + + % To do indexing, use something like: + % \usepackage{multind} + % \newcommand{\coqdef}[3]{\hypertarget{coq:#1}{\index{coq}{#1@#2|hyperpage}#3}} \newcommand{\coqdef}[3]{\phantomsection\hypertarget{coq:#1}{#3}} \newcommand{\coqref}[2]{\hyperlink{coq:#1}{#2}} \newcommand{\identref}[2]{\hyperlink{coq:#1}{\textsf {#2}}} \newcommand{\coqlibrary}[2]{\cleardoublepage\phantomsection - \hypertarget{coq:#1}{\chapter{Library \coqdoccst{#2}}}} + \hypertarget{coq:#1}{\chapter{Library \texorpdfstring{\coqdoccst}{}{#2}}}} \else \newcommand{\coqdef}[3]{#3} \newcommand{\coqref}[2]{#2} - \newcommand{\identref}[2]{\textsf {#2}} + \newcommand{\texorpdfstring}[2]{#1} + \newcommand{\identref}[2]{\textsf{#2}} \newcommand{\coqlibrary}[2]{\cleardoublepage\chapter{Library \coqdoccst{#2}}} \fi \usepackage{xr} -%\usepackage{color} -%\usepackage{multind} -%\newcommand{\coqdef}[3]{\hypertarget{coq:#1}{\index{coq}{#1@#2|hyperpage}#3}} - - - -\newcommand{\coqdocvar}[1]{{\textit{#1}}} -\newcommand{\coqdoctac}[1]{{\texttt{#1}}} - +\newif\if@coqdoccolors + \@coqdoccolorsfalse + +\DeclareOption{color}{\@coqdoccolorstrue} +\ProcessOptions + +\if@coqdoccolors +\RequirePackage{xcolor} +\definecolor{varpurple}{rgb}{0.4,0,0.4} +\definecolor{constrmaroon}{rgb}{0.6,0,0} +\definecolor{defgreen}{rgb}{0,0.4,0} +\definecolor{indblue}{rgb}{0,0,0.8} +\definecolor{kwred}{rgb}{0.8,0.1,0.1} + +\def\coqdocvarcolor{varpurple} +\def\coqdockwcolor{kwred} +\def\coqdoccstcolor{defgreen} +\def\coqdocindcolor{indblue} +\def\coqdocconstrcolor{constrmaroon} +\def\coqdocmodcolor{defgreen} +\def\coqdocaxcolor{varpurple} +\def\coqdoctaccolor{black} + +\def\coqdockw#1{{\color{\coqdockwcolor}{\texttt{#1}}}} +\def\coqdocvar#1{{\color{\coqdocvarcolor}{\textit{#1}}}} +\def\coqdoccst#1{{\color{\coqdoccstcolor}{\textrm{#1}}}} +\def\coqdocind#1{{\color{\coqdocindcolor}{\textsf{#1}}}} +\def\coqdocconstr#1{{\color{\coqdocconstrcolor}{\textsf{#1}}}} +\def\coqdocmod#1{{{\color{\coqdocmodcolor}{\textsc{\textsf{#1}}}}}} +\def\coqdocax#1{{{\color{\coqdocaxcolor}{\textsl{\textrm{#1}}}}}} +\def\coqdoctac#1{{\color{\coqdoctaccolor}{\texttt{#1}}}} +\fi \newcommand{\coqdefinition}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}} \newcommand{\coqdefinitionref}[2]{\coqref{#1}{\coqdoccst{#2}}} -%\newcommand{\coqvariable}[2]{\coqdef{#1}{#2}{\coqdocid{#2}}} -%\newcommand{\coqaxiom}[2]{\coqdef{#1}{#2}{\coqdocid{#2}}} -\newcommand{\coqvariable}[2]{\coqdocid{#2}} +\newcommand{\coqvariable}[2]{\coqdocvar{#2}} +\newcommand{\coqvariableref}[2]{\coqref{#1}{\coqdocvar{#2}}} \newcommand{\coqinductive}[2]{\coqdef{#1}{#2}{\coqdocind{#2}}} \newcommand{\coqinductiveref}[2]{\coqref{#1}{\coqdocind{#2}}} @@ -133,8 +179,8 @@ \newcommand{\coqnotationref}[2]{\coqref{#1}{\coqdockw{#2}}} -\newcommand{\coqsection}[2]{\coqdef{#1}{#2}{\coqdoccst{#2}}} -\newcommand{\coqsectionref}[2]{\coqref{#1}{\coqdoccst{#2}}} +\newcommand{\coqsection}[2]{\coqdef{sec:#1}{#2}{\coqdoccst{#2}}} +\newcommand{\coqsectionref}[2]{\coqref{sec:#1}{\coqdoccst{#2}}} %\newcommand{\coqlibrary}[2]{\chapter{Library \coqdoccst{#2}}\label{coq:#1}} @@ -145,11 +191,7 @@ \newcommand{\coqaxiom}[2]{\coqdef{#1}{#2}{\coqdocax{#2}}} \newcommand{\coqaxiomref}[2]{\coqref{#1}{\coqdocax{#2}}} -\newcommand{\coqmodule}[2]{\coqdef{#1}{#2}{\coqdocmod{#2}}} -\newcommand{\coqmoduleref}[2]{\coqref{#1}{\coqdocmod{#2}}} - - -%HEVEA\newcommand{\lnot}{\coqwkw{not}} -%HEVEA\newcommand{\lor}{\coqwkw{or}} -%HEVEA\newcommand{\land}{\&} +\newcommand{\coqmodule}[2]{\coqdef{mod:#1}{#2}{\coqdocmod{#2}}} +\newcommand{\coqmoduleref}[2]{\coqref{mod:#1}{\coqdocmod{#2}}} +\endinput diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli index 1da8ebd7..56a3cd11 100644 --- a/tools/coqdoc/index.mli +++ b/tools/coqdoc/index.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: index.mli 11065 2008-06-06 22:39:43Z msozeau $ i*) +(*i $Id: index.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) open Cdglobals @@ -40,6 +40,8 @@ type index_entry = val find : coq_module -> loc -> index_entry +val find_string : coq_module -> string -> index_entry + val add_module : coq_module -> unit type module_kind = Local | Coqlib | Unknown diff --git a/tools/coqdoc/index.mll b/tools/coqdoc/index.mll index fc2090dc..f8adb52b 100644 --- a/tools/coqdoc/index.mll +++ b/tools/coqdoc/index.mll @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: index.mll 11065 2008-06-06 22:39:43Z msozeau $ i*) +(*i $Id: index.mll 11790 2009-01-15 20:19:58Z msozeau $ i*) { @@ -47,9 +47,14 @@ let current_type = ref Library let current_library = ref "" (** refers to the file being parsed *) -let table = Hashtbl.create 97 - (** [table] is used to store references and definitions *) +(** [deftable] stores only definitions and is used to interpolate idents + inside comments, which are not globalized otherwise. *) +let deftable = Hashtbl.create 97 + +(** [reftable] stores references and definitions *) +let reftable = Hashtbl.create 97 + let full_ident sp id = if sp <> "<>" then if id <> "<>" then @@ -60,15 +65,24 @@ let full_ident sp id = else "" let add_def loc ty sp id = - Hashtbl.add table (!current_library, loc) (Def (full_ident sp id, ty)) - + Hashtbl.add reftable (!current_library, loc) (Def (full_ident sp id, ty)); + Hashtbl.add deftable id (Ref (!current_library, full_ident sp id, ty)) + let add_ref m loc m' sp id ty = - Hashtbl.add table (m, loc) (Ref (m', full_ident sp id, ty)) + if Hashtbl.mem reftable (m, loc) then () + else Hashtbl.add reftable (m, loc) (Ref (m', full_ident sp id, ty)); + let idx = if id = "<>" then m' else id in + if Hashtbl.mem deftable idx then () + else Hashtbl.add deftable idx (Ref (m', full_ident sp id, ty)) -let add_mod m loc m' id = Hashtbl.add table (m, loc) (Mod (m', id)) - -let find m l = Hashtbl.find table (m, l) - +let add_mod m loc m' id = + Hashtbl.add reftable (m, loc) (Mod (m', id)); + Hashtbl.add deftable m (Mod (m', id)) + +let find m l = Hashtbl.find reftable (m, l) + +let find_string m s = Hashtbl.find deftable s + (*s Manipulating path prefixes *) type stack = string list @@ -216,7 +230,7 @@ let all_entries () = | Def (s,t) -> add_g s m t; add_bt t s m | Ref _ | Mod _ -> () in - Hashtbl.iter classify table; + Hashtbl.iter classify reftable; Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules; { idx_name = "global"; idx_entries = sort_entries !gl; @@ -238,7 +252,9 @@ let firstchar = let identchar = ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] -let ident = firstchar identchar* +let id = firstchar identchar* +let pfx_id = (id '.')* +let ident = id | pfx_id id let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" let end_hide = "(*" space* "end" space+ "hide" space* "*)" @@ -406,9 +422,9 @@ and module_refs = parse | ident { let id = lexeme lexbuf in (try - add_mod !current_library (lexeme_start lexbuf) (Hashtbl.find modules id) id - with - Not_found -> () + add_mod !current_library (lexeme_start lexbuf) (Hashtbl.find modules id) id + with + Not_found -> () ); module_refs lexbuf } | eof @@ -418,7 +434,7 @@ and module_refs = parse { let type_of_string = function - | "def" | "coe" | "subclass" | "canonstruc" + | "def" | "coe" | "subclass" | "canonstruc" | "fix" | "cofix" | "ex" | "scheme" -> Definition | "prf" | "thm" -> Lemma | "ind" | "coind" -> Inductive diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 81560259..2e97618b 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: main.ml 11236 2008-07-18 15:58:12Z notin $ i*) +(*i $Id: main.ml 11828 2009-01-22 06:44:11Z notin $ i*) (* Modified by Lionel Elie Mamane on 9 & 10 Mar 2004: * - handling of absolute filenames (function coq_module) @@ -30,6 +30,7 @@ let usage () = prerr_endline " --html produce a HTML document (default)"; prerr_endline " --latex produce a LaTeX document"; prerr_endline " --texmacs produce a TeXmacs document"; + prerr_endline " --raw produce a text document"; prerr_endline " --dvi output the DVI"; prerr_endline " --ps output the PostScript"; prerr_endline " --pdf output the Pdf"; @@ -56,12 +57,14 @@ let usage () = prerr_endline " --no-externals no links to Coq standard library"; prerr_endline " --coqlib set URL for Coq standard library"; prerr_endline " (default is http://coq.inria.fr/library/)"; + prerr_endline " --boot run in boot mode"; prerr_endline " --coqlib_path set the path where Coq files are installed"; prerr_endline " -R map physical dir to Coq dir"; prerr_endline " --latin1 set ISO-8859-1 input language"; prerr_endline " --utf8 set UTF-8 input language"; prerr_endline " --charset set HTML charset"; prerr_endline " --inputenc set LaTeX input encoding"; + prerr_endline " --interpolate try to typeset identifiers in comments using definitions in the same module"; prerr_endline ""; exit 1 @@ -81,6 +84,7 @@ let banner () = let target_full_name f = match !Cdglobals.target_language with | HTML -> f ^ ".html" + | Raw -> f ^ ".txt" | _ -> f ^ ".tex" (*s \textbf{Separation of files.} Files given on the command line are @@ -257,6 +261,8 @@ let parse () = Cdglobals.target_language := HTML; parse_rec rem | ("-texmacs" | "--texmacs") :: rem -> Cdglobals.target_language := TeXmacs; parse_rec rem + | ("-raw" | "--raw") :: rem -> + Cdglobals.target_language := Raw; parse_rec rem | ("-charset" | "--charset") :: s :: rem -> Cdglobals.charset := s; parse_rec rem | ("-charset" | "--charset") :: [] -> @@ -267,6 +273,9 @@ let parse () = usage () | ("-raw-comments" | "--raw-comments") :: rem -> Cdglobals.raw_comments := true; parse_rec rem + | ("-interpolate" | "--interpolate") :: rem -> + Cdglobals.interpolate := true; parse_rec rem + | ("-latin1" | "--latin1") :: rem -> Cdglobals.set_latin1 (); parse_rec rem | ("-utf8" | "--utf8") :: rem -> @@ -310,6 +319,8 @@ let parse () = Cdglobals.coqlib := u; parse_rec rem | ("--coqlib" | "-coqlib") :: [] -> usage () + | ("--boot" | "-boot") :: rem -> + Cdglobals.coqlib_path := Coq_config.coqsrc; parse_rec rem | ("--coqlib_path" | "-coqlib_path") :: d :: rem -> Cdglobals.coqlib_path := d; parse_rec rem | ("--coqlib_path" | "-coqlib_path") :: [] -> @@ -318,6 +329,7 @@ let parse () = add_file (what_file f); parse_rec rem in parse_rec (List.tl (Array.to_list Sys.argv)); + Output.initialize (); List.rev !files @@ -414,10 +426,10 @@ let read_glob x = match x with | Vernac_file (f,m) -> let glob = (Filename.chop_extension f) ^ ".glob" in - (try + (try Vernac_file (f, Index.read_glob glob) - with _ -> - eprintf "Warning: file %s cannot be opened; links will not be available\n" glob; + with e -> + eprintf "Warning: file %s cannot be used; links will not be available: %s\n" glob (Printexc.to_string e); x) | Latex_file _ -> x @@ -430,13 +442,13 @@ let produce_document l = (if !target_language=HTML then let src = (Filename.concat !Cdglobals.coqlib_path "/tools/coqdoc/coqdoc.css") in let dst = if !output_dir <> "" then Filename.concat !output_dir "coqdoc.css" else "coqdoc.css" in - copy src dst); + if (Sys.file_exists src) then (copy src dst) else eprintf "Warning: file %s does not exist\n" src); (if !target_language=LaTeX then let src = (Filename.concat !Cdglobals.coqlib_path "/tools/coqdoc/coqdoc.sty") in let dst = if !output_dir <> "" then Filename.concat !output_dir "coqdoc.sty" else "coqdoc.sty" in - copy src dst); + if Sys.file_exists src then copy src dst else eprintf "Warning: file %s does not exist\n" src); (match !Cdglobals.glob_source with | NoGlob -> () | DotGlob -> ignore (List.map read_glob l) diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 93414f22..c146150c 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: output.ml 11154 2008-06-19 18:42:19Z msozeau $ i*) +(*i $Id: output.ml 11823 2009-01-21 15:32:37Z msozeau $ i*) open Cdglobals open Index @@ -32,43 +32,48 @@ let build_table l = let is_keyword = build_table - [ "AddPath"; "Axiom"; "Chapter"; "Check"; "CoFixpoint"; - "CoInductive"; "Defined"; "Definition"; "End"; "Eval"; "Example"; + [ "AddPath"; "Axiom"; "Abort"; "Boxed"; "Chapter"; "Check"; "Coercion"; "CoFixpoint"; + "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example"; "Export"; "Fact"; "Fix"; "Fixpoint"; "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"; "Qed"; + "Mutual"; "Parameter"; "Parameters"; "Print"; "Proof"; "Proof with"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; - "Set"; "Unset"; "Variable"; "Variables"; "Context"; + "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context"; "Notation"; "Reserved Notation"; "Tactic Notation"; "Delimit"; "Bind"; "Open"; "Scope"; "Boxed"; "Unboxed"; "Inline"; - "Arguments"; "Add"; "Strict"; - "Typeclasses"; "Instance"; "Class"; "Instantiation"; + "Implicit Arguments"; "Add"; "Strict"; + "Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation"; + "subgoal"; (* Program *) "Program Definition"; "Program Example"; "Program Fixpoint"; "Program Lemma"; "Obligation"; "Obligations"; "Solve"; "using"; "Next Obligation"; "Next"; - "Program Instance"; + "Program Instance"; "Equations"; "Equations_nocomp"; (*i (* coq terms *) *) - "match"; "as"; "in"; "return"; "with"; "end"; "let"; "dest"; "fun"; - "if"; "then"; "else"; "Prop"; "Set"; "Type"; ":="; "where" + "forall"; "match"; "as"; "in"; "return"; "with"; "end"; "let"; "dest"; "fun"; + "if"; "then"; "else"; "Prop"; "Set"; "Type"; ":="; "where"; "struct"; "wf"; "measure"; + (* Ltac *) + "before"; "after" ] let is_tactic = build_table - [ "intro"; "intros"; "apply"; "rewrite"; "setoid_rewrite"; - "destruct"; "induction"; "elim"; "dependent"; - "generalize"; "clear"; "rename"; "move"; "set"; "assert"; - "cut"; "assumption"; "exact"; "split"; "try"; "discriminate"; + [ "intro"; "intros"; "apply"; "rewrite"; "refine"; "case"; "clear"; "injection"; + "elimtype"; "progress"; "setoid_rewrite"; + "destruct"; "destruction"; "destruct_call"; "dependent"; "elim"; "extensionality"; + "f_equal"; "generalize"; "generalize_eqs"; "generalize_eqs_vars"; "induction"; "rename"; "move"; "omega"; + "set"; "assert"; "do"; "repeat"; + "cut"; "assumption"; "exact"; "split"; "subst"; "try"; "discriminate"; "simpl"; "unfold"; "red"; "compute"; "at"; "in"; "by"; "reflexivity"; "symmetry"; "transitivity"; "replace"; "setoid_replace"; "inversion"; "inversion_clear"; - "pattern"; "intuition"; "congruence"; + "pattern"; "intuition"; "congruence"; "fail"; "fresh"; "trivial"; "exact"; "tauto"; "firstorder"; "ring"; - "clapply"; "program_simpl"; "eapply"; "auto"; "eauto" ] + "clapply"; "program_simpl"; "program_simplify"; "eapply"; "auto"; "eauto" ] (*s Current Coq module *) @@ -92,27 +97,31 @@ let find_printing_token tok = let remove_printing_token = Hashtbl.remove token_pp (* predefined pretty-prints *) -let _ = List.iter - (fun (s,l) -> Hashtbl.add token_pp s (Some l, None)) - [ "*" , "\\ensuremath{\\times}"; - "|", "\\ensuremath{|}"; - "->", "\\ensuremath{\\rightarrow}"; - "->~", "\\ensuremath{\\rightarrow\\lnot}"; - "->~~", "\\ensuremath{\\rightarrow\\lnot\\lnot}"; - "<-", "\\ensuremath{\\leftarrow}"; - "<->", "\\ensuremath{\\leftrightarrow}"; - "=>", "\\ensuremath{\\Rightarrow}"; - "<=", "\\ensuremath{\\le}"; - ">=", "\\ensuremath{\\ge}"; - "<>", "\\ensuremath{\\not=}"; - "~", "\\ensuremath{\\lnot}"; - "/\\", "\\ensuremath{\\land}"; - "\\/", "\\ensuremath{\\lor}"; - "|-", "\\ensuremath{\\vdash}"; - "forall", "\\ensuremath{\\forall}"; - "exists", "\\ensuremath{\\exists}"; - (* "fun", "\\ensuremath{\\lambda}" ? *) - ] +let initialize () = + let if_utf8 = if !Cdglobals.utf8 then fun x -> Some x else fun _ -> None in + List.iter + (fun (s,l,l') -> Hashtbl.add token_pp s (Some l, l')) + [ "*" , "\\ensuremath{\\times}", if_utf8 "×"; + "|", "\\ensuremath{|}", None; + "->", "\\ensuremath{\\rightarrow}", if_utf8 "→"; + "->~", "\\ensuremath{\\rightarrow\\lnot}", None; + "->~~", "\\ensuremath{\\rightarrow\\lnot\\lnot}", None; + "<-", "\\ensuremath{\\leftarrow}", None; + "<->", "\\ensuremath{\\leftrightarrow}", if_utf8 "↔"; + "=>", "\\ensuremath{\\Rightarrow}", if_utf8 "⇒"; + "<=", "\\ensuremath{\\le}", if_utf8 "≤"; + ">=", "\\ensuremath{\\ge}", if_utf8 "≥"; + "<>", "\\ensuremath{\\not=}", if_utf8 "≠"; + "~", "\\ensuremath{\\lnot}", if_utf8 "¬"; + "/\\", "\\ensuremath{\\land}", if_utf8 "∧"; + "\\/", "\\ensuremath{\\lor}", if_utf8 "∨"; + "|-", "\\ensuremath{\\vdash}", None; + "forall", "\\ensuremath{\\forall}", if_utf8 "∀"; + "exists", "\\ensuremath{\\exists}", if_utf8 "∃"; + "Π", "\\ensuremath{\\Pi}", if_utf8 "Π"; + "λ", "\\ensuremath{\\lambda}", if_utf8 "λ" + (* "fun", "\\ensuremath{\\lambda}" ? *) + ] (*s Table of contents *) @@ -130,6 +139,9 @@ let new_label = let r = ref 0 in fun () -> incr r; "lab" ^ string_of_int !r module Latex = struct + let in_title = ref false + let in_doc = ref false + (*s Latex preamble *) let (preamble : string Queue.t) = Queue.create () @@ -208,7 +220,7 @@ module Latex = struct let indentation n = if n == 0 then - printf "\\noindent\n" + printf "\\coqdocnoindent\n" else let space = 0.5 *. (float n) in printf "\\coqdocindent{%2.2fem}\n" space @@ -243,35 +255,49 @@ module Latex = struct let _m = Filename.concat !coqlib m in printf "\\coq%sref{" (type_name typ); label_ident id; printf "}{"; raw_ident s; printf "}" | Coqlib | Unknown -> - raw_ident s + printf "\\coq%sref{" (type_name typ); label_ident id; printf "}{"; raw_ident s; printf "}" let defref m id ty s = printf "\\coq%s{" (type_name ty); label_ident (m ^ "." ^ id); printf "}{"; raw_ident s; printf "}" + let reference s = function + | Def (fullid,typ) -> + defref !current_module fullid typ s + | Mod (m,s') when s = s' -> + module_ref m s + | Ref (m,fullid,typ) -> + ident_ref m fullid typ s + | Mod _ -> + printf "\\coqdocvar{"; raw_ident s; printf "}" + let ident s loc = if is_keyword s then begin printf "\\coqdockw{"; raw_ident s; printf "}" end else begin begin try - (match Index.find !current_module loc with - | Def (fullid,typ) -> - defref !current_module fullid typ s - | Mod (m,s') when s = s' -> - module_ref m s - | Ref (m,fullid,typ) -> - ident_ref m fullid typ s - | Mod _ -> - printf "\\coqdocid{"; raw_ident s; printf "}") + reference s (Index.find !current_module loc) with Not_found -> if is_tactic s then begin printf "\\coqdoctac{"; raw_ident s; printf "}" - end else begin printf "\\coqdocvar{"; raw_ident s; printf "}" end + end else begin + if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) + then + try reference s (Index.find_string !current_module s) + with _ -> (printf "\\coqdocvar{"; raw_ident s; printf "}") + else (printf "\\coqdocvar{"; raw_ident s; printf "}") + end end end - let ident s l = with_latex_printing (fun s -> ident s l) s - + let ident s l = + if !in_title then ( + printf "\\texorpdfstring{"; + with_latex_printing (fun s -> ident s l) s; + printf "}{"; raw_ident s; printf "}") + else + with_latex_printing (fun s -> ident s l) s + let symbol = with_latex_printing raw_ident let rec reach_item_level n = @@ -290,13 +316,13 @@ module Latex = struct let stop_item () = reach_item_level 0 - let start_doc () = printf "\n\n\n\\noindent\n" + let start_doc () = in_doc := true - let end_doc () = stop_item (); printf "\n\n\n" + let end_doc () = in_doc := false; stop_item () - let start_coq () = () + let start_coq () = printf "\\begin{coqdoccode}\n" - let end_coq () = () + let end_coq () = printf "\\end{coqdoccode}\n" let start_code () = end_doc (); start_coq () @@ -312,17 +338,17 @@ module Latex = struct let section lev f = stop_item (); output_string (section_kind lev); - f (); + in_title := true; f (); in_title := false; printf "}\n\n" let rule () = printf "\\par\n\\noindent\\hrulefill\\par\n\\noindent{}" - let paragraph () = stop_item (); printf "\n\n\\medskip\n" + let paragraph () = stop_item (); printf "\n\n" let line_break () = printf "\\coqdoceol\n" - let empty_line_of_code () = printf "\n\n\\medskip\n" + let empty_line_of_code () = printf "\\coqdocemptyline\n" let start_inline_coq () = () @@ -394,7 +420,8 @@ module Html = struct let line_break () = printf "
\n" - let empty_line_of_code () = printf "\n
\n" + let empty_line_of_code () = + printf "\n
\n" let char = function | '<' -> printf "<" @@ -417,49 +444,54 @@ module Html = struct let stop_verbatim () = printf "\n" let module_ref m s = - printf "" m; raw_ident s; printf "" - (*i - match find_module m with - | Local -> - printf "" m; raw_ident s; printf "" - | Coqlib when !externals -> - let m = Filename.concat !coqlib m in - printf "" m; raw_ident s; printf "" - | Coqlib | Unknown -> - raw_ident s - i*) - - let ident_ref m fid s = match find_module m with | Local -> - printf "" m fid; raw_ident s; printf "" + printf "" m; raw_ident s; printf "" | Coqlib when !externals -> let m = Filename.concat !coqlib m in - printf "" m fid; raw_ident s; printf "" + printf "" m; raw_ident s; printf "" | Coqlib | Unknown -> raw_ident s + let ident_ref m fid typ s = + match find_module m with + | Local -> + printf "" typ; + printf "" m fid; raw_ident s; + printf "" + | Coqlib when !externals -> + let m = Filename.concat !coqlib m in + printf "" typ; + printf "" m fid; + raw_ident s; printf "" + | Coqlib | Unknown -> + printf "" typ; raw_ident s; printf "" + let ident s loc = if is_keyword s then begin - printf ""; + printf ""; raw_ident s; printf "" end else begin try (match Index.find !current_module loc with - | Def (fullid,_) -> - printf "" fullid; raw_ident s + | Def (fullid,ty) -> + printf "" (type_name ty); + printf "" fullid; raw_ident s; printf "" | Mod (m,s') when s = s' -> module_ref m s | Ref (m,fullid,ty) -> - ident_ref m fullid s + ident_ref m fullid (type_name ty) s | Mod _ -> - raw_ident s) + printf ""; raw_ident s ; printf "") with Not_found -> - raw_ident s + if is_tactic s then + (printf ""; raw_ident s; printf "") + else + (printf ""; raw_ident s ; printf "") end - + let with_html_printing f tok = try (match Hashtbl.find token_pp tok with @@ -488,9 +520,9 @@ module Html = struct let stop_item () = reach_item_level 0 - let start_coq () = if not !raw_comments then printf "\n" + let start_coq () = if not !raw_comments then printf "
\n" - let end_coq () = if not !raw_comments then printf "\n" + let end_coq () = if not !raw_comments then printf "
\n" let start_doc () = if not !raw_comments then @@ -504,9 +536,9 @@ module Html = struct let end_code () = end_coq (); start_doc () - let start_inline_coq () = printf "" + let start_inline_coq () = printf "" - let end_inline_coq () = printf "" + let end_inline_coq () = printf "" let paragraph () = stop_item (); printf "\n

\n" @@ -539,7 +571,7 @@ module Html = struct let all_letters i = List.iter (letter_index false i.idx_name) i.idx_entries (* Construction d'une liste des index (1 index global, puis 1 - index par catégorie) *) + index par catégorie) *) let format_global_index = Index.map (fun s (m,t) -> @@ -578,7 +610,7 @@ module Html = struct printf "\n" let make_one_multi_index prt_tbl i = - (* Attn: make_one_multi_index créé un nouveau fichier... *) + (* Attn: make_one_multi_index créé un nouveau fichier... *) let idx = i.idx_name in let one_letter ((c,l) as cl) = open_out_file (sprintf "index_%s_%c.html" idx c); @@ -776,68 +808,155 @@ module TeXmacs = struct end + +(*s LaTeX output *) + +module Raw = struct + + let header () = () + + let trailer () = () + + let char = output_char + + let label_char c = match c with + | '\\' | '$' | '#' | '%' | '&' | '{' | '}' | '_' + | '^' | '~' -> () + | _ -> + output_char c + + let latex_char = output_char + let latex_string = output_string + + let html_char _ = () + let html_string _ = () + + let raw_ident s = + for i = 0 to String.length s - 1 do char s.[i] done + + let start_module () = () + let end_module () = () + + let start_latex_math () = () + let stop_latex_math () = () + + let start_verbatim () = () + + let stop_verbatim () = () + + let indentation n = + for i = 1 to n do printf " " done + + let ident s loc = raw_ident s + + let symbol = raw_ident + + let item n = printf "- " + + let stop_item () = () + + let start_doc () = printf "(** " + let end_doc () = printf " *)\n" + + let start_coq () = () + let end_coq () = () + + let start_code () = end_doc (); start_coq () + let end_code () = end_coq (); start_doc () + + let section_kind = + function + | 1 -> "*" + | 2 -> "**" + | 3 -> "***" + | 4 -> "****" + | _ -> assert false + + let section lev f = + output_string (section_kind lev); + f () + + let rule () = () + + let paragraph () = printf "\n\n" + + let line_break () = printf "\n" + + let empty_line_of_code () = printf "\n" + + let start_inline_coq () = () + let end_inline_coq () = () + + let make_multi_index () = () + let make_index () = () + let make_toc () = () + +end + + + (*s Generic output *) -let select f1 f2 f3 x = - match !target_language with LaTeX -> f1 x | HTML -> f2 x | TeXmacs -> f3 x +let select f1 f2 f3 f4 x = + match !target_language with LaTeX -> f1 x | HTML -> f2 x | TeXmacs -> f3 x | Raw -> f4 x let push_in_preamble = Latex.push_in_preamble -let header = select Latex.header Html.header TeXmacs.header -let trailer = select Latex.trailer Html.trailer TeXmacs.trailer +let header = select Latex.header Html.header TeXmacs.header Raw.header +let trailer = select Latex.trailer Html.trailer TeXmacs.trailer Raw.trailer let start_module = - select Latex.start_module Html.start_module TeXmacs.start_module + select Latex.start_module Html.start_module TeXmacs.start_module Raw.start_module -let start_doc = select Latex.start_doc Html.start_doc TeXmacs.start_doc -let end_doc = select Latex.end_doc Html.end_doc TeXmacs.end_doc +let start_doc = select Latex.start_doc Html.start_doc TeXmacs.start_doc Raw.start_doc +let end_doc = select Latex.end_doc Html.end_doc TeXmacs.end_doc Raw.end_doc -let start_coq = select Latex.start_coq Html.start_coq TeXmacs.start_coq -let end_coq = select Latex.end_coq Html.end_coq TeXmacs.end_coq +let start_coq = select Latex.start_coq Html.start_coq TeXmacs.start_coq Raw.start_coq +let end_coq = select Latex.end_coq Html.end_coq TeXmacs.end_coq Raw.end_coq -let start_code = select Latex.start_code Html.start_code TeXmacs.start_code -let end_code = select Latex.end_code Html.end_code TeXmacs.end_code +let start_code = select Latex.start_code Html.start_code TeXmacs.start_code Raw.start_code +let end_code = select Latex.end_code Html.end_code TeXmacs.end_code Raw.end_code let start_inline_coq = - select Latex.start_inline_coq Html.start_inline_coq TeXmacs.start_inline_coq + select Latex.start_inline_coq Html.start_inline_coq TeXmacs.start_inline_coq Raw.start_inline_coq let end_inline_coq = - select Latex.end_inline_coq Html.end_inline_coq TeXmacs.end_inline_coq + select Latex.end_inline_coq Html.end_inline_coq TeXmacs.end_inline_coq Raw.end_inline_coq -let indentation = select Latex.indentation Html.indentation TeXmacs.indentation -let paragraph = select Latex.paragraph Html.paragraph TeXmacs.paragraph -let line_break = select Latex.line_break Html.line_break TeXmacs.line_break +let indentation = select Latex.indentation Html.indentation TeXmacs.indentation Raw.indentation +let paragraph = select Latex.paragraph Html.paragraph TeXmacs.paragraph Raw.paragraph +let line_break = select Latex.line_break Html.line_break TeXmacs.line_break Raw.line_break let empty_line_of_code = select - Latex.empty_line_of_code Html.empty_line_of_code TeXmacs.empty_line_of_code + Latex.empty_line_of_code Html.empty_line_of_code TeXmacs.empty_line_of_code Raw.empty_line_of_code -let section = select Latex.section Html.section TeXmacs.section -let item = select Latex.item Html.item TeXmacs.item -let stop_item = select Latex.stop_item Html.stop_item TeXmacs.stop_item -let rule = select Latex.rule Html.rule TeXmacs.rule +let section = select Latex.section Html.section TeXmacs.section Raw.section +let item = select Latex.item Html.item TeXmacs.item Raw.item +let stop_item = select Latex.stop_item Html.stop_item TeXmacs.stop_item Raw.stop_item +let rule = select Latex.rule Html.rule TeXmacs.rule Raw.rule -let char = select Latex.char Html.char TeXmacs.char -let ident = select Latex.ident Html.ident TeXmacs.ident -let symbol = select Latex.symbol Html.symbol TeXmacs.symbol +let char = select Latex.char Html.char TeXmacs.char Raw.char +let ident = select Latex.ident Html.ident TeXmacs.ident Raw.ident +let symbol = select Latex.symbol Html.symbol TeXmacs.symbol Raw.symbol -let latex_char = select Latex.latex_char Html.latex_char TeXmacs.latex_char +let latex_char = select Latex.latex_char Html.latex_char TeXmacs.latex_char Raw.latex_char let latex_string = - select Latex.latex_string Html.latex_string TeXmacs.latex_string -let html_char = select Latex.html_char Html.html_char TeXmacs.html_char + select Latex.latex_string Html.latex_string TeXmacs.latex_string Raw.latex_string +let html_char = select Latex.html_char Html.html_char TeXmacs.html_char Raw.html_char let html_string = - select Latex.html_string Html.html_string TeXmacs.html_string + select Latex.html_string Html.html_string TeXmacs.html_string Raw.html_string let start_latex_math = - select Latex.start_latex_math Html.start_latex_math TeXmacs.start_latex_math + select Latex.start_latex_math Html.start_latex_math TeXmacs.start_latex_math Raw.start_latex_math let stop_latex_math = - select Latex.stop_latex_math Html.stop_latex_math TeXmacs.stop_latex_math + select Latex.stop_latex_math Html.stop_latex_math TeXmacs.stop_latex_math Raw.stop_latex_math let start_verbatim = - select Latex.start_verbatim Html.start_verbatim TeXmacs.start_verbatim + select Latex.start_verbatim Html.start_verbatim TeXmacs.start_verbatim Raw.start_verbatim let stop_verbatim = - select Latex.stop_verbatim Html.stop_verbatim TeXmacs.stop_verbatim + select Latex.stop_verbatim Html.stop_verbatim TeXmacs.stop_verbatim Raw.stop_verbatim let verbatim_char = - select output_char Html.char TeXmacs.char + select output_char Html.char TeXmacs.char Raw.char let hard_verbatim_char = output_char -let make_multi_index = select Latex.make_multi_index Html.make_multi_index TeXmacs.make_multi_index -let make_index = select Latex.make_index Html.make_index TeXmacs.make_index -let make_toc = select Latex.make_toc Html.make_toc TeXmacs.make_toc +let make_multi_index = select Latex.make_multi_index Html.make_multi_index TeXmacs.make_multi_index Raw.make_multi_index +let make_index = select Latex.make_index Html.make_index TeXmacs.make_index Raw.make_index +let make_toc = select Latex.make_toc Html.make_toc TeXmacs.make_toc Raw.make_toc diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli index 87b311f3..3da80335 100644 --- a/tools/coqdoc/output.mli +++ b/tools/coqdoc/output.mli @@ -6,11 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: output.mli 8669 2006-03-28 17:34:15Z notin $ i*) +(*i $Id: output.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) open Cdglobals open Index +val initialize : unit -> unit + val add_printing_token : string -> string option * string option -> unit val remove_printing_token : string -> unit diff --git a/tools/coqdoc/pretty.mll b/tools/coqdoc/pretty.mll index baace5ba..3ae5cbed 100644 --- a/tools/coqdoc/pretty.mll +++ b/tools/coqdoc/pretty.mll @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: pretty.mll 11255 2008-07-24 16:57:13Z notin $ i*) +(*i $Id: pretty.mll 11823 2009-01-21 15:32:37Z msozeau $ i*) (*s Utility functions for the scanners *) @@ -57,6 +57,7 @@ let formatted = ref false let brackets = ref 0 let comment_level = ref 0 + let in_proof = ref false let backtrack lexbuf = lexbuf.lex_curr_pos <- lexbuf.lex_start_pos @@ -173,11 +174,12 @@ let firstchar = ['A'-'Z' 'a'-'z' '_' (* iso 8859-1 accents *) '\192'-'\214' '\216'-'\246' '\248'-'\255' ] | + (* *) '\194' '\185' | (* utf-8 latin 1 supplement *) '\195' ['\128'-'\191'] | (* utf-8 letterlike symbols *) - '\206' ['\177'-'\183'] | + '\206' ('\160' | [ '\177'-'\183'] | '\187') | '\226' ('\130' [ '\128'-'\137' ] (* subscripts *) | '\129' [ '\176'-'\187' ] (* superscripts *) | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143']) @@ -188,17 +190,24 @@ let pfx_id = (id '.')* let identifier = id | pfx_id id -let symbolchar_no_brackets = - ['!' '$' '%' '&' '*' '+' ',' '@' '^' '#' - '\\' '/' '-' '<' '>' '|' ':' '?' '=' '~' - '{' '}' '(' ')'] | +let symbolchar_symbol_no_brackets = + ['!' '$' '%' '&' '*' '+' ',' '^' '#' + '\\' '/' '-' '<' '>' '|' ':' '?' '=' '~' ] | (* utf-8 symbols *) '\226' ['\134'-'\143' '\152'-'\155' '\164'-'\165' '\168'-'\171'] _ +let symbolchar_no_brackets = symbolchar_symbol_no_brackets | + [ '@' '{' '}' '(' ')' 'A'-'Z' 'a'-'z' '_'] let symbolchar = symbolchar_no_brackets | '[' | ']' -let token_no_brackets = symbolchar_no_brackets+ -let token = symbolchar+ | '[' [^ '[' ']' ':']* ']' +let token_no_brackets = symbolchar_symbol_no_brackets symbolchar_no_brackets* +let token = symbolchar_symbol_no_brackets symbolchar* | '[' [^ '[' ']' ':']* ']' let printing_token = (token | id)+ +(* tokens with balanced brackets *) +let token_brackets = + ( token_no_brackets ('[' token_no_brackets? ']')* + | token_no_brackets? ('[' token_no_brackets? ']')+ ) + token_no_brackets? + let thm_token = "Theorem" | "Lemma" @@ -208,22 +217,26 @@ let thm_token = | "Proposition" | "Property" | "Goal" + | "Next" space+ "Obligation" let def_token = "Definition" | "Let" | "Class" - | "SubClass" + | "SubClass" | "Example" | "Local" | "Fixpoint" + | "Boxed" | "CoFixpoint" | "Record" | "Structure" - | "Instance" | "Scheme" | "Inductive" | "CoInductive" + | "Equations" + | "Instance" + | "Global" space+ "Instance" let decl_token = "Hypothesis" @@ -277,6 +290,8 @@ let commands = | ("Hypothesis" | "Hypotheses") | "End" +let end_kw = "Proof" | "Qed" | "Defined" | "Save" | "Admitted" | "Abort" + let extraction = "Extraction" | "Recursive" space+ "Extraction" @@ -291,7 +306,8 @@ let prog_kw = | "Solve" let gallina_kw_to_hide = - "Implicit" + "Implicit" space+ "Arguments" + | "Next" "Obligation" | "Ltac" | "Require" | "Import" @@ -308,12 +324,6 @@ let gallina_kw_to_hide = | "Declare" space+ ("Left" | "Right") space+ "Step" -(* tokens with balanced brackets *) -let token_brackets = - ( symbolchar_no_brackets+ ('[' symbolchar_no_brackets* ']')* - | symbolchar_no_brackets* ('[' symbolchar_no_brackets* ']')+ ) - symbolchar_no_brackets* - let section = "*" | "**" | "***" | "****" let item_space = " " @@ -333,7 +343,7 @@ let end_verb = "(*" space* "end" space+ "verb" space* "*)" rule coq_bol = parse | space* nl+ - { Output.empty_line_of_code (); coq_bol lexbuf } + { if not (!in_proof && !Cdglobals.gallina) then Output.empty_line_of_code (); coq_bol lexbuf } | space* "(**" space_nl { Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in @@ -352,7 +362,7 @@ rule coq_bol = parse { let s = lexeme lexbuf in if !Cdglobals.light && section_or_end s then let eol = skip_to_dot lexbuf in - if eol then (Output.line_break (); coq_bol lexbuf) else coq lexbuf + if eol then (coq_bol lexbuf) else coq lexbuf else begin let nbsp,isp = count_spaces s in @@ -362,8 +372,35 @@ rule coq_bol = parse let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf end } - | space* gallina_kw + | space* thm_token { let s = lexeme lexbuf in + let nbsp,isp = count_spaces s in + let s = String.sub s isp (String.length s - isp) in + Output.indentation nbsp; + Output.ident s (lexeme_start lexbuf + isp); + let eol = body lexbuf in + in_proof := true; + if eol then coq_bol lexbuf else coq lexbuf } + | space* "Proof" (space* "." | space+ "with") + { in_proof := true; + let eol = + if not !Cdglobals.gallina then + begin backtrack lexbuf; body_bol lexbuf end + else true + in if eol then coq_bol lexbuf else coq lexbuf } + | space* end_kw { + let eol = + if not (!in_proof && !Cdglobals.gallina) then + begin backtrack lexbuf; body_bol lexbuf end + else + skip_to_dot lexbuf + in + in_proof := false; + if eol then coq_bol lexbuf else coq lexbuf } + | space* gallina_kw + { + in_proof := false; + let s = lexeme lexbuf in let nbsp,isp = count_spaces s in let s = String.sub s isp (String.length s - isp) in Output.indentation nbsp; @@ -371,7 +408,9 @@ rule coq_bol = parse let eol= body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space* prog_kw - { let s = lexeme lexbuf in + { + in_proof := false; + let s = lexeme lexbuf in let nbsp,isp = count_spaces s in Output.indentation nbsp; let s = String.sub s isp (String.length s - isp) in @@ -409,7 +448,7 @@ rule coq_bol = parse | _ { let eol = if not !Cdglobals.gallina then - begin backtrack lexbuf; Output.indentation 0; body_bol lexbuf end + begin backtrack lexbuf; body_bol lexbuf end else skip_to_dot lexbuf in @@ -419,7 +458,7 @@ rule coq_bol = parse and coq = parse | nl - { Output.line_break(); coq_bol lexbuf } + { if not (!in_proof && !Cdglobals.gallina) then Output.line_break(); coq_bol lexbuf } | "(**" space_nl { Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in @@ -448,6 +487,15 @@ and coq = parse let eol=body lexbuf in if eol then coq_bol lexbuf else coq lexbuf end } + | end_kw { + let eol = + if not (!in_proof && !Cdglobals.gallina) then + begin backtrack lexbuf; body lexbuf end + else + skip_to_dot lexbuf + in + in_proof := false; + if eol then coq_bol lexbuf else coq lexbuf } | gallina_kw { let s = lexeme lexbuf in Output.ident s (lexeme_start lexbuf); @@ -463,7 +511,7 @@ and coq = parse { () } | _ { let eol = if not !Cdglobals.gallina then - begin backtrack lexbuf; Output.indentation 0; body lexbuf end + begin backtrack lexbuf; body lexbuf end else let eol = skip_to_dot lexbuf in if eol then Output.line_break (); eol @@ -496,16 +544,15 @@ and doc_bol = parse and doc = parse | nl { Output.char '\n'; doc_bol lexbuf } - | "[" - { brackets := 1; - Output.start_inline_coq (); escaped_coq lexbuf; Output.end_inline_coq (); - doc lexbuf } - | "[[" nl space* + | "[[" nl { formatted := true; Output.line_break (); Output.start_inline_coq (); - Output.indentation (fst (count_spaces (lexeme lexbuf))); let eol = body_bol lexbuf in Output.end_inline_coq (); formatted := false; if eol then doc_bol lexbuf else doc lexbuf} + | "[" + { brackets := 1; + Output.start_inline_coq (); escaped_coq lexbuf; Output.end_inline_coq (); + doc lexbuf } | '*'* "*)" space* nl { true } | '*'* "*)" @@ -612,7 +659,7 @@ and skip_to_dot = parse and body_bol = parse | space+ { Output.indentation (fst (count_spaces (lexeme lexbuf))); body lexbuf } - | _ { backtrack lexbuf; body lexbuf } + | _ { backtrack lexbuf; Output.indentation 0; body lexbuf } and body = parse | nl {Output.line_break(); body_bol lexbuf} @@ -645,7 +692,7 @@ and notation_bol = parse and notation = parse | nl { Output.line_break(); notation_bol lexbuf } - | '"' { Output.char '"'; false } + | '"' { Output.char '"'} | token { let s = lexeme lexbuf in Output.symbol s; notation lexbuf } @@ -660,7 +707,7 @@ and skip_hide = parse (*s Reading token pretty-print *) and printing_token_body = parse - | "*)" | eof + | "*)" nl? | eof { let s = Buffer.contents token_buffer in Buffer.clear token_buffer; s } diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 49b9ce7a..82709db4 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: auto_ind_decl.ml 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: auto_ind_decl.ml 11671 2008-12-12 12:43:03Z herbelin $ i*) open Tacmach open Util @@ -530,13 +530,13 @@ let compute_bl_tact ind lnamesparrec nparrec = tclORELSE reflexivity (Equality.discr_tac false None) ); simpl_in_hyp - ((Rawterm.all_occurrences_expr,freshz),Tacexpr.InHyp); + ((Rawterm.all_occurrences_expr,freshz),InHyp); (* repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). *) tclREPEAT ( tclTHENSEQ [ - apply_in false freshz [(andb_prop()),Rawterm.NoBindings]; + apply_in false false freshz [(Evd.empty,andb_prop()),Rawterm.NoBindings] None; fun gl -> let fresht = fresh_id (!avoid) (id_of_string "Z") gsig in @@ -748,8 +748,8 @@ let compute_dec_tact ind lnamesparrec nparrec = Pfedit.by ( tclTHENSEQ [ intros_using fresh_first_intros; intros_using [freshn;freshm]; - assert_as true (dl,Genarg.IntroIdentifier freshH) ( - mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) + assert_tac (Name freshH) ( + mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) ) ]); (*we do this so we don't have to prove the same goal twice *) Pfedit.by ( tclTHEN @@ -795,7 +795,7 @@ let compute_dec_tact ind lnamesparrec nparrec = unfold_constr (Lazy.force Coqlib.coq_not_ref); intro; Equality.subst_all; - assert_as true (dl,Genarg.IntroIdentifier freshH3) + assert_tac (Name freshH3) (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|])) ]); Pfedit.by diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 511befd8..04945040 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: classes.ml 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: classes.ml 11800 2009-01-18 18:34:15Z msozeau $ i*) (*i*) open Names @@ -32,19 +32,23 @@ open Topconstr open Decl_kinds open Entries -let hint_db = "typeclass_instances" +let typeclasses_db = "typeclass_instances" let qualid_of_con c = Qualid (dummy_loc, shortest_qualid_of_global Idset.empty (ConstRef c)) +let set_rigid c = + Auto.add_hints false [typeclasses_db] + (Vernacexpr.HintsTransparency ([qualid_of_con c], false)) + let _ = Typeclasses.register_add_instance_hint (fun inst pri -> Flags.silently (fun () -> - Auto.add_hints false [hint_db] + Auto.add_hints false [typeclasses_db] (Vernacexpr.HintsResolve - [pri, CAppExpl (dummy_loc, (None, qualid_of_con inst), [])])) ()) - + [pri, false, CAppExpl (dummy_loc, (None, qualid_of_con inst), [])])) ()) + let declare_instance_cst glob con = let instance = Typeops.type_of_constant (Global.env ()) con in let _, r = decompose_prod_assum instance in @@ -67,207 +71,27 @@ type binder_list = (identifier located * bool * constr_expr) list (* Calls to interpretation functions. *) -let interp_binders_evars isevars env avoid l = - List.fold_left - (fun (env, ids, params) ((loc, i), t) -> - let n = Name i in - let t' = interp_binder_evars isevars env n t in - let d = (i,None,t') in - (push_named d env, i :: ids, d::params)) - (env, avoid, []) l - -let interp_typeclass_context_evars isevars env avoid l = - List.fold_left - (fun (env, ids, params) (iid, bk, l) -> - let t' = interp_binder_evars isevars env (snd iid) l in - let i = match snd iid with - | Anonymous -> Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids - | Name id -> id - in - let d = (i,None,t') in - (push_named d env, i :: ids, d::params)) - (env, avoid, []) l - let interp_type_evars evdref env ?(impls=([],[])) typ = let typ' = intern_gen true ~impls (Evd.evars_of !evdref) env typ in let imps = Implicit_quantifiers.implicits_of_rawterm typ' in imps, Pretyping.Default.understand_tcc_evars evdref env Pretyping.IsType typ' - -let mk_interning_data env na impls typ = - let impl = Impargs.compute_implicits_with_manual env typ (Impargs.is_implicit_args()) impls - in (na, ([], impl, Notation.compute_arguments_scope typ)) -let interp_fields_evars isevars env avoid l = - List.fold_left - (fun (env, uimpls, ids, params, impls) ((loc, i), _, t) -> - let impl, t' = interp_type_evars isevars env ~impls t in - let data = mk_interning_data env i impl t' in - let d = (Name i,None,t') in - (push_rel d env, impl :: uimpls, Idset.add i ids, d::params, ([], data :: snd impls))) - (env, [], avoid, [], ([], [])) l - (* Declare everything in the parameters as implicit, and the class instance as well *) open Topconstr - -let implicits_of_context ctx = - list_map_i (fun i name -> - let explname = - match name with - | Name n -> Some n - | Anonymous -> None - in ExplByPos (i, explname), (true, true)) - 1 (List.rev (Anonymous :: (List.map pi1 ctx))) - -let degenerate_decl (na,b,t) = - let id = match na with - | Name id -> id - | Anonymous -> anomaly "Unnamed record variable" in - match b with - | None -> (id, Entries.LocalAssum t) - | Some b -> (id, Entries.LocalDef b) - -let name_typeclass_binder avoid = function - | LocalRawAssum ([loc, Anonymous], bk, c) -> - let name = - let id = - match c with - CApp (_, (_, CRef (Ident (loc,id))), _) -> id - | _ -> id_of_string "assum" - in Implicit_quantifiers.make_fresh avoid (Global.env ()) id - in LocalRawAssum ([loc, Name name], bk, c), Idset.add name avoid - | x -> x, avoid - -let name_typeclass_binders avoid l = - let l', avoid = - List.fold_left - (fun (binders, avoid) b -> let b', avoid = name_typeclass_binder avoid b in - b' :: binders, avoid) - ([], avoid) l - in List.rev l', avoid - -let new_class id par ar sup props = - let env0 = Global.env() in - let isevars = ref (Evd.create_evar_defs Evd.empty) in - let bound = Implicit_quantifiers.ids_of_list (Termops.ids_of_context env0) in - let bound, ids = Implicit_quantifiers.free_vars_of_binders ~bound [] (sup @ par) in - let bound = Idset.union bound (Implicit_quantifiers.ids_of_list ids) in - let sup, bound = name_typeclass_binders bound sup in - let supnames = - List.fold_left (fun acc b -> - match b with - LocalRawAssum (nl, _, _) -> nl @ acc - | LocalRawDef _ -> assert(false)) - [] sup - in - - (* Interpret the arity *) - let arity_imps, fullarity = - let ar = - match ar with - Some ar -> ar | None -> (dummy_loc, Rawterm.RType None) - in - let arity = CSort (fst ar, snd ar) in - let term = prod_constr_expr (prod_constr_expr arity par) sup in - interp_type_evars isevars env0 term - in - let ctx_params, arity = decompose_prod_assum fullarity in - let env_params = push_rel_context ctx_params env0 in - (* Interpret the definitions and propositions *) - let env_props, prop_impls, bound, ctx_props, _ = - interp_fields_evars isevars env_params bound props - in - let subs = List.map (fun ((loc, id), b, _) -> b) props in - (* Instantiate evars and check all are resolved *) - let isevars,_ = Evarconv.consider_remaining_unif_problems env_props !isevars in - let isevars = Typeclasses.resolve_typeclasses env_props isevars in - let sigma = Evd.evars_of isevars in - let ctx_params = Evarutil.nf_rel_context_evar sigma ctx_params in - let ctx_props = Evarutil.nf_rel_context_evar sigma ctx_props in - let arity = Reductionops.nf_evar sigma arity in - let ce t = Evarutil.check_evars env0 Evd.empty isevars t in - let fieldimpls = - (* Make the class and all params implicits in the projections *) - let ctx_impls = implicits_of_context ctx_params in - let len = succ (List.length ctx_params) in - List.map (fun x -> ctx_impls @ Impargs.lift_implicits len x) prop_impls - in - let impl, projs = - let params = ctx_params and fields = ctx_props in - List.iter (fun (_,c,t) -> ce t; match c with Some c -> ce c | None -> ()) (params @ fields); - match fields with - [(Name proj_name, _, field)] -> - let class_body = it_mkLambda_or_LetIn field params in - let class_type = - match ar with - Some _ -> Some (it_mkProd_or_LetIn arity params) - | None -> None - in - let class_entry = - { const_entry_body = class_body; - const_entry_type = class_type; - const_entry_opaque = false; - const_entry_boxed = false } - in - let cst = Declare.declare_constant (snd id) - (DefinitionEntry class_entry, IsDefinition Definition) - in - let inst_type = appvectc (mkConst cst) (rel_vect 0 (List.length params)) in - let proj_type = it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in - let proj_body = it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in - let proj_entry = - { const_entry_body = proj_body; - const_entry_type = Some proj_type; - const_entry_opaque = false; - const_entry_boxed = false } - in - let proj_cst = Declare.declare_constant proj_name - (DefinitionEntry proj_entry, IsDefinition Definition) - in - let cref = ConstRef cst in - Impargs.declare_manual_implicits false cref (Impargs.is_implicit_args()) arity_imps; - Impargs.declare_manual_implicits false (ConstRef proj_cst) (Impargs.is_implicit_args()) (List.hd fieldimpls); - cref, [proj_name, proj_cst] - | _ -> - let idb = id_of_string ("Build_" ^ (string_of_id (snd id))) in - let idarg = Nameops.next_ident_away (snd id) (ids_of_context (Global.env())) in - let kn = Record.declare_structure (snd id) idb arity_imps - params arity fieldimpls fields ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields) - in - IndRef (kn,0), (List.map2 (fun (id, _, _) y -> Nameops.out_name id, Option.get y) - fields (Recordops.lookup_projections (kn,0))) - in - let ctx_context = - List.map (fun ((na, b, t) as d) -> - match Typeclasses.class_of_constr t with - | Some cl -> (Some (cl.cl_impl, List.exists (fun (_, n) -> n = na) supnames), d) - | None -> (None, d)) - ctx_params - in - let k = - { cl_impl = impl; - cl_context = ctx_context; - cl_props = ctx_props; - cl_projs = projs } - in - List.iter2 (fun p sub -> if sub then declare_instance_cst true (snd p)) - k.cl_projs subs; - add_class k - -type binder_def_list = (identifier located * identifier located list * constr_expr) list - -let binders_of_lidents l = - List.map (fun (loc, id) -> LocalRawAssum ([loc, Name id], Default Rawterm.Implicit, CHole (loc, None))) l - let type_ctx_instance isevars env ctx inst subst = let (s, _) = List.fold_left2 - (fun (subst, instctx) (na, _, t) ce -> + (fun (subst, instctx) (na, b, t) ce -> let t' = substl subst t in - let c = interp_casted_constr_evars isevars env ce t' in - let d = na, Some c, t' in - c :: subst, d :: instctx) + let c' = + match b with + | None -> interp_casted_constr_evars isevars env ce t' + | Some b -> substl subst b + in + let d = na, Some c', t' in + c' :: subst, d :: instctx) (subst, []) (List.rev ctx) inst in s @@ -284,27 +108,10 @@ let id_of_class cl = open Pp let ($$) g f = fun x -> g (f x) - -let default_on_free_vars = - Flags.if_verbose - (fun fvs -> - match fvs with - [] -> () - | l -> msgnl (str"Implicitly generalizing " ++ - prlist_with_sep (fun () -> str", ") Nameops.pr_id l ++ str".")) - -let fail_on_free_vars = function - [] -> () - | [fv] -> - errorlabstrm "Classes" - (str"Unbound variable " ++ Nameops.pr_id fv ++ str".") - | fvs -> errorlabstrm "Classes" - (str"Unbound variables " ++ - prlist_with_sep (fun () -> str", ") Nameops.pr_id fvs ++ str".") let instance_hook k pri global imps ?hook cst = let inst = Typeclasses.new_instance k pri global cst in - Impargs.maybe_declare_manual_implicits false (ConstRef cst) false imps; + Impargs.maybe_declare_manual_implicits false (ConstRef cst) ~enriching:false imps; Typeclasses.add_instance inst; (match hook with Some h -> h cst | None -> ()) @@ -323,51 +130,30 @@ let declare_instance_constant k pri global imps ?hook id term termtype = instance_hook k pri global imps ?hook kn; id -let new_instance ?(global=false) ctx (instid, bk, cl) props ?(on_free_vars=default_on_free_vars) +let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) ?(tac:Proof_type.tactic option) ?(hook:(Names.constant -> unit) option) pri = let env = Global.env() in let isevars = ref (Evd.create_evar_defs Evd.empty) in - let bound = Implicit_quantifiers.ids_of_list (Termops.ids_of_context env) in - let bound, fvs = Implicit_quantifiers.free_vars_of_binders ~bound [] ctx in let tclass = match bk with - | Implicit -> - let loc, id, par = Implicit_quantifiers.destClassAppExpl cl in - let k = class_info (Nametab.global id) in - let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in - let needlen = List.fold_left (fun acc (x, y) -> if x = None then succ acc else acc) 0 k.cl_context in - if needlen <> applen then - mismatched_params env (List.map fst par) (List.map snd k.cl_context); - let pars, _ = Implicit_quantifiers.combine_params Idset.empty (* need no avoid *) - (fun avoid (clname, (id, _, t)) -> - match clname with - Some (cl, b) -> - let t = - if b then - let _k = class_info cl in - CHole (Util.dummy_loc, Some (Evd.ImplicitArg (k.cl_impl, (1, None)))) - else CHole (Util.dummy_loc, None) - in t, avoid - | None -> failwith ("new instance: under-applied typeclass")) - par (List.rev k.cl_context) - in Topconstr.CAppExpl (loc, (None, id), pars) - - | Explicit -> cl + | Implicit -> + Implicit_quantifiers.implicit_application Idset.empty ~allow_partial:false + (fun avoid (clname, (id, _, t)) -> + match clname with + | Some (cl, b) -> + let t = CHole (Util.dummy_loc, None) in + t, avoid + | None -> failwith ("new instance: under-applied typeclass")) + cl + | Explicit -> cl in - let ctx_bound = Idset.union bound (Implicit_quantifiers.ids_of_list fvs) in - let gen_ids = Implicit_quantifiers.free_vars_of_constr_expr ~bound:ctx_bound tclass [] in - on_free_vars (List.rev fvs @ List.rev gen_ids); - let gen_idset = Implicit_quantifiers.ids_of_list gen_ids in - let bound = Idset.union gen_idset ctx_bound in - let gen_ctx = Implicit_quantifiers.binder_list_of_ids gen_ids in - let ctx, avoid = name_typeclass_binders bound ctx in - let ctx = List.append ctx (List.rev gen_ctx) in + let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in let k, ctx', imps, subst = let c = Command.generalize_constr_expr tclass ctx in let imps, c' = interp_type_evars isevars env c in let ctx, c = decompose_prod_assum c' in - let cl, args = Typeclasses.dest_class_app c in - cl, ctx, imps, List.rev (Array.to_list args) + let cl, args = Typeclasses.dest_class_app (push_rel_context ctx env) c in + cl, ctx, imps, List.rev args in let id = match snd instid with @@ -384,7 +170,7 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(on_free_vars=defau isevars := Evarutil.nf_evar_defs !isevars; isevars := resolve_typeclasses env !isevars; let sigma = Evd.evars_of !isevars in - let substctx = List.map (Evarutil.nf_evar sigma) subst in + let subst = List.map (Evarutil.nf_evar sigma) subst in if Lib.is_modtype () then begin let _, ty_constr = instance_constructor k (List.rev subst) in @@ -399,31 +185,48 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(on_free_vars=defau end else begin + let props = + match props with + | CRecord (loc, _, fs) -> + if List.length fs > List.length k.cl_props then + mismatched_props env' (List.map snd fs) k.cl_props; + fs + | _ -> + if List.length k.cl_props <> 1 then + errorlabstrm "new_instance" (Pp.str "Expected a definition for the instance body") + else [(dummy_loc, Nameops.out_name (pi1 (List.hd k.cl_props))), props] + in let subst = - let props = - List.map (fun (x, l, d) -> - x, Topconstr.abstract_constr_expr d (binders_of_lidents l)) - props - in - if List.length props > List.length k.cl_props then - mismatched_props env' (List.map snd props) k.cl_props; - let props, rest = - List.fold_left - (fun (props, rest) (id,_,_) -> - try - let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in - let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in - Constrintern.add_glob loc (ConstRef (List.assoc mid k.cl_projs)); - c :: props, rest' - with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest) - ([], props) k.cl_props - in - if rest <> [] then - unbound_method env' k.cl_impl (fst (List.hd rest)) - else - type_ctx_instance isevars env' k.cl_props props substctx + match k.cl_props with + | [(na,b,ty)] -> + let term = match props with [] -> CHole (Util.dummy_loc, None) + | [(_,f)] -> f | _ -> assert false in + let ty' = substl subst ty in + let c = interp_casted_constr_evars isevars env' term ty' in + c :: subst + | _ -> + let props, rest = + List.fold_left + (fun (props, rest) (id,b,_) -> + try + let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in + let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in + Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); + c :: props, rest' + with Not_found -> + (CHole (Util.dummy_loc, None) :: props), rest) + ([], props) k.cl_props + in + if rest <> [] then + unbound_method env' k.cl_impl (fst (List.hd rest)) + else + type_ctx_instance isevars env' k.cl_props props subst + in + let subst = List.fold_left2 + (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') + [] subst (k.cl_props @ snd k.cl_context) in - let app, ty_constr = instance_constructor k (List.rev subst) in + let app, ty_constr = instance_constructor k subst in let termtype = let t = it_mkProd_or_LetIn ty_constr ctx' in Evarutil.nf_isevar !isevars t diff --git a/toplevel/classes.mli b/toplevel/classes.mli index f149ac72..1bbf29a6 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: classes.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: classes.mli 11709 2008-12-20 11:42:15Z msozeau $ i*) (*i*) open Names @@ -29,27 +29,6 @@ val mismatched_params : env -> constr_expr list -> rel_context -> 'a val mismatched_props : env -> constr_expr list -> rel_context -> 'a -type binder_list = (identifier located * bool * constr_expr) list -type binder_def_list = (identifier located * identifier located list * constr_expr) list - -val binders_of_lidents : identifier located list -> local_binder list - -val name_typeclass_binders : Idset.t -> - Topconstr.local_binder list -> - Topconstr.local_binder list * Idset.t - -val new_class : identifier located -> - local_binder list -> - Vernacexpr.sort_expr located option -> - local_binder list -> - binder_list -> unit - -(* By default, print the free variables that are implicitely generalized. *) - -val default_on_free_vars : identifier list -> unit - -val fail_on_free_vars : identifier list -> unit - (* Instance declaration *) val declare_instance : bool -> identifier located -> unit @@ -69,8 +48,8 @@ val new_instance : ?global:bool -> (* Not global by default. *) local_binder list -> typeclass_constraint -> - binder_def_list -> - ?on_free_vars:(identifier list -> unit) -> + constr_expr -> + ?generalize:bool -> ?tac:Proof_type.tactic -> ?hook:(constant -> unit) -> int option -> diff --git a/toplevel/command.ml b/toplevel/command.ml index 3688c347..b50c9bbd 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: command.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: command.ml 11745 2009-01-04 18:43:08Z herbelin $ *) open Pp open Util @@ -136,7 +136,7 @@ let red_constant_entry bl ce = function let declare_global_definition ident ce local imps = let kn = declare_constant ident (DefinitionEntry ce,IsDefinition Definition) in let gr = ConstRef kn in - maybe_declare_manual_implicits false gr (is_implicit_args ()) imps; + maybe_declare_manual_implicits false gr imps; if local = Local && Flags.is_verbose() then msg_warning (pr_id ident ++ str" is declared as a global definition"); definition_message ident; @@ -166,8 +166,9 @@ let declare_definition ident (local,boxed,dok) bl red_option c typopt hook = hook local r let syntax_definition ident (vars,c) local onlyparse = - let pat = interp_aconstr [] vars c in - Syntax_def.declare_syntactic_definition local ident onlyparse pat + let ((vars,_),pat) = interp_aconstr [] (vars,[]) c in + let onlyparse = onlyparse or Metasyntax.is_not_printable pat in + Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) @@ -189,7 +190,7 @@ let declare_one_assumption is_coe (local,kind) c imps impl keep nl (_,ident) = let kn = declare_constant ident (ParameterEntry (c,nl), IsAssumption kind) in let gr = ConstRef kn in - maybe_declare_manual_implicits false gr (is_implicit_args ()) imps; + maybe_declare_manual_implicits false gr imps; assumption_message ident; if local=Local & Flags.is_verbose () then msg_warning (pr_id ident ++ str" is declared as a parameter" ++ @@ -339,13 +340,26 @@ let (inDec,outDec) = let start_hook = ref ignore let set_start_hook = (:=) start_hook -let start_proof id kind c ?init_tac hook = +let start_proof id kind c ?init_tac ?(compute_guard=false) hook = let sign = Global.named_context () in let sign = clear_proofs sign in !start_hook c; - Pfedit.start_proof id kind sign c ?init_tac:init_tac hook - -let save id const (locality,kind) hook = + Pfedit.start_proof id kind sign c ?init_tac ~compute_guard hook + +let adjust_guardness_conditions const = + (* Try all combinations... not optimal *) + match kind_of_term const.const_entry_body with + | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> + let possible_indexes = + List.map (fun c -> + interval 0 (List.length (fst (Sign.decompose_lam_assum c)))) + (Array.to_list fixdefs) in + let indexes = search_guard dummy_loc (Global.env()) possible_indexes fixdecls in + { const with const_entry_body = mkFix ((indexes,0),fixdecls) } + | c -> const + +let save id const do_guard (locality,kind) hook = + let const = if do_guard then adjust_guardness_conditions const else const in let {const_entry_body = pft; const_entry_type = tpo; const_entry_opaque = opacity } = const in @@ -366,9 +380,9 @@ let save_hook = ref ignore let set_save_hook f = save_hook := f let save_named opacity = - let id,(const,persistence,hook) = Pfedit.cook_proof !save_hook in + let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in let const = { const with const_entry_opaque = opacity } in - save id const persistence hook + save id const do_guard persistence hook let make_eq_decidability ind = (* fetching data *) @@ -442,7 +456,7 @@ let declare_eliminations sp = (* 3b| Mutual inductive definitions *) -let compute_interning_datas env l nal typl impll = +let compute_interning_datas env ty l nal typl impll = let mk_interning_data na typ impls = let idl, impl = let impl = @@ -452,7 +466,7 @@ let compute_interning_datas env l nal typl impll = let sub_impl' = List.filter is_status_implicit sub_impl in (List.map name_of_implicit sub_impl', impl) in - (na, (idl, impl, compute_arguments_scope typ)) in + (na, (ty, idl, impl, compute_arguments_scope typ)) in (l, list_map3 mk_interning_data nal typl impll) let declare_interning_data (_,impls) (df,c,scope) = @@ -511,7 +525,9 @@ let interp_mutual paramsl indl notations finite = check_all_names_different indl; let env0 = Global.env() in let evdref = ref (Evd.create_evar_defs Evd.empty) in - let (env_params, ctx_params), userimpls = interp_context_evars evdref env0 paramsl in + let (env_params, ctx_params), userimpls = + interp_context_evars ~fail_anonymous:false evdref env0 paramsl + in let indnames = List.map (fun ind -> ind.ind_name) indl in (* Names of parameters as arguments of the inductive type (defs removed) *) @@ -526,7 +542,7 @@ let interp_mutual paramsl indl notations finite = (* Compute interpretation metadatas *) let indimpls = List.map (fun _ -> userimpls) fullarities in - let impls = compute_interning_datas env0 params indnames fullarities indimpls in + let impls = compute_interning_datas env0 Inductive params indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in let constructors = @@ -539,6 +555,7 @@ let interp_mutual 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 sigma = evars_of 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 @@ -604,7 +621,7 @@ let prepare_inductive ntnl indl = let indl = List.map (fun ((_,indname),_,ar,lc) -> { ind_name = indname; - ind_arity = ar; + ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Rawterm.RType None)) ar; ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc }) indl in List.fold_right Option.List.cons ntnl [], indl @@ -624,12 +641,10 @@ let declare_mutual_with_eliminations isrecord mie impls = let (_,kn) = declare_mind isrecord mie in list_iter_i (fun i (indimpls, constrimpls) -> let ind = (kn,i) in - maybe_declare_manual_implicits false (IndRef ind) - (is_implicit_args()) indimpls; + maybe_declare_manual_implicits false (IndRef ind) indimpls; list_iter_i (fun j impls -> - maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) - (is_implicit_args()) impls) + maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls) constrimpls) impls; if_verbose ppnl (minductive_message names); @@ -784,7 +799,7 @@ let declare_fix boxed kind f def t imps = } in let kn = declare_constant f (DefinitionEntry ce,IsDefinition kind) in let gr = ConstRef kn in - maybe_declare_manual_implicits false gr (is_implicit_args ()) imps; + maybe_declare_manual_implicits false gr imps; gr let prepare_recursive_declaration fixnames fixtypes fixdefs = @@ -831,7 +846,7 @@ let interp_recursive fixkind l boxed = let env_rec = push_named_types env fixnames fixtypes in (* Get interpretation metadatas *) - let impls = compute_interning_datas env [] fixnames fixtypes fiximps in + let impls = compute_interning_datas env Recursive [] fixnames fixtypes fiximps in let notations = List.fold_right Option.List.cons ntnl [] in (* Interp bodies with rollback because temp use of notations/implicit *) @@ -1044,13 +1059,12 @@ let build_combined_scheme name schemes = (* 4.1| Support for mutually proved theorems *) let retrieve_first_recthm = function - | VarRef id -> - (pi2 (Global.lookup_named id),variable_opacity id) - | ConstRef cst -> - let {const_body=body;const_opaque=opaq} = - Global.lookup_constant cst in - (Option.map Declarations.force body,opaq) - | _ -> assert false + | VarRef id -> + (pi2 (Global.lookup_named id),variable_opacity id) + | ConstRef cst -> + let {const_body=body;const_opaque=opaq} = Global.lookup_constant cst in + (Option.map Declarations.force body,opaq) + | _ -> assert false let default_thm_id = id_of_string "Unnamed_thm" @@ -1108,19 +1122,19 @@ let look_for_mutual_statements thms = (* common coinductive conclusion *) let n = List.length thms in let inds = List.map (fun (id,(t,_) as x) -> - let (hyps,ccl) = splay_prod_assum (Global.env()) Evd.empty t in + let (hyps,ccl) = Sign.decompose_prod_assum t in let whnf_hyp_hds = map_rel_context_with_binders (fun i c -> fst (whd_betadeltaiota_stack (Global.env()) Evd.empty (lift i c))) hyps in let ind_hyps = - List.filter ((<>) None) (list_map_i (fun i (_,b,t) -> + List.flatten (list_map_i (fun i (_,b,t) -> match kind_of_term t with | Ind (kn,_ as ind) when let mind = Global.lookup_mind kn in - mind.mind_ntypes = n & mind.mind_finite & b = None -> - Some (ind,x,i) + mind.mind_finite & b = None -> + [ind,x,i] | _ -> - None) 1 whnf_hyp_hds) in + []) 1 (List.rev whnf_hyp_hds)) in let ind_ccl = let cclenv = push_rel_context hyps (Global.env()) in let whnf_ccl,_ = whd_betadeltaiota_stack cclenv Evd.empty ccl in @@ -1128,53 +1142,45 @@ let look_for_mutual_statements thms = | Ind (kn,_ as ind) when let mind = Global.lookup_mind kn in mind.mind_ntypes = n & not mind.mind_finite -> - Some (ind,x,0) + [ind,x,0] | _ -> - None in + [] in ind_hyps,ind_ccl) thms in let inds_hyps,ind_ccls = List.split inds in - let is_same_ind kn = function Some ((kn',_),_,_) -> kn = kn' | _ -> false in - let compare_kn ((kn,i),_,_) ((kn,i'),_,_) = i - i' in + let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> kn = kn' in (* Check if all conclusions are coinductive in the same type *) + (* (degenerated cartesian product since there is at most one coind ccl) *) let same_indccl = - match ind_ccls with - | (Some ((kn,_),_,_ as x))::rest when List.for_all (is_same_ind kn) rest - -> Some (x :: List.map Option.get rest) - | _ -> None in + list_cartesians_filter (fun hyp oks -> + if List.for_all (of_same_mutind hyp) oks + then Some (hyp::oks) else None) [] ind_ccls in + let ordered_same_indccl = + List.filter (list_for_all_i (fun i ((kn,j),_,_) -> i=j) 0) same_indccl in (* Check if some hypotheses are inductive in the same type *) let common_same_indhyp = - let rec find_same_ind inds = - match inds with - | []::_ -> - [] - | (Some ((kn,_),_,_) as x :: hyps_thms1)::other_thms -> - let others' = List.map (List.filter (is_same_ind kn)) other_thms in - (x,others')::find_same_ind (hyps_thms1::other_thms) - | (None::hyps_thm1)::other_thms -> - find_same_ind (hyps_thm1::other_thms) - | [] -> - assert false in - find_same_ind inds_hyps in - let common_inds,finite = - match same_indccl, common_same_indhyp with - | None, [(x,rest)] when List.for_all (fun l -> List.length l = 1) rest -> - (* One occurrence of common inductive hyps and no common coind ccls *) - Option.get x::List.map (fun x -> Option.get (List.hd x)) rest, - false - | Some indccl, [] -> - (* One occurrence of common coind ccls and no common inductive hyps *) + list_cartesians_filter (fun hyp oks -> + if List.for_all (of_same_mutind hyp) oks + then Some (hyp::oks) else None) [] inds_hyps in + let ordered_inds,finite = + match ordered_same_indccl, common_same_indhyp with + | indccl::rest, _ -> + assert (rest=[]); + (* One occ. of common coind ccls and no common inductive hyps *) + if common_same_indhyp <> [] then + if_verbose warning "Assuming mutual coinductive statements."; + flush_all (); indccl, true - | _ -> - error - ("Cannot find a common mutual inductive premise or coinductive" ^ - " conclusion in the statements") in - let ordered_inds = List.sort compare_kn common_inds in - list_iter_i (fun i' ((kn,i),_,_) -> - if i <> i' then - error - ("Cannot find distinct (co)inductive types of the same family" ^ - "of mutual (co)inductive types")) - ordered_inds; + | [], _::_ -> + if same_indccl <> [] && + list_distinct (List.map pi1 (List.hd same_indccl)) then + if_verbose warn (strbrk "Coinductive statements do not follow the order of definition, assume the proof to be by induction."); flush_all (); + (* assume the largest indices as possible *) + list_last common_same_indhyp, false + | _, [] -> + error + ("Cannot find common (mutual) inductive premises or coinductive" ^ + " conclusions in the statements.") + in let nl,thms = List.split (List.map (fun (_,x,i) -> (i,x)) ordered_inds) in let rec_tac = if finite then @@ -1182,6 +1188,7 @@ let look_for_mutual_statements thms = | (id,_)::l -> Hiddentac.h_mutual_cofix true id l | _ -> assert false else + (* nl is dummy: it will be recomputed at Qed-time *) match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with | (id,n,_)::l -> Hiddentac.h_mutual_fix true id n l | _ -> assert false in @@ -1208,9 +1215,10 @@ let start_proof_com kind thms hook = list_map_i (save_remaining_recthms kind body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in List.iter (fun (strength,ref,imps) -> - maybe_declare_manual_implicits false ref (is_implicit_args ()) imps; + maybe_declare_manual_implicits false ref imps; hook strength ref) thms_data in - start_proof id kind t ?init_tac:rec_tac hook + start_proof id kind t ?init_tac:rec_tac + ~compute_guard:(rec_tac<>None) hook let check_anonymity id save_ident = if atompart_of_id id <> "Unnamed_thm" then @@ -1220,17 +1228,17 @@ let check_anonymity id save_ident = *) let save_anonymous opacity save_ident = - let id,(const,persistence,hook) = Pfedit.cook_proof !save_hook in + let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in let const = { const with const_entry_opaque = opacity } in check_anonymity id save_ident; - save save_ident const persistence hook + save save_ident const do_guard persistence hook let save_anonymous_with_strength kind opacity save_ident = - let id,(const,_,hook) = Pfedit.cook_proof !save_hook in + let id,(const,do_guard,_,hook) = Pfedit.cook_proof !save_hook in let const = { const with const_entry_opaque = opacity } in check_anonymity id save_ident; (* we consider that non opaque behaves as local for discharge *) - save save_ident const (Global, Proof kind) hook + save save_ident const do_guard (Global, Proof kind) hook let admit () = let (id,k,typ,hook) = Pfedit.current_proof_statement () in diff --git a/toplevel/command.mli b/toplevel/command.mli index 8ac8c234..b42fafd0 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: command.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: command.mli 11745 2009-01-04 18:43:08Z herbelin $ i*) (*i*) open Util @@ -56,17 +56,19 @@ val declare_assumption : identifier located list -> val declare_interning_data : 'a * Constrintern.implicits_env -> string * Topconstr.constr_expr * Topconstr.scope_name option -> unit -val compute_interning_datas : Environ.env -> 'a list -> 'b list -> +val compute_interning_datas : Environ.env -> Constrintern.var_internalisation_type -> + 'a list -> 'b list -> Term.types list ->Impargs.manual_explicitation list list -> 'a list * - ('b * (Names.identifier list * Impargs.implicits_list * + ('b * (Constrintern.var_internalisation_type * Names.identifier list * Impargs.implicits_list * Topconstr.scope_name option list)) list val check_mutuality : Environ.env -> definition_object_kind -> (identifier * types) list -> unit -val build_mutual : (inductive_expr * decl_notation) list -> bool -> unit +val build_mutual : ((lident * local_binder list * constr_expr option * constructor_expr list) * + decl_notation) list -> bool -> unit val declare_mutual_with_eliminations : bool -> Entries.mutual_inductive_entry -> @@ -107,7 +109,7 @@ val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr val set_start_hook : (types -> unit) -> unit val start_proof : identifier -> goal_kind -> types -> - ?init_tac:Proof_type.tactic -> declaration_hook -> unit + ?init_tac:Proof_type.tactic -> ?compute_guard:bool -> declaration_hook -> unit val start_proof_com : goal_kind -> (lident option * (local_binder list * constr_expr)) list -> diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 884589e7..d32a773d 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coqinit.ml 10901 2008-05-07 18:53:48Z letouzey $ *) +(* $Id: coqinit.ml 11749 2009-01-05 14:01:04Z notin $ *) open Pp open System @@ -93,16 +93,11 @@ let theories_dirs_map = [ "theories/Init", "Init" ] -(* Initializes the LoadPath according to COQLIB and Coq_config *) +(* Initializes the LoadPath *) let init_load_path () = - let coqlib = - (* variable COQLIB overrides the default library *) - getenv_else "COQLIB" - (if Coq_config.local || !Flags.boot then Coq_config.coqtop - else Coq_config.coqlib) in + let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in let dirs = "states" :: ["contrib"] in - let camlp4 = getenv_else "CAMLP4LIB" Coq_config.camlp4lib in (* first user-contrib *) if Sys.file_exists user_contrib then Mltop.add_rec_path user_contrib Nameops.default_root_prefix; @@ -114,8 +109,6 @@ let init_load_path () = List.iter (fun (s,alias) -> Mltop.add_rec_path (coqlib/s) (Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root])) theories_dirs_map; - (* then camlp4lib *) - add_ml_include camlp4; (* then current directory *) Mltop.add_path "." Nameops.default_root_prefix; (* additional loadpath, given with -I -include -R options *) @@ -129,13 +122,13 @@ let init_library_roots () = (* Initialises the Ocaml toplevel before launching it, so that it can find the "include" file in the *source* directory *) -(* We only assume that the variable COQTOP is set *) let init_ocaml_path () = - let coqtop = getenv_else "COQTOP" Coq_config.coqtop in + let coqsrc = Coq_config.coqsrc in let add_subdir dl = - Mltop.add_ml_dir (List.fold_left (/) coqtop dl) + Mltop.add_ml_dir (List.fold_left (/) coqsrc dl) in - List.iter add_subdir - [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; - [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ]; - [ "tactics" ]; [ "toplevel" ]; [ "translate" ]; [ "ide" ] ] + Mltop.add_ml_dir (Envars.coqlib ()); + List.iter add_subdir + [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; + [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ]; + [ "tactics" ]; [ "toplevel" ]; [ "translate" ]; [ "ide" ] ] diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index f8c57ad2..f5d1d142 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coqtop.ml 11209 2008-07-05 10:17:49Z herbelin $ *) +(* $Id: coqtop.ml 11830 2009-01-22 06:45:13Z notin $ *) open Pp open Util @@ -21,7 +21,8 @@ open Coqinit let get_version_date () = try - let ch = open_in (Coq_config.coqlib^"/revision") in + let coqlib = Envars.coqlib () in + let ch = open_in (Filename.concat coqlib "revision") in let ver = input_line ch in let rev = input_line ch in (ver,rev) @@ -51,7 +52,9 @@ let set_batch_mode () = batch_mode := true let toplevel_default_name = make_dirpath [id_of_string "Top"] let toplevel_name = ref (Some toplevel_default_name) -let set_toplevel_name dir = toplevel_name := Some dir +let set_toplevel_name dir = + if dir = empty_dirpath then error "Need a non empty toplevel module name"; + toplevel_name := Some dir let unset_toplevel_name () = toplevel_name := None let remove_top_ml () = Mltop.remove () @@ -68,16 +71,16 @@ let outputstate = ref "" let set_outputstate s = outputstate:=s let outputstate () = if !outputstate <> "" then extern_state !outputstate -let check_coq_overwriting p = - if string_of_id (list_last (repr_dirpath p)) = "Coq" then - error "The \"Coq\" logical root directory is reserved for the Coq library" - let set_default_include d = push_include (d,Nameops.default_root_prefix) let set_default_rec_include d = push_rec_include(d,Nameops.default_root_prefix) let set_include d p = - let p = dirpath_of_string p in check_coq_overwriting p; push_include (d,p) + let p = dirpath_of_string p in + Library.check_coq_overwriting p; + push_include (d,p) let set_rec_include d p = - let p = dirpath_of_string p in check_coq_overwriting p; push_rec_include(d,p) + let p = dirpath_of_string p in + Library.check_coq_overwriting p; + push_rec_include(d,p) let load_vernacular_list = ref ([] : (string * bool) list) let add_load_vernacular verb s = @@ -85,8 +88,8 @@ let add_load_vernacular verb s = let load_vernacular () = List.iter (fun (s,b) -> - if Flags.do_translate () then - with_option translate_file (Vernac.load_vernac b) s + if Flags.do_beautify () then + with_option beautify_file (Vernac.load_vernac b) s else Vernac.load_vernac b s) (List.rev !load_vernacular_list) @@ -110,13 +113,13 @@ let add_compile verbose s = compile_list := (verbose,s) :: !compile_list let compile_files () = let init_state = States.freeze() in - let coqdoc_init_state = Constrintern.coqdoc_freeze () in + let coqdoc_init_state = Dumpglob.coqdoc_freeze () in List.iter (fun (v,f) -> States.unfreeze init_state; - Constrintern.coqdoc_unfreeze coqdoc_init_state; - if Flags.do_translate () then - with_option translate_file (Vernac.compile v) f + Dumpglob.coqdoc_unfreeze coqdoc_init_state; + if Flags.do_beautify () then + with_option beautify_file (Vernac.compile v) f else Vernac.compile v f) (List.rev !compile_list) @@ -132,7 +135,7 @@ let set_opt () = re_exec_version := "opt" let re_exec is_ide = let s = !re_exec_version in - let is_native = (Mltop.get()) = Mltop.Native in + let is_native = Mltop.is_native in (* Unix.readlink is not implemented on Windows architectures :-( let prog = try Unix.readlink "/proc/self/exe" @@ -177,8 +180,10 @@ let usage () = let warning s = msg_warning (str s) + let ide_args = ref [] let parse_args is_ide = + let glob_opt = ref false in let rec parse = function | [] -> () | "-with-geoproof" :: s :: rem -> @@ -240,21 +245,25 @@ let parse_args is_ide = | "-load-vernac-object" :: f :: rem -> add_vernac_obj f; parse rem | "-load-vernac-object" :: [] -> usage () - | "-dump-glob" :: f :: rem -> dump_into_file f; parse rem + | "-dump-glob" :: "stdout" :: rem -> Dumpglob.dump_to_stdout (); glob_opt := true; parse rem + (* À ne pas documenter : l'option 'stdout' n'étant + éventuellement utile que pour le debugging... *) + | "-dump-glob" :: f :: rem -> Dumpglob.dump_into_file f; glob_opt := true; parse rem | "-dump-glob" :: [] -> usage () + | ("-no-glob" | "-noglob") :: rem -> Dumpglob.noglob (); glob_opt := true; parse rem | "-require" :: f :: rem -> add_require f; parse rem | "-require" :: [] -> usage () - | "-compile" :: f :: rem -> add_compile false f; parse rem + | "-compile" :: f :: rem -> add_compile false f; if not !glob_opt then Dumpglob.dump_to_dotglob (); parse rem | "-compile" :: [] -> usage () - | "-compile-verbose" :: f :: rem -> add_compile true f; parse rem + | "-compile-verbose" :: f :: rem -> add_compile true f; if not !glob_opt then Dumpglob.dump_to_dotglob (); parse rem | "-compile-verbose" :: [] -> usage () | "-dont-load-proofs" :: rem -> Flags.dont_load_proofs := true; parse rem - | "-translate" :: rem -> make_translate true; parse rem + | "-beautify" :: rem -> make_beautify true; parse rem | "-unsafe" :: f :: rem -> add_unsafe f; parse rem | "-unsafe" :: [] -> usage () @@ -265,10 +274,15 @@ let parse_args is_ide = | "-emacs" :: rem -> Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem | "-emacs-U" :: rem -> Flags.print_emacs := true; Flags.print_emacs_safechar := true; Pp.make_pp_emacs(); parse rem - + | "-unicode" :: rem -> Flags.unicode_syntax := true; parse rem - | "-where" :: _ -> print_endline (getenv_else "COQLIB" Coq_config.coqlib); exit 0 + | "-coqlib" :: d :: rem -> Flags.coqlib_spec:=true; Flags.coqlib:=d; parse rem + | "-coqlib" :: [] -> usage () + + | "-where" :: _ -> print_endline (Envars.coqlib ()); exit 0 + + | ("-config"|"--config") :: _ -> Usage.print_config (); exit 0 | ("-quiet"|"-silent") :: rem -> Flags.make_silent true; parse rem diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 41783faa..f733a3d5 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: himsg.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: himsg.ml 11784 2009-01-14 11:36:32Z herbelin $ *) open Pp open Util @@ -312,7 +312,13 @@ let explain_occur_check env ev rhs = str "Cannot define " ++ str id ++ str " with term" ++ brk(1,1) ++ pt ++ spc () ++ str "that would depend on itself." -let explain_hole_kind env = function +let pr_ne_context_of header footer env = + if Environ.rel_context env = empty_rel_context & + Environ.named_context env = empty_named_context + then footer + else pr_ne_context_of header env + +let explain_hole_kind env evi = function | QuestionMark _ -> str "this placeholder" | CasesType -> str "the type of this pattern-matching problem" @@ -326,7 +332,12 @@ let explain_hole_kind env = function pr_id id ++ spc () ++ str "of" ++ spc () ++ Nametab.pr_global_env Idset.empty c | InternalHole -> - str "an internal placeholder" + str "an internal placeholder" ++ + Option.cata (fun evi -> + let env = Evd.evar_env evi in + str " of type " ++ pr_lconstr_env env evi.evar_concl ++ + pr_ne_context_of (str " in environment:"++ fnl ()) (mt ()) env) + (mt ()) evi | TomatchTypeParameter (tyi,n) -> str "the " ++ nth n ++ str " argument of the inductive type (" ++ pr_inductive env tyi ++ @@ -340,7 +351,7 @@ let explain_not_clean env ev t k = let env = make_all_name_different env in let id = Evd.string_of_existential ev in let var = pr_lconstr_env env t in - str "Tried to instantiate " ++ explain_hole_kind env k ++ + str "Tried to instantiate " ++ explain_hole_kind env None k ++ str " (" ++ str id ++ str ")" ++ spc () ++ str "with a term using variable " ++ var ++ spc () ++ str "which is not in its scope." @@ -350,25 +361,20 @@ let explain_unsolvability = function | Some (SeveralInstancesFound n) -> strbrk " (several distinct possible instances found)" -let pr_ne_context_of header footer env = - if Environ.rel_context env = empty_rel_context & - Environ.named_context env = empty_named_context then footer - else pr_ne_context_of header env - let explain_typeclass_resolution env evi k = match k with - InternalHole | ImplicitArg _ -> - (match Typeclasses.class_of_constr evi.evar_concl with - | Some c -> - let env = Evd.evar_env evi in - fnl () ++ str "Could not find an instance for " ++ - pr_lconstr_env env evi.evar_concl ++ - pr_ne_context_of (str " in environment:"++ fnl ()) (str ".") env - | None -> mt()) - | _ -> mt() - + | GoalEvar | InternalHole | ImplicitArg _ -> + (match Typeclasses.class_of_constr evi.evar_concl with + | Some c -> + let env = Evd.evar_env evi in + fnl () ++ str "Could not find an instance for " ++ + pr_lconstr_env env evi.evar_concl ++ + pr_ne_context_of (str " in environment:"++ fnl ()) (str ".") env + | None -> mt()) + | _ -> mt() + let explain_unsolvable_implicit env evi k explain = - str "Cannot infer " ++ explain_hole_kind env k ++ + str "Cannot infer " ++ explain_hole_kind env (Some evi) k ++ explain_unsolvability explain ++ str "." ++ explain_typeclass_resolution env evi k @@ -500,7 +506,7 @@ let explain_no_instance env (_,id) l = str "applied to arguments" ++ spc () ++ prlist_with_sep pr_spc (pr_lconstr_env env) l -let pr_constraints env evm = +let pr_constraints printenv env evm = let l = Evd.to_list evm in let (ev, evi) = List.hd l in if List.for_all (fun (ev', evi') -> @@ -508,7 +514,7 @@ let pr_constraints env evm = then let pe = pr_ne_context_of (str "In environment:") (mt ()) (reset_with_named_context evi.evar_hyps env) in - pe ++ fnl () ++ + (if printenv then pe ++ fnl () else mt ()) ++ prlist_with_sep (fun () -> fnl ()) (fun (ev, evi) -> str(string_of_existential ev)++ str " == " ++ pr_constr evi.evar_concl) l else @@ -518,13 +524,13 @@ let explain_unsatisfiable_constraints env evd constr = let evm = Evd.evars_of evd in match constr with | None -> - str"Unable to satisfy the following typeclass constraints:" ++ fnl() ++ - pr_constraints env evm + str"Unable to satisfy the following constraints:" ++ fnl() ++ + pr_constraints true env evm | Some (evi, k) -> explain_unsolvable_implicit env evi k None ++ fnl () ++ if List.length (Evd.to_list evm) > 1 then - str"With the following meta variables:" ++ - fnl() ++ Evd.pr_evar_map evm + str"With the following constraints:" ++ fnl() ++ + pr_constraints false env evm else mt () let explain_mismatched_contexts env c i j = @@ -572,6 +578,10 @@ let explain_non_linear_proof c = str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr c ++ spc () ++ str "because a metavariable has several occurrences." +let explain_meta_in_type c = + str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++ + str " of another meta" + let explain_refiner_error = function | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty | UnresolvedBindings t -> explain_refiner_unresolved_bindings t @@ -580,6 +590,7 @@ let explain_refiner_error = function | IntroNeedsProduct -> explain_intro_needs_product () | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp | NonLinearProof c -> explain_non_linear_proof c + | MetaInType c -> explain_meta_in_type c (* Inductive errors *) @@ -618,8 +629,8 @@ let error_bad_ind_parameters env c n v1 v2 = let pc = pr_lconstr_env_at_top env c in let pv1 = pr_lconstr_env env v1 in let pv2 = pr_lconstr_env env v2 in - str "The " ++ nth n ++ str " argument of " ++ pv2 ++ brk(1,1) ++ - str "must be " ++ pv1 ++ str " in" ++ brk(1,1) ++ pc ++ str "." + str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++ + str " as " ++ nth n ++ str " argument in " ++ brk(1,1) ++ pc ++ str "." let error_same_names_types id = str "The name" ++ spc () ++ pr_id id ++ spc () ++ @@ -640,17 +651,16 @@ let error_not_an_arity id = let error_bad_entry () = str "Bad inductive definition." -let error_not_allowed_case_analysis dep kind i = - str (if dep then "Dependent" else "Non dependent") ++ - str " case analysis on sort: " ++ pr_sort kind ++ fnl () ++ - str "is not allowed for inductive definition: " ++ - pr_inductive (Global.env()) i ++ str "." +let error_large_non_prop_inductive_not_in_type () = + str "Large non-propositional inductive types must be in Type." -let error_bad_induction dep indid kind = - str (if dep then "Dependent" else "Non dependent") ++ - str " induction for type " ++ pr_id indid ++ - str " and sort " ++ pr_sort kind ++ spc () ++ - str "is not allowed." +(* Recursion schemes errors *) + +let error_not_allowed_case_analysis isrec kind i = + str (if isrec then "Induction" else "Case analysis") ++ + strbrk " on sort " ++ pr_sort kind ++ + strbrk " is not allowed for inductive definition " ++ + pr_inductive (Global.env()) i ++ str "." let error_not_mutual_in_scheme ind ind' = if ind = ind' then @@ -674,13 +684,13 @@ let explain_inductive_error = function | SameNamesOverlap idl -> error_same_names_overlap idl | NotAnArity id -> error_not_an_arity id | BadEntry -> error_bad_entry () + | LargeNonPropInductiveNotInType -> error_large_non_prop_inductive_not_in_type () (* Recursion schemes errors *) let explain_recursion_scheme_error = function - | NotAllowedCaseAnalysis (dep,k,i) -> - error_not_allowed_case_analysis dep k i - | BadInduction (dep,indid,kind) -> error_bad_induction dep indid kind + | NotAllowedCaseAnalysis (isrec,k,i) -> + error_not_allowed_case_analysis isrec k i | NotMutualInScheme (ind,ind')-> error_not_mutual_in_scheme ind ind' (* Pattern-matching errors *) diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 89ba6aac..6a75b99c 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: metasyntax.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: metasyntax.ml 11786 2009-01-14 13:07:34Z herbelin $ *) open Pp open Util @@ -281,22 +281,22 @@ let rec find_pattern xl = function error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\".") let rec interp_list_parser hd = function - | [] -> [], List.rev hd + | [] -> [], [], List.rev hd | NonTerminal id :: tl when id = ldots_var -> let ((x,y,sl),tl') = find_pattern [] (hd,tl) in - let yl,tl'' = interp_list_parser [] tl' in - (* We remember the second copy of each recursive part variable to *) - (* remove it afterwards *) - y::yl, SProdList (x,sl) :: tl'' + let yl,xl,tl'' = interp_list_parser [] tl' in + (* We remember each pair of variable denoting a recursive part to *) + (* remove the second copy of it afterwards *) + (y,x)::yl, x::xl, SProdList (x,sl) :: tl'' | (Terminal _ | Break _) as s :: tl -> if hd = [] then - let yl,tl' = interp_list_parser [] tl in - yl, s :: tl' + let yl,xl,tl' = interp_list_parser [] tl in + yl, xl, s :: tl' else interp_list_parser (s::hd) tl | NonTerminal _ as x :: tl -> - let yl,tl' = interp_list_parser [x] tl in - yl, List.rev_append hd tl' + let yl,xl,tl' = interp_list_parser [x] tl in + yl, xl, List.rev_append hd tl' | SProdList _ :: _ -> anomaly "Unexpected SProdList in interp_list_parser" (* Find non-terminal tokens of notation *) @@ -345,10 +345,20 @@ let is_numeral symbs = let analyse_notation_tokens l = let vars,l = raw_analyse_notation_tokens l in - let recvars,l = interp_list_parser [] l in - ((if recvars = [] then [] else ldots_var::recvars), vars, l) - -let remove_vars = List.fold_right List.remove_assoc + let extrarecvars,recvars,l = interp_list_parser [] l in + (if extrarecvars = [] then [], [], vars, l + else extrarecvars, recvars, list_subtract vars recvars, l) + +let remove_extravars extrarecvars (vars,recvars) = + let vars = + List.fold_right (fun (x,y) l -> + if List.assoc x l <> List.assoc y recvars then + error + "Two end variables of a recursive notation are not in the same scope." + else + List.remove_assoc x l) + extrarecvars (List.remove_assoc ldots_var vars) in + (vars,recvars) (**********************************************************************) (* Build pretty-printing rules *) @@ -400,7 +410,7 @@ let is_operator s = let l = String.length s in l <> 0 & (s.[0] = '+' or s.[0] = '*' or s.[0] = '=' or s.[0] = '-' or s.[0] = '/' or s.[0] = '<' or s.[0] = '>' or - s.[0] = '@' or s.[0] = '\\' or s.[0] = '&' or s.[0] = '~') + s.[0] = '@' or s.[0] = '\\' or s.[0] = '&' or s.[0] = '~' or s.[0] = '$') let is_prod_ident = function | Terminal s when is_letter s.[0] or s.[0] = '_' -> true @@ -422,7 +432,7 @@ let make_hunks etyps symbols from = | NonTerminal m :: prods -> let i = list_index m vars in let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in - let u = UnpMetaVar (i ,prec) in + let u = UnpMetaVar (i,prec) in if prods <> [] && is_non_terminal (List.hd prods) then u :: add_break 1 (make CanBreak prods) else @@ -745,7 +755,7 @@ let check_rule_productivity l = error "A recursive notation must start with at least one symbol." let is_not_printable = function - | AVar _ -> warning "This notation won't be used for printing as it is bound to a \nsingle variable"; true + | AVar _ -> warning "This notation will not be used for printing as it is bound to a \nsingle variable"; true | _ -> false let find_precedence lev etyps symbols = @@ -814,7 +824,7 @@ let compute_syntax_data (df,modifiers) = (* Notation defaults to NONA *) let assoc = match assoc with None -> Some Gramext.NonA | a -> a in let toks = split_notation_string df in - let (recvars,vars,symbols) = analyse_notation_tokens toks in + let (extrarecvars,recvars,vars,symbols) = analyse_notation_tokens toks in let ntn_for_interp = make_notation_key symbols in let symbols' = remove_curly_brackets symbols in let need_squash = (symbols <> symbols') in @@ -833,7 +843,7 @@ let compute_syntax_data (df,modifiers) = let prec = (n,List.map (assoc_of_type n) typs) in let sy_data = (ntn_for_grammar,prec,need_squash,(n,typs,symbols',fmt)) in let df' = (Lib.library_dp(),df) in - let i_data = (onlyparse,recvars,vars,(ntn_for_interp,df')) in + let i_data = (onlyparse,extrarecvars,recvars,vars,(ntn_for_interp,df')) in (i_data,sy_data) (**********************************************************************) @@ -939,14 +949,15 @@ let add_notation_in_scope local df c mods scope = let sy_rules = make_syntax_rules sy_data in Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)); (* Declare interpretation *) - let (onlyparse,recvars,vars,df') = i_data in - let (acvars,ac) = interp_aconstr [] vars c in - let a = (remove_vars recvars acvars,ac) (* For recursive parts *) in + let (onlyparse,extrarecvars,recvars,vars,df') = i_data in + let (acvars,ac) = interp_aconstr [] (vars,recvars) c in + let a = (remove_extravars extrarecvars acvars,ac) in let onlyparse = onlyparse or is_not_printable ac in - Lib.add_anonymous_leaf (inNotation(local,scope,a,onlyparse,df')) + Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df')) let add_notation_interpretation_core local df names c scope onlyparse = - let (recs,vars,symbs) = analyse_notation_tokens (split_notation_string df) in + let dfs = split_notation_string df in + let (extrarecvars,recvars,vars,symbs) = analyse_notation_tokens dfs in (* Redeclare pa/pp rules *) if not (is_numeral symbs) then begin let sy_rules = recover_notation_syntax (make_notation_key symbs) in @@ -954,10 +965,10 @@ let add_notation_interpretation_core local df names c scope onlyparse = end; (* Declare interpretation *) let df' = (make_notation_key symbs,(Lib.library_dp(),df)) in - let (acvars,ac) = interp_aconstr names vars c in - let a = (remove_vars recs acvars,ac) (* For recursive parts *) in + let (acvars,ac) = interp_aconstr names (vars,recvars) c in + let a = (remove_extravars extrarecvars acvars,ac) in let onlyparse = onlyparse or is_not_printable ac in - Lib.add_anonymous_leaf (inNotation(local,scope,a,onlyparse,df')) + Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df')) (* Notations without interpretation (Reserved Notation) *) diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index c3bdadfa..fefc0b27 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: metasyntax.mli 9677 2007-02-24 14:17:54Z herbelin $ i*) +(*i $Id: metasyntax.mli 11481 2008-10-20 19:23:51Z herbelin $ i*) (*i*) open Util @@ -56,3 +56,7 @@ val print_grammar : string -> unit (* Removes quotes in a notation *) val standardize_locatable_notation : string -> string + +(* Evaluate whether a notation is not printable *) + +val is_not_printable : aconstr -> bool diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index ac30f890..176f336b 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -11,7 +11,7 @@ * camlp4deps will not work for this file unless Makefile system enhanced. *) -(* $Id: mltop.ml4 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: mltop.ml4 11801 2009-01-18 20:11:41Z herbelin $ *) open Util open Pp @@ -47,8 +47,10 @@ open Vernacinterp (* This path is where we look for .cmo *) let coq_mlpath_copy = ref ["."] -let keep_copy_mlpath path = - coq_mlpath_copy := path :: !coq_mlpath_copy +let keep_copy_mlpath path = + let cpath = canonical_path_name path in + let filter path' = (cpath <> canonical_path_name path') in + coq_mlpath_copy := path :: List.filter filter !coq_mlpath_copy (* If there is a toplevel under Coq *) type toplevel = { @@ -62,17 +64,18 @@ type toplevel = { type kind_load = | WithTop of toplevel | WithoutTop - | Native (* Must be always initialized *) -let load = ref Native +let load = ref WithoutTop -(* Sets and initializes the kind of loading *) -let set kload = load := kload -let get () = !load +(* Are we in a native version of Coq? *) +let is_native = IFDEF Byte THEN false ELSE true END -(* Resets load *) -let remove ()= load := Native +(* Sets and initializes a toplevel (if any) *) +let set_top toplevel = load := WithTop toplevel + +(* Removes the toplevel (if any) *) +let remove ()= load := WithoutTop (* Tests if an Ocaml toplevel runs under Coq *) let is_ocaml_top () = @@ -81,10 +84,7 @@ let is_ocaml_top () = |_ -> false (* Tests if we can load ML files *) -let enable_load () = - match !load with - | WithTop _ | WithoutTop -> true - |_ -> false +let has_dynlink = IFDEF HasDynlink THEN true ELSE false END (* Runs the toplevel loop of Ocaml *) let ocaml_toploop () = @@ -103,24 +103,21 @@ let dir_ml_load s = str s ++ str" to Coq code.")) (* TO DO: .cma loading without toplevel *) | WithoutTop -> - IFDEF Byte THEN + IFDEF HasDynlink THEN (* WARNING * if this code section starts to use a module not used elsewhere * in this file, the Makefile dependency logic needs to be updated. *) - let _,gname = where_in_path true !coq_mlpath_copy s in + let warn = Flags.is_verbose() in + let _,gname = where_in_path ~warn !coq_mlpath_copy s in try Dynlink.loadfile gname; - Dynlink.add_interfaces - [(String.capitalize (Filename.chop_suffix - (Filename.basename gname) ".cmo"))] - [Filename.dirname gname] with | Dynlink.Error a -> errorlabstrm "Mltop.load_object" (str (Dynlink.error_message a)) - ELSE () END - | Native -> - errorlabstrm "Mltop.no_load_object" - (str"Loading of ML object file forbidden in a native Coq.") + ELSE + errorlabstrm "Mltop.no_load_object" + (str"Loading of ML object file forbidden in a native Coq.") + END (* Dynamic interpretation of .ml *) let dir_ml_use s = @@ -132,7 +129,7 @@ let dir_ml_use s = let add_ml_dir s = match !load with | WithTop t -> t.add_dir s; keep_copy_mlpath s - | WithoutTop -> keep_copy_mlpath s + | WithoutTop when has_dynlink -> keep_copy_mlpath s | _ -> () (* For Rec Add ML Path *) @@ -182,15 +179,44 @@ let mod_of_name name = in String.capitalize base -let file_of_name name = - let bname = String.uncapitalize name in - let fname = make_suffix bname ".cmo" in - if (is_in_path !coq_mlpath_copy fname) then fname - else let fname=make_suffix bname ".cma" in - if (is_in_path !coq_mlpath_copy fname) then fname +let get_ml_object_suffix name = + if Filename.check_suffix name ".cmo" then + Some ".cmo" + else if Filename.check_suffix name ".cma" then + Some ".cma" + else if Filename.check_suffix name ".cmxs" then + Some ".cmxs" else + None + +let file_of_name name = + let name = String.uncapitalize name in + let suffix = get_ml_object_suffix name in + let fail s = errorlabstrm "Mltop.load_object" - (str"File not found on loadpath : " ++ str (bname^".cm[oa]")) + (str"File not found on loadpath : " ++ str s) in + if is_native then + let name = match suffix with + | Some ((".cmo"|".cma") as suffix) -> + (Filename.chop_suffix name suffix) ^ ".cmxs" + | Some ".cmxs" -> name + | _ -> name ^ ".cmxs" + in + if is_in_path !coq_mlpath_copy name then name else fail name + else + let (full, base) = match suffix with + | Some ".cmo" | Some ".cma" -> true, name + | Some ".cmxs" -> false, Filename.chop_suffix name ".cmxs" + | _ -> false, name + in + if full then + if is_in_path !coq_mlpath_copy base then base else fail base + else + let name = base ^ ".cmo" in + if is_in_path !coq_mlpath_copy name then name else + let name = base ^ ".cma" in + if is_in_path !coq_mlpath_copy name then name else + fail (base ^ ".cm[oa]") (* TODO: supprimer ce hack, si possible *) (* Initialisation of ML modules that need the state (ex: tactics like @@ -242,7 +268,7 @@ let unfreeze_ml_modules x = (fun name -> let mname = mod_of_name name in if not (module_is_known mname) then - if enable_load() then + if has_dynlink then let fname = file_of_name mname in load_object mname fname else @@ -272,9 +298,9 @@ let cache_ml_module_object (_,{mnames=mnames}) = if_verbose msg (str"[Loading ML file " ++ str fname ++ str" ..."); load_object mname fname; - if_verbose msgnl (str"done]") + if_verbose msgnl (str" done]") with e -> - if_verbose msgnl (str"failed]"); + if_verbose msgnl (str" failed]"); raise e end; add_loaded_module mname) @@ -286,7 +312,9 @@ let (inMLModule,outMLModule) = declare_object {(default_object "ML-MODULE") with load_function = (fun _ -> cache_ml_module_object); cache_function = cache_ml_module_object; - export_function = export_ml_module_object } + export_function = export_ml_module_object; + subst_function = (fun (_,_,o) -> o); + classify_function = (fun (_,o) -> Substitute o) } let declare_ml_modules l = Lib.add_anonymous_leaf (inMLModule {mnames=l}) diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli index b869f70b..875fb423 100644 --- a/toplevel/mltop.mli +++ b/toplevel/mltop.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mltop.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id: mltop.mli 11528 2008-10-31 08:40:42Z glondu $ i*) (* If there is a toplevel under Coq, it is described by the following record. *) @@ -16,25 +16,20 @@ type toplevel = { add_dir : string -> unit; ml_loop : unit -> unit } -(* Determines the behaviour of Coq with respect to ML files (compiled - or not) *) -type kind_load= - | WithTop of toplevel - | WithoutTop - | Native +(* Sets and initializes a toplevel (if any) *) +val set_top : toplevel -> unit -(* Sets and initializes the kind of loading *) -val set : kind_load -> unit -val get : unit -> kind_load +(* Are we in a native version of Coq? *) +val is_native : bool -(* Resets the kind of loading *) +(* Removes the toplevel (if any) *) val remove : unit -> unit (* Tests if an Ocaml toplevel runs under Coq *) val is_ocaml_top : unit -> bool (* Tests if we can load ML files *) -val enable_load : unit -> bool +val has_dynlink : bool (* Starts the Ocaml toplevel loop *) val ocaml_toploop : unit -> unit diff --git a/toplevel/protectedtoplevel.ml b/toplevel/protectedtoplevel.ml index a9ff3326..caf32305 100644 --- a/toplevel/protectedtoplevel.ml +++ b/toplevel/protectedtoplevel.ml @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: protectedtoplevel.ml 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: protectedtoplevel.ml 11784 2009-01-14 11:36:32Z herbelin $ *) open Pp open Line_oriented_parser open Vernac +open Vernacexpr (* The toplevel parsing loop we propose here is more robust to printing errors. The philosophy is that all commands should be individually wrapped @@ -130,7 +131,8 @@ let rec parse_one_command_group input_channel = !global_request_id !count None) | Some(rank, e) -> (match e with - DuringCommandInterp(a,e1) -> + | DuringCommandInterp(a,e1) + | Stdpp.Exc_located (a,DuringSyntaxChecking e1) -> output_results_nl (acknowledge_command !global_request_id rank (Some e1)) @@ -164,7 +166,8 @@ let protected_loop input_chan = | End_of_file -> exit 0 | DuringCommandInterp(loc, Vernacexpr.Quit) -> raise Vernacexpr.Quit | DuringCommandInterp(loc, Vernacexpr.Drop) -> raise Vernacexpr.Drop - | DuringCommandInterp(loc, e) -> + | DuringCommandInterp(loc, e) + | Stdpp.Exc_located (loc,DuringSyntaxChecking e) -> explain_and_restart e | e -> explain_and_restart e in begin diff --git a/toplevel/record.ml b/toplevel/record.ml index 306ab047..4a2ef7db 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: record.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: record.ml 11809 2009-01-20 11:39:55Z aspiwack $ *) open Pp open Util @@ -38,17 +38,23 @@ let interp_evars evdref env ?(impls=([],[])) k typ = let mk_interning_data env na impls typ = let impl = Impargs.compute_implicits_with_manual env typ (Impargs.is_implicit_args()) impls - in (out_name na, ([], impl, Notation.compute_arguments_scope typ)) + in (na, (Constrintern.Method, [], impl, Notation.compute_arguments_scope typ)) -let interp_fields_evars isevars env l = - List.fold_left - (fun (env, uimpls, params, impls) ((loc, i), b, t) -> +let interp_fields_evars isevars env nots l = + List.fold_left2 + (fun (env, uimpls, params, impls) no ((loc, i), b, t) -> let impl, t' = interp_evars isevars env ~impls Pretyping.IsType t in let b' = Option.map (fun x -> snd (interp_evars isevars env ~impls (Pretyping.OfType (Some t')) x)) b in - let data = mk_interning_data env i impl t' in + let impls = + match i with + | Anonymous -> impls + | Name na -> (fst impls, mk_interning_data env na impl t' :: snd impls) + in let d = (i,b',t') in - (push_rel d env, impl :: uimpls, d::params, ([], data :: snd impls))) - (env, [], [], ([], [])) l + (* Temporary declaration of notations and scopes *) + Option.iter (declare_interning_data impls) no; + (push_rel d env, impl :: uimpls, d::params, impls)) + (env, [], [], ([], [])) nots l let binder_of_decl = function | Vernacexpr.AssumExpr(n,t) -> (n,None,t) @@ -56,18 +62,21 @@ let binder_of_decl = function let binders_of_decls = List.map binder_of_decl -let typecheck_params_and_fields id t ps fs = +let typecheck_params_and_fields id t ps nots fs = let env0 = Global.env () in - let (env1,newps), imps = interp_context Evd.empty env0 ps in - let fullarity = it_mkProd_or_LetIn t newps in - let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in let evars = ref (Evd.create_evar_defs Evd.empty) in + let (env1,newps), imps = interp_context_evars ~fail_anonymous:false evars env0 ps in + let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (new_Type ()) t) newps in + let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in let env2,impls,newfs,data = - interp_fields_evars evars env_ar (binders_of_decls fs) + interp_fields_evars evars env_ar nots (binders_of_decls fs) in - let newps = Evarutil.nf_rel_context_evar (Evd.evars_of !evars) newps in - let newfs = Evarutil.nf_rel_context_evar (Evd.evars_of !evars) newfs in - let ce t = Evarutil.check_evars env0 Evd.empty !evars t in + let evars,_ = Evarconv.consider_remaining_unif_problems env_ar !evars in + let evars = Typeclasses.resolve_typeclasses env_ar evars in + let sigma = Evd.evars_of evars in + 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; imps, newps, impls, newfs @@ -198,8 +207,7 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls raise (NotDefinable (BadTypedProj (fid,ctx,te))) in let refi = ConstRef kn in let constr_fi = mkConst kn in - Impargs.maybe_declare_manual_implicits - false refi (Impargs.is_implicit_args()) impls; + Impargs.maybe_declare_manual_implicits false refi impls; if coe then begin let cl = Class.class_of_global (IndRef indsp) in Class.try_add_new_coercion_with_source refi Global cl @@ -210,11 +218,11 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls with NotDefinable why -> warning_or_error coe indsp why; (None::sp_projs,NoProjection fi::subst) in - (nfi-1,(optci=None)::kinds,sp_projs,subst)) + (nfi-1,(fi, optci=None)::kinds,sp_projs,subst)) (List.length fields,[],[],[]) coers (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) -let declare_structure id idbuild paramimpls params arity fieldimpls fields +let declare_structure finite id idbuild paramimpls params arity fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers = let nparams = List.length params and nfields = List.length fields in let args = extended_rel_list nfields params in @@ -224,26 +232,130 @@ let declare_structure id idbuild paramimpls params arity fieldimpls fields { mind_entry_typename = id; mind_entry_arity = arity; mind_entry_consnames = [idbuild]; - mind_entry_lc = [type_constructor] } in - let declare_as_coind = - (* CoInd if recursive; otherwise Ind to have compat on _ind schemes *) - dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) in + mind_entry_lc = [type_constructor] } + in + (* spiwack: raises an error if the structure is supposed to be non-recursive, + but isn't *) + (* there is probably a way to push this to "declare_mutual" *) + begin match finite with + | BiFinite -> + if 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." + | _ -> () + end; let mie = { mind_entry_params = List.map degenerate_decl params; mind_entry_record = true; - mind_entry_finite = not declare_as_coind; + mind_entry_finite = recursivity_flag_of_kind finite; mind_entry_inds = [mie_ind] } in let kn = Command.declare_mutual_with_eliminations true mie [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) let kinds,sp_projs = declare_projections rsp ~kind ?name coers fieldimpls fields in let build = ConstructRef (rsp,1) in if is_coe then Class.try_add_new_coercion build Global; - Recordops.declare_structure(rsp,idbuild,List.rev kinds,List.rev sp_projs); - kn + Recordops.declare_structure(rsp,(rsp,1),List.rev kinds,List.rev sp_projs); + kn,0 + +let implicits_of_context ctx = + list_map_i (fun i name -> + let explname = + match name with + | Name n -> Some n + | Anonymous -> None + in ExplByPos (i, explname), (true, true)) + 1 (List.rev (Anonymous :: (List.map pi1 ctx))) + +open Typeclasses + +let typeclasses_db = "typeclass_instances" + +let qualid_of_con c = + Qualid (dummy_loc, shortest_qualid_of_global Idset.empty (ConstRef c)) + +let set_rigid c = + Auto.add_hints false [typeclasses_db] + (Vernacexpr.HintsTransparency ([qualid_of_con c], false)) + +let declare_instance_cst glob con = + let instance = Typeops.type_of_constant (Global.env ()) con in + let _, r = Sign.decompose_prod_assum instance in + match class_of_constr r with + | Some tc -> add_instance (new_instance tc None glob con) + | None -> errorlabstrm "" (Pp.strbrk "Constant does not build instances of a declared type class.") + +let declare_class finite def id idbuild paramimpls params arity fieldimpls fields + ?(kind=StructureComponent) ?name is_coe coers = + let fieldimpls = + (* Make the class and all params implicits in the projections *) + let ctx_impls = implicits_of_context params in + let len = succ (List.length params) in + List.map (fun x -> ctx_impls @ Impargs.lift_implicits len x) fieldimpls + in + let impl, projs = + match fields with + | [(Name proj_name, _, field)] when def -> + let class_body = it_mkLambda_or_LetIn field params in + let class_type = Option.map (fun ar -> it_mkProd_or_LetIn ar params) arity in + let class_entry = + { const_entry_body = class_body; + const_entry_type = class_type; + const_entry_opaque = false; + const_entry_boxed = false } + in + let cst = Declare.declare_constant (snd id) + (DefinitionEntry class_entry, IsDefinition Definition) + in + let inst_type = appvectc (mkConst cst) (rel_vect 0 (List.length params)) in + let proj_type = it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in + let proj_body = it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in + let proj_entry = + { const_entry_body = proj_body; + const_entry_type = Some proj_type; + const_entry_opaque = false; + const_entry_boxed = false } + in + let proj_cst = Declare.declare_constant proj_name + (DefinitionEntry proj_entry, IsDefinition Definition) + in + let cref = ConstRef cst in + Impargs.declare_manual_implicits false cref paramimpls; + Impargs.declare_manual_implicits false (ConstRef proj_cst) (List.hd fieldimpls); + set_rigid cst; (* set_rigid proj_cst; *) + cref, [proj_name, Some proj_cst] + | _ -> + let idarg = Nameops.next_ident_away (snd id) (ids_of_context (Global.env())) in + let ind = declare_structure BiFinite (snd id) idbuild paramimpls + params (Option.cata (fun x -> x) (new_Type ()) arity) fieldimpls fields + ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields) + in + (* List.iter (Option.iter (declare_interning_data ((),[]))) notations; *) + IndRef ind, (List.map2 (fun (id, _, _) y -> (Nameops.out_name id, y)) + (List.rev fields) (Recordops.lookup_projections ind)) + in + let ctx_context = + List.map (fun (na, b, t) -> + match Typeclasses.class_of_constr t with + | Some cl -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*) + | None -> None) + params, params + in + let k = + { cl_impl = impl; + cl_context = ctx_context; + cl_props = fields; + cl_projs = projs } + in + List.iter2 (fun p sub -> + if sub then match snd p with Some p -> declare_instance_cst true p | None -> ()) + k.cl_projs coers; + add_class k; impl + +open Vernacexpr (* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean list telling if the corresponding fields must me declared as coercion *) -let definition_structure ((is_coe,(_,idstruc)),ps,cfs,idbuild,s) = +let definition_structure (kind,finite,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = + let cfs,notations = List.split cfs in let coers,fs = List.split cfs in let extract_name acc = function Vernacexpr.AssumExpr((_,Name id),_) -> id::acc @@ -252,8 +364,16 @@ let definition_structure ((is_coe,(_,idstruc)),ps,cfs,idbuild,s) = let allnames = idstruc::(List.fold_left extract_name [] fs) in if not (list_distinct allnames) then error "Two objects have the same name"; (* Now, younger decl in params and fields is on top *) - let implpars, params, implfs, fields = typecheck_params_and_fields idstruc (mkSort s) ps fs in - let implfs = List.map - (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs in - declare_structure idstruc idbuild implpars params (mkSort s) implfs fields is_coe coers - + let sc = Option.map mkSort s in + let implpars, params, implfs, fields = + States.with_heavy_rollback (fun () -> + typecheck_params_and_fields idstruc sc ps notations fs) () + in + match kind with + | Class b -> + declare_class finite b (loc,idstruc) idbuild implpars params sc implfs fields is_coe coers + | _ -> + let arity = Option.cata (fun x -> x) (new_Type ()) sc in + let implfs = List.map + (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs + in IndRef (declare_structure finite idstruc idbuild implpars params arity implfs fields is_coe coers) diff --git a/toplevel/record.mli b/toplevel/record.mli index 48181437..b49c26bc 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: record.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: record.mli 11809 2009-01-20 11:39:55Z aspiwack $ i*) (*i*) open Names @@ -15,6 +15,7 @@ open Sign open Vernacexpr open Topconstr open Impargs +open Libnames (*i*) (* [declare_projections ref name coers params fields] declare projections of @@ -24,17 +25,17 @@ open Impargs val declare_projections : inductive -> ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> bool list -> manual_explicitation list list -> rel_context -> - bool list * constant option list + (name * bool) list * constant option list -val declare_structure : identifier -> identifier -> - manual_explicitation list -> rel_context -> (* params *) - Term.constr -> (* arity *) +val declare_structure : Decl_kinds.recursivity_kind -> + identifier -> identifier -> + manual_explicitation list -> rel_context -> (* params *) constr -> (* arity *) Impargs.manual_explicitation list list -> Sign.rel_context -> (* fields *) ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> bool -> (* coercion? *) bool list -> (* field coercions *) - mutual_inductive + inductive val definition_structure : - lident with_coercion * local_binder list * - (local_decl_expr with_coercion) list * identifier * sorts -> kernel_name + inductive_kind*Decl_kinds.recursivity_kind *lident with_coercion * local_binder list * + (local_decl_expr with_coercion with_notation) list * identifier * sorts option -> global_reference diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml index 8a9ef501..a1acd1d6 100644 --- a/toplevel/toplevel.ml +++ b/toplevel/toplevel.ml @@ -6,13 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: toplevel.ml 11317 2008-08-07 15:52:38Z barras $ *) +(* $Id: toplevel.ml 11784 2009-01-14 11:36:32Z herbelin $ *) open Pp open Util open Flags open Cerrors open Vernac +open Vernacexpr open Pcoq open Protectedtoplevel @@ -262,6 +263,7 @@ let rec is_pervasive_exn = function | Error_in_file (_,_,e) -> is_pervasive_exn e | Stdpp.Exc_located (_,e) -> is_pervasive_exn e | DuringCommandInterp (_,e) -> is_pervasive_exn e + | DuringSyntaxChecking e -> is_pervasive_exn e | _ -> false (* Toplevel error explanation, dealing with locations, Drop, Ctrl-D @@ -270,7 +272,8 @@ let rec is_pervasive_exn = function let print_toplevel_error exc = let (dloc,exc) = match exc with - | DuringCommandInterp (loc,ie) -> + | DuringCommandInterp (loc,ie) + | Stdpp.Exc_located (loc, DuringSyntaxChecking ie) -> if loc = dummy_loc then (None,ie) else (Some loc, ie) | _ -> (None, exc) in @@ -321,7 +324,8 @@ let rec discard_to_dot () = * in encountered. *) let process_error = function - | DuringCommandInterp _ as e -> e + | DuringCommandInterp _ + | Stdpp.Exc_located (_,DuringSyntaxChecking _) as e -> e | e -> if is_pervasive_exn e then e diff --git a/toplevel/usage.ml b/toplevel/usage.ml index b0b0f826..96ff8cbc 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -6,12 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: usage.ml 11209 2008-07-05 10:17:49Z herbelin $ *) +(* $Id: usage.ml 11858 2009-01-26 13:27:23Z notin $ *) let version () = Printf.printf "The Coq Proof Assistant, version %s (%s)\n" Coq_config.version Coq_config.date; - Printf.printf "compiled on %s\n" Coq_config.compile_date; + Printf.printf "compiled on %s with OCaml %s\n" Coq_config.compile_date Coq_config.caml_version; exit 0 (* print the usage of coqtop (or coqc) on channel co *) @@ -57,6 +57,7 @@ let print_usage_channel co command = -batch batch mode (exits just after arguments parsing) -boot boot mode (implies -q and -batch) -emacs tells Coq it is executed under Emacs + -noglob f do not dump globalizations -dump-glob f dump globalizations in file f (to be used by coqdoc) -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes) -impredicative-set set sort Set impredicative @@ -80,6 +81,18 @@ let print_usage_coqc () = print_usage "Usage: coqc file...\n options are: -verbose compile verbosely - -bindir override the default directory where coqc looks for coqtop -image f specify an alternative executable for Coq -t keep temporary files\n\n" + +(* Print the configuration information *) + +let print_config () = + if Coq_config.local then Printf.printf "LOCAL=1\n" else Printf.printf "LOCAL=0\n"; + Printf.printf "COQLIB=%s/\n" Coq_config.coqlib; + Printf.printf "COQSRC=%s/\n" Coq_config.coqsrc; + Printf.printf "CAMLBIN=%s/\n" Coq_config.camlbin; + Printf.printf "CAMLLIB=%s/\n" Coq_config.camllib; + Printf.printf "CAMLP4=%s\n" Coq_config.camlp4; + Printf.printf "CAMLP4BIN=%s\n" Coq_config.camlp4bin; + Printf.printf "CAMLP4LIB=%s\n" Coq_config.camlp4lib + diff --git a/toplevel/usage.mli b/toplevel/usage.mli index 97814fd2..0ee58f4d 100644 --- a/toplevel/usage.mli +++ b/toplevel/usage.mli @@ -6,15 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: usage.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id: usage.mli 11830 2009-01-22 06:45:13Z notin $ i*) (*s Prints the version number on the standard output and exits (with 0). *) val version : unit -> 'a -(*s Prints the usage on the error output, preceeded by a user-provided message. *) +(*s Prints the usage on the error output, preceded by a user-provided message. *) val print_usage : string -> unit (*s Prints the usage on the error output. *) val print_usage_coqtop : unit -> unit val print_usage_coqc : unit -> unit + +(*s Prints the configuration information. *) +val print_config : unit -> unit diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index c331c13b..c5549503 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: vernac.ml 10836 2008-04-23 11:43:58Z courtieu $ *) +(* $Id: vernac.ml 11801 2009-01-18 20:11:41Z herbelin $ *) (* Parsing of vernacular. *) @@ -32,7 +32,8 @@ exception DuringCommandInterp of Util.loc * exn let raise_with_file file exc = let (cmdloc,re) = match exc with - | DuringCommandInterp(loc,e) -> (loc,e) + | DuringCommandInterp(loc,e) + | Stdpp.Exc_located (loc,DuringSyntaxChecking e) -> (loc,e) | e -> (dummy_loc,e) in let (inner,inex) = @@ -56,7 +57,9 @@ let real_error = function the file we parse seems a bit risky to me. B.B. *) let open_file_twice_if verbosely fname = - let _,longfname = find_file_in_path (Library.get_load_paths ()) fname in + 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 po = Pcoq.Gram.parsable (Stream.of_channel in_chan) in @@ -93,23 +96,24 @@ let parse_phrase (po, verbch) = * parses, and is verbose on "primitives" commands if verbosely is true *) let just_parsing = ref false -let chan_translate = ref stdout +let chan_beautify = ref stdout +let beautify_suffix = ".beautified" let set_formatter_translator() = - let ch = !chan_translate in + let ch = !chan_beautify in let out s b e = output ch s b e in Format.set_formatter_output_functions out (fun () -> flush ch); Format.set_max_boxes max_int let pr_new_syntax loc ocom = let loc = unloc loc in - if !translate_file then set_formatter_translator(); + if !beautify_file then set_formatter_translator(); let fs = States.freeze () in let com = match ocom with | Some VernacNop -> mt() | Some com -> pr_vernac com | None -> mt() in - if !translate_file then + if !beautify_file then msg (hov 0 (comment (fst loc) ++ com ++ comment (snd loc))) else msgnl (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); @@ -121,33 +125,34 @@ let rec vernac_com interpfun (loc,com) = | VernacLoad (verbosely, fname) -> let fname = expand_path_macros fname in (* translator state *) - let ch = !chan_translate in + let ch = !chan_beautify in let cs = Lexer.com_state() in let cl = !Pp.comments in (* end translator state *) (* coqdoc state *) - let cds = Constrintern.coqdoc_freeze() in - if !Flags.translate_file then + let cds = Dumpglob.coqdoc_freeze() in + if !Flags.beautify_file then begin - let _,f = find_file_in_path (Library.get_load_paths ()) + let _,f = find_file_in_path ~warn:(Flags.is_verbose()) + (Library.get_load_paths ()) (make_suffix fname ".v") in - chan_translate := open_out (f^"8"); + chan_beautify := open_out (f^beautify_suffix); Pp.comments := [] end; begin try read_vernac_file verbosely (make_suffix fname ".v"); - if !Flags.translate_file then close_out !chan_translate; - chan_translate := ch; + if !Flags.beautify_file then close_out !chan_beautify; + chan_beautify := ch; Lexer.restore_com_state cs; Pp.comments := cl; - Constrintern.coqdoc_unfreeze cds + Dumpglob.coqdoc_unfreeze cds with e -> - if !Flags.translate_file then close_out !chan_translate; - chan_translate := ch; + if !Flags.beautify_file then close_out !chan_beautify; + chan_beautify := ch; Lexer.restore_com_state cs; Pp.comments := cl; - Constrintern.coqdoc_unfreeze cds; + Dumpglob.coqdoc_unfreeze cds; raise e end @@ -164,7 +169,7 @@ let rec vernac_com interpfun (loc,com) = in try - if do_translate () then pr_new_syntax loc (Some com); + if do_beautify () then pr_new_syntax loc (Some com); interp com with e -> Format.set_formatter_out_channel stdout; @@ -191,7 +196,7 @@ and read_vernac_file verbosely s = close_input in_chan input; (* we must close the file first *) match real_error e with | End_of_input -> - if do_translate () then pr_new_syntax (make_loc (max_int,max_int)) None + if do_beautify () then pr_new_syntax (make_loc (max_int,max_int)) None | _ -> raise_with_file fname e (* raw_do_vernac : char Stream.t -> unit @@ -214,23 +219,26 @@ let set_xml_end_library f = xml_end_library := f (* Load a vernac file. Errors are annotated with file and location *) let load_vernac verb file = - chan_translate := - if !Flags.translate_file then open_out (file^"8") else stdout; + chan_beautify := + if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout; try read_vernac_file verb file; - if !Flags.translate_file then close_out !chan_translate; + if !Flags.beautify_file then close_out !chan_beautify; with e -> - if !Flags.translate_file then close_out !chan_translate; + if !Flags.beautify_file then close_out !chan_beautify; raise_with_file file e (* Compile a vernac file (f is assumed without .v suffix) *) let compile verbosely f = - let ldir,long_f_dot_v = Library.start_library f in - if !dump then dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n"); - if !Flags.xml_export then !xml_start_library (); - let _ = load_vernac verbosely long_f_dot_v in - if Pfedit.get_all_proof_names () <> [] then - (message "Error: There are pending proofs"; exit 1); - if !Flags.xml_export then !xml_end_library (); - Library.save_library_to ldir (long_f_dot_v ^ "o") + let ldir,long_f_dot_v = Flags.verbosely Library.start_library f in + if Dumpglob.multi_dump () then + Dumpglob.open_glob_file (f ^ ".glob"); + Dumpglob.dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n"); + if !Flags.xml_export then !xml_start_library (); + let _ = load_vernac verbosely long_f_dot_v in + if Pfedit.get_all_proof_names () <> [] then + (message "Error: There are pending proofs"; exit 1); + if !Flags.xml_export then !xml_end_library (); + if Dumpglob.multi_dump () then Dumpglob.close_glob_file (); + Library.save_library_to ldir (long_f_dot_v ^ "o") diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 3f474239..c95c89d3 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: vernacentries.ml 11313 2008-08-07 11:15:03Z barras $ i*) +(*i $Id: vernacentries.ml 11809 2009-01-20 11:39:55Z aspiwack $ i*) (* Concrete syntax of the mathematical vernacular MV V2.6 *) @@ -182,8 +182,11 @@ let show_match id = let print_path_entry (s,l) = (str (string_of_dirpath l) ++ str " " ++ tbrk (0,0) ++ str s) -let print_loadpath () = +let print_loadpath dir = let l = Library.get_full_load_paths () in + let l = match dir with + | None -> l + | Some dir -> List.filter (fun (s,l) -> is_dirpath_prefix_of dir l) l in msgnl (Pp.t (str "Logical Path: " ++ tab () ++ str "Physical path:" ++ fnl () ++ prlist_with_sep pr_fnl print_path_entry l)) @@ -232,7 +235,7 @@ let dump_universes s = let locate_file f = try - let _,file = System.where_in_path false (Library.get_load_paths ()) f in + let _,file = System.where_in_path ~warn:false (Library.get_load_paths ()) f in msgnl (str file) with Not_found -> msgnl (hov 0 (str"Can't find file" ++ spc () ++ str f ++ spc () ++ @@ -277,7 +280,7 @@ let print_located_module r = let global_with_alias r = let gr = global_with_alias r in - if !Flags.dump then Constrintern.add_glob (loc_of_reference r) gr; + Dumpglob.add_glob (loc_of_reference r) gr; gr (**********) @@ -307,49 +310,31 @@ let start_proof_and_print k l hook = print_subgoals (); if !pcoq <> None then (Option.get !pcoq).start_proof () -let current_dirpath sec = - drop_dirpath_prefix (Lib.library_dp ()) - (if sec then Lib.cwd () - else extract_dirpath_prefix (Lib.sections_depth ()) (Lib.cwd ())) - -let dump_definition (loc, id) sec s = - Flags.dump_string (Printf.sprintf "%s %d %s %s\n" s (fst (unloc loc)) - (string_of_dirpath (current_dirpath sec)) (string_of_id id)) - -let dump_reference loc modpath ident ty = - dump_string (Printf.sprintf "R%d %s %s %s %s\n" - (fst (unloc loc)) (string_of_dirpath (Lib.library_dp ())) modpath ident ty) - -let dump_constraint ((loc, n), _, _) sec ty = - match n with - | Name id -> dump_definition (loc, id) sec ty - | Anonymous -> () - -let vernac_definition (local,_,_ as k) (_,id as lid) def hook = - if !Flags.dump then dump_definition lid false "def"; - match def with - | ProveBody (bl,t) -> (* local binders, typ *) - if Lib.is_modtype () then - errorlabstrm "Vernacentries.VernacDefinition" - (str "Proof editing mode not supported in module types.") - else - let hook _ _ = () in - start_proof_and_print (local,DefinitionBody Definition) - [Some lid,(bl,t)] hook - | DefineBody (bl,red_option,c,typ_opt) -> - let red_option = match red_option with - | None -> None - | Some r -> - let (evc,env)= Command.get_current_context () in - Some (interp_redexp env evc r) in - declare_definition id k bl red_option c typ_opt hook - +let vernac_definition (local,_,_ as k) (loc,id as lid) def hook = + Dumpglob.dump_definition lid false "def"; + (match def with + | ProveBody (bl,t) -> (* local binders, typ *) + if Lib.is_modtype () then + errorlabstrm "Vernacentries.VernacDefinition" + (str "Proof editing mode not supported in module types") + else + let hook _ _ = () in + start_proof_and_print (local,DefinitionBody Definition) + [Some lid, (bl,t)] hook + | DefineBody (bl,red_option,c,typ_opt) -> + let red_option = match red_option with + | None -> None + | Some r -> + let (evc,env)= Command.get_current_context () in + Some (interp_redexp env evc r) in + declare_definition id k bl red_option c typ_opt hook) + let vernac_start_proof kind l lettop hook = - if !Flags.dump then + if Dumpglob.dump () then List.iter (fun (id, _) -> match id with - | Some lid -> dump_definition lid false "prf" - | None -> ()) l; + | Some lid -> Dumpglob.dump_definition lid false "prf" + | None -> ()) l; if not(refining ()) then if lettop then errorlabstrm "Vernacentries.StartProof" @@ -383,28 +368,75 @@ let vernac_exact_proof c = let vernac_assumption kind l nl= let global = fst kind = Global in - List.iter (fun (is_coe,(idl,c)) -> - if !dump then - List.iter (fun lid -> - if global then dump_definition lid false "ax" - else dump_definition lid true "var") idl; - declare_assumption idl is_coe kind [] c false false nl) l - -let vernac_inductive f indl = - if !dump then - List.iter (fun ((lid, _, _, cstrs), _) -> - dump_definition lid false"ind"; - List.iter (fun (_, (lid, _)) -> - dump_definition lid false "constr") cstrs) - indl; - build_mutual indl f + List.iter (fun (is_coe,(idl,c)) -> + if Dumpglob.dump () then + List.iter (fun lid -> + if global then Dumpglob.dump_definition lid false "ax" + else Dumpglob.dump_definition lid true "var") idl; + declare_assumption idl is_coe kind [] c false false nl) l + +let vernac_record k finite struc binders sort nameopt cfs = + let const = match nameopt with + | None -> add_prefix "Build_" (snd (snd struc)) + | Some (_,id as lid) -> + Dumpglob.dump_definition lid false "constr"; id in + let sigma = Evd.empty in + let env = Global.env() in + let s = Option.map (fun x -> + let s = Reductionops.whd_betadeltaiota env sigma (interp_constr sigma env x) in + match kind_of_term s with + | Sort s -> s + | _ -> user_err_loc + (constr_loc x,"definition_structure", str "Sort expected.")) sort + in + if Dumpglob.dump () then ( + Dumpglob.dump_definition (snd struc) false "rec"; + List.iter (fun ((_, x), _) -> + match x with + | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" + | _ -> ()) cfs); + ignore(Record.definition_structure (k,finite,struc,binders,cfs,const,s)) + +let vernac_inductive finite indl = + if Dumpglob.dump () then + List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> + match cstrs with + | Constructors cstrs -> + Dumpglob.dump_definition lid false "ind"; + List.iter (fun (_, (lid, _)) -> + Dumpglob.dump_definition lid false "constr") cstrs + | _ -> () (* dumping is done by vernac_record (called below) *) ) + indl; + match indl with + | [ ( id , bl , c , b, RecordDecl (oc,fs) ), None ] -> + vernac_record (match b with Class true -> Class false | _ -> b) + finite id bl c oc fs + | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> + let f = + let (coe, ((loc, id), ce)) = l in + ((coe, AssumExpr ((loc, Name id), ce)), None) + in vernac_record (Class true) finite id bl c None [f] + | [ ( id , bl , c , Class true, _), _ ] -> + Util.error "Definitional classes must have a single method" + | [ ( id , bl , c , Class false, Constructors _), _ ] -> + Util.error "Inductive classes not supported" + | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> + Util.error "where clause not supported for (co)inductive records" + | _ -> let unpack = function + | ( (_, id) , bl , c , _ , Constructors l ) , ntn -> ( id , bl , c , l ) , ntn + | _ -> Util.error "Cannot handle mutually (co)inductive records." + in + let indl = List.map unpack indl in + Command.build_mutual indl (recursivity_flag_of_kind finite) let vernac_fixpoint l b = - List.iter (fun ((lid, _, _, _, _), _) -> dump_definition lid false "def") l; + if Dumpglob.dump () then + List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; build_recursive l b let vernac_cofixpoint l b = - List.iter (fun ((lid, _, _, _), _) -> dump_definition lid false "def") l; + if Dumpglob.dump () then + List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; build_corecursive l b let vernac_scheme = build_scheme @@ -415,9 +447,11 @@ let vernac_combined_scheme = build_combined_scheme (* Modules *) let vernac_import export refl = - let import ref = Library.import_module export (qualid_of_reference ref) in - List.iter import refl; - Lib.add_frozen_state () + let import ref = + Library.import_module export (qualid_of_reference ref) + in + List.iter import refl; + Lib.add_frozen_state () let vernac_declare_module export (loc, id) binders_ast mty_ast_o = (* We check the state of the system (in section, in module type) @@ -435,9 +469,9 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast_o = Modintern.interp_modtype Modintern.interp_modexpr id binders_ast (Some mty_ast_o) None in - Modintern.dump_moddef loc mp "mod"; - if_verbose message ("Module "^ string_of_id id ^" is declared"); - Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export + Dumpglob.dump_moddef loc mp "mod"; + if_verbose message ("Module "^ string_of_id id ^" is declared"); + Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = (* We check the state of the system (in section, in module type) @@ -455,7 +489,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = let mp = Declaremods.start_module Modintern.interp_modtype export id binders_ast mty_ast_o in - Modintern.dump_moddef loc mp "mod"; + Dumpglob.dump_moddef loc mp "mod"; if_verbose message ("Interactive Module "^ string_of_id id ^" started") ; List.iter @@ -475,7 +509,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = Modintern.interp_modtype Modintern.interp_modexpr id binders_ast mty_ast_o mexpr_ast_o in - Modintern.dump_moddef loc mp "mod"; + Dumpglob.dump_moddef loc mp "mod"; if_verbose message ("Module "^ string_of_id id ^" is defined"); Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) @@ -483,9 +517,9 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = let vernac_end_module export (loc,id) = let mp = Declaremods.end_module id in - Modintern.dump_modref loc mp "mod"; - if_verbose message ("Module "^ string_of_id id ^" is defined") ; - Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export + Dumpglob.dump_modref loc mp "mod"; + if_verbose message ("Module "^ string_of_id id ^" is defined") ; + Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export let vernac_declare_module_type (loc,id) binders_ast mty_ast_o = @@ -501,7 +535,7 @@ let vernac_declare_module_type (loc,id) binders_ast mty_ast_o = (idl,ty)::args, List.map (fun (_,i) -> export,i) idl) binders_ast ([],[]) in let mp = Declaremods.start_modtype Modintern.interp_modtype id binders_ast in - Modintern.dump_moddef loc mp "modtype"; + Dumpglob.dump_moddef loc mp "modtype"; if_verbose message ("Interactive Module Type "^ string_of_id id ^" started"); List.iter @@ -511,25 +545,25 @@ let vernac_declare_module_type (loc,id) binders_ast mty_ast_o = ) argsexport | Some base_mty -> - let binders_ast = List.map - (fun (export,idl,ty) -> - if export <> None then - error ("Arguments of a functor definition can be imported only if" ^ - " the definition is interactive. Remove the \"Export\" " ^ - "and \"Import\" keywords from every functor argument.") - else (idl,ty)) binders_ast in - let mp = Declaremods.declare_modtype Modintern.interp_modtype + let binders_ast = List.map + (fun (export,idl,ty) -> + if export <> None then + error ("Arguments of a functor definition can be imported only if" ^ + " the definition is interactive. Remove the \"Export\" " ^ + "and \"Import\" keywords from every functor argument.") + else (idl,ty)) binders_ast in + let mp = Declaremods.declare_modtype Modintern.interp_modtype id binders_ast base_mty in - Modintern.dump_moddef loc mp "modtype"; - if_verbose message - ("Module Type "^ string_of_id id ^" is defined") + Dumpglob.dump_moddef loc mp "modtype"; + if_verbose message + ("Module Type "^ string_of_id id ^" is defined") let vernac_end_modtype (loc,id) = let mp = Declaremods.end_modtype id in - Modintern.dump_modref loc mp "modtype"; - if_verbose message - ("Module Type "^ string_of_id id ^" is defined") + Dumpglob.dump_modref loc mp "modtype"; + if_verbose message + ("Module Type "^ string_of_id id ^" is defined") let vernac_include = function | CIMTE mty_ast -> @@ -541,39 +575,18 @@ let vernac_include = function (**********************) (* Gallina extensions *) - -let vernac_record struc binders sort nameopt cfs = - let const = match nameopt with - | None -> add_prefix "Build_" (snd (snd struc)) - | Some (_,id as lid) -> - if !dump then dump_definition lid false "constr"; id in - let sigma = Evd.empty in - let env = Global.env() in - let s = interp_constr sigma env sort in - let s = Reductionops.whd_betadeltaiota env sigma s in - let s = match kind_of_term s with - | Sort s -> s - | _ -> user_err_loc - (constr_loc sort,"definition_structure", str "Sort expected.") in - if !dump then ( - dump_definition (snd struc) false "rec"; - List.iter (fun (_, x) -> - match x with - | AssumExpr ((loc, Name id), _) -> dump_definition (loc,id) false "proj" - | _ -> ()) cfs); - ignore(Record.definition_structure (struc,binders,cfs,const,s)) (* Sections *) let vernac_begin_section (_, id as lid) = check_no_pending_proofs (); - if !Flags.dump then dump_definition lid true "sec"; + Dumpglob.dump_definition lid true "sec"; Lib.open_section id let vernac_end_section (loc, id) = - if !Flags.dump then - dump_reference loc - (string_of_dirpath (current_dirpath true)) "<>" "sec"; + + Dumpglob.dump_reference loc + (string_of_dirpath (Lib.current_dirpath true)) "<>" "sec"; Lib.close_section id let vernac_end_segment lid = @@ -588,6 +601,10 @@ let vernac_end_segment lid = let vernac_require import _ qidl = let qidl = List.map qualid_of_reference qidl in + if Dumpglob.dump () then begin + let modrefl = Flags.silently (List.map Library.try_locate_qualified_library) qidl in + List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl) + end; Library.require_library qidl import let vernac_canonical r = @@ -606,21 +623,17 @@ let vernac_identity_coercion stre id qids qidt = Class.try_add_new_identity_coercion id stre source target (* Type classes *) -let vernac_class id par ar sup props = - if !dump then ( - dump_definition id false "class"; - List.iter (fun (lid, _, _) -> dump_definition lid false "meth") props); - Classes.new_class id par ar sup props let vernac_instance glob sup inst props pri = - if !dump then dump_constraint inst false "inst"; + Dumpglob.dump_constraint inst false "inst"; ignore(Classes.new_instance ~global:glob sup inst props pri) let vernac_context l = + List.iter (fun x -> Dumpglob.dump_local_binder x true "var") l; Classes.context l let vernac_declare_instance id = - if !dump then dump_definition id false "inst"; + Dumpglob.dump_definition id false "inst"; Classes.declare_instance false id (***********) @@ -752,15 +765,18 @@ let vernac_backto n = Lib.reset_label n let vernac_declare_tactic_definition = Tacinterp.add_tacdef +let vernac_create_hintdb local id b = + Auto.create_hint_db local id full_transparent_state b + let vernac_hints = Auto.add_hints let vernac_syntactic_definition lid = - dump_definition lid false "syndef"; + Dumpglob.dump_definition lid false "syndef"; Command.syntax_definition (snd lid) let vernac_declare_implicits local r = function | Some imps -> - Impargs.declare_manual_implicits local (global_with_alias r) false + Impargs.declare_manual_implicits local (global_with_alias r) ~enriching:false (List.map (fun (ex,b,f) -> ex, (b,f)) imps) | None -> Impargs.declare_implicits local (global_with_alias r) @@ -1059,7 +1075,7 @@ let vernac_print = function | PrintSectionContext qid -> msg (print_sec_context_typ qid) | PrintInspect n -> msg (inspect n) | PrintGrammar ent -> Metasyntax.print_grammar ent - | PrintLoadPath -> (* For compatibility ? *) print_loadpath () + | PrintLoadPath dir -> (* For compatibility ? *) print_loadpath dir | PrintModules -> msg (print_modules ()) | PrintModule qid -> print_module qid | PrintModuleType qid -> print_modtype qid @@ -1085,7 +1101,6 @@ let vernac_print = function | PrintHintDbName s -> Auto.print_hint_db_by_name s | PrintRewriteHintDbName s -> Autorewrite.print_rewrite_hintdb s | PrintHintDb -> Auto.print_searchtable () - | PrintSetoids -> Setoid_replace.print_setoids() | PrintScopes -> pp (Notation.pr_scopes (Constrextern.without_symbols pr_lrawconstr)) | PrintScope s -> @@ -1113,24 +1128,38 @@ let interp_search_restriction = function open Search +let is_ident s = try ignore (check_ident s); true with UserError _ -> false + let interp_search_about_item = function - | SearchRef r -> GlobSearchRef (global_with_alias r) - | SearchString s -> GlobSearchString s + | SearchSubPattern pat -> + let _,pat = intern_constr_pattern Evd.empty (Global.env()) pat in + GlobSearchSubPattern pat + | SearchString (s,None) when is_ident s -> + GlobSearchString s + | SearchString (s,sc) -> + try + let ref = + Notation.interp_notation_as_global_reference dummy_loc + (fun _ -> true) s sc in + GlobSearchSubPattern (Pattern.PRef ref) + with UserError _ -> + error ("Unable to interp \""^s^"\" either as a reference or + as an identifier component") let vernac_search s r = let r = interp_search_restriction r in if !pcoq <> None then (Option.get !pcoq).search s r else match s with | SearchPattern c -> - let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in Search.search_pattern pat r | SearchRewrite c -> - let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in Search.search_rewrite pat r | SearchHead ref -> Search.search_by_head (global_with_alias ref) r | SearchAbout sl -> - Search.search_about (List.map interp_search_about_item sl) r + Search.search_about (List.map (on_snd interp_search_about_item) sl) r let vernac_locate = function | LocateTerm qid -> msgnl (print_located_qualid qid) @@ -1309,7 +1338,6 @@ let interp c = match c with | VernacEndSegment lid -> vernac_end_segment lid - | VernacRecord (_,id,bl,s,idopt,fs) -> vernac_record id bl s idopt fs | VernacRequire (export,spec,qidl) -> vernac_require export spec qidl | VernacImport (export,qidl) -> vernac_import export qidl | VernacCanonical qid -> vernac_canonical qid @@ -1317,8 +1345,6 @@ let interp c = match c with | VernacIdentityCoercion (str,(_,id),s,t) -> vernac_identity_coercion str id s t (* Type classes *) - | VernacClass (id, par, ar, sup, props) -> vernac_class id par ar sup props - | VernacInstance (glob, sup, inst, props, pri) -> vernac_instance glob sup inst props pri | VernacContext sup -> vernac_context sup | VernacDeclareInstance id -> vernac_declare_instance id @@ -1356,6 +1382,7 @@ let interp c = match c with (* Commands *) | VernacDeclareTacticDefinition (x,l) -> vernac_declare_tactic_definition x l + | VernacCreateHintDb (local,dbname,b) -> vernac_create_hintdb local dbname b | VernacHints (local,dbnames,hints) -> vernac_hints local dbnames hints | VernacSyntacticDefinition (id,c,l,b) ->vernac_syntactic_definition id c l b | VernacDeclareImplicits (local,qid,l) ->vernac_declare_implicits local qid l diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index 663e2e3c..3e9dfb25 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: vernacexpr.ml 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: vernacexpr.ml 11809 2009-01-20 11:39:55Z aspiwack $ i*) open Util open Names @@ -38,7 +38,7 @@ type printable = | PrintSectionContext of reference | PrintInspect of int | PrintGrammar of string - | PrintLoadPath + | PrintLoadPath of dir_path option | PrintModules | PrintModule of reference | PrintModuleType of reference @@ -60,7 +60,6 @@ type printable = | PrintHintDbName of string | PrintRewriteHintDbName of string | PrintHintDb - | PrintSetoids | PrintScopes | PrintScope of string | PrintVisibility of string option @@ -69,14 +68,14 @@ type printable = | PrintAssumptions of reference type search_about_item = - | SearchRef of reference - | SearchString of string + | SearchSubPattern of constr_pattern_expr + | SearchString of string * scope_name option type searchable = - | SearchPattern of pattern_expr - | SearchRewrite of pattern_expr + | SearchPattern of constr_pattern_expr + | SearchRewrite of constr_pattern_expr | SearchHead of reference - | SearchAbout of search_about_item list + | SearchAbout of (bool * search_about_item) list type locatable = | LocateTerm of reference @@ -112,11 +111,12 @@ type comment = | CommentInt of int type hints = - | HintsResolve of (int option * constr_expr) list + | HintsResolve of (int option * bool * constr_expr) list | HintsImmediate of constr_expr list | HintsUnfold of reference list + | HintsTransparency of reference list * bool | HintsConstructors of reference list - | HintsExtern of int * constr_expr * raw_tactic_expr + | HintsExtern of int * constr_expr option * raw_tactic_expr | HintsDestruct of identifier * int * (bool,unit) location * constr_expr * raw_tactic_expr @@ -140,19 +140,11 @@ type locality_flag = bool (* true = Local; false = Global *) type coercion_flag = bool (* true = AddCoercion; false = NoCoercion *) type export_flag = bool (* true = Export; false = Import *) type specif_flag = bool (* true = Specification; false = Implementation *) -type inductive_flag = bool (* true = Inductive; false = CoInductive *) +type inductive_flag = Decl_kinds.recursivity_kind type onlyparsing_flag = bool (* true = Parse only; false = Print also *) type sort_expr = Rawterm.rawsort -type decl_notation = (string * constr_expr * scope_name option) option -type simple_binder = lident list * constr_expr -type class_binder = lident * constr_expr list -type 'a with_coercion = coercion_flag * 'a -type constructor_expr = (lident * constr_expr) with_coercion -type inductive_expr = - lident * local_binder list * constr_expr * constructor_expr list - type definition_expr = | ProveBody of local_binder list * constr_expr | DefineBody of local_binder list * raw_red_expr option * constr_expr @@ -162,6 +154,20 @@ type local_decl_expr = | AssumExpr of lname * constr_expr | DefExpr of lname * constr_expr * constr_expr option +type inductive_kind = Inductive_kw | CoInductive | Record | Structure | Class of bool (* true = definitional, false = inductive *) +type decl_notation = (string * constr_expr * scope_name option) option +type simple_binder = lident list * constr_expr +type class_binder = lident * constr_expr list +type 'a with_coercion = coercion_flag * 'a +type 'a with_notation = 'a * decl_notation +type constructor_expr = (lident * constr_expr) with_coercion +type constructor_list_or_record_decl_expr = + | Constructors of constructor_expr list + | RecordDecl of lident option * local_decl_expr with_coercion with_notation list +type inductive_expr = + lident with_coercion * local_binder list * constr_expr option * inductive_kind * + constructor_list_or_record_decl_expr + type module_binder = bool option * lident list * module_type_ast type grammar_production = @@ -211,9 +217,6 @@ type vernac_expr = | VernacCombinedScheme of lident * lident list (* Gallina extensions *) - | VernacRecord of bool (* = Record or Structure *) - * lident with_coercion * local_binder list - * constr_expr * lident option * local_decl_expr with_coercion list | VernacBeginSection of lident | VernacEndSegment of lident | VernacRequire of @@ -225,18 +228,18 @@ type vernac_expr = class_rawexpr * class_rawexpr (* Type classes *) - | VernacClass of - lident * (* name *) - local_binder list * (* params *) - sort_expr located option * (* arity *) - local_binder list * (* constraints *) - (lident * bool * constr_expr) list (* props, with substructure hints *) +(* | VernacClass of *) +(* lident * (\* name *\) *) +(* local_binder list * (\* params *\) *) +(* sort_expr located option * (\* arity *\) *) +(* local_binder list * (\* constraints *\) *) +(* (lident * bool * constr_expr) list (\* props, with substructure hints *\) *) | VernacInstance of bool * (* global *) local_binder list * (* super *) typeclass_constraint * (* instance name, class name, params *) - (lident * lident list * constr_expr) list * (* props *) + constr_expr * (* props *) int option (* Priority *) | VernacContext of local_binder list @@ -287,6 +290,7 @@ type vernac_expr = (* Commands *) | VernacDeclareTacticDefinition of rec_flag * (reference * bool * raw_tactic_expr) list + | VernacCreateHintDb of locality_flag * lstring * bool | VernacHints of locality_flag * lstring list * hints | VernacSyntacticDefinition of identifier located * (identifier list * constr_expr) * locality_flag * onlyparsing_flag @@ -332,3 +336,72 @@ type vernac_expr = | VernacExtend of string * raw_generic_argument list and located_vernac_expr = loc * vernac_expr + +(* Locating errors raised just after the dot is parsed but before the + interpretation phase *) + +exception DuringSyntaxChecking of exn + +let syntax_checking_error s = + raise (DuringSyntaxChecking (UserError ("",Pp.str s))) + +(* Managing locality *) + +let locality_flag = ref None + +let local_of_bool = function true -> Local | false -> Global + +let check_locality () = + if !locality_flag = Some true then + syntax_checking_error "This command does not support the \"Local\" prefix."; + if !locality_flag = Some false then + syntax_checking_error "This command does not support the \"Global\" prefix." + +let use_locality () = + let local = match !locality_flag with Some true -> true | _ -> false in + locality_flag := None; + local + +let use_locality_exp () = local_of_bool (use_locality ()) + +let use_section_locality () = + let local = + match !locality_flag with Some b -> b | None -> Lib.sections_are_opened () + in + locality_flag := None; + local + +let use_non_locality () = + let local = match !locality_flag with Some false -> false | _ -> true in + locality_flag := None; + local + +let enforce_locality () = + let local = + match !locality_flag with + | Some false -> + error "Cannot be simultaneously Local and Global." + | _ -> + Flags.if_verbose + Pp.warning "Obsolete syntax: use \"Local\" as a prefix."; + true in + locality_flag := None; + local + +let enforce_locality_exp () = local_of_bool (enforce_locality ()) + +let enforce_locality_of local = + let local = + match !locality_flag with + | Some false when local -> + error "Cannot be simultaneously Local and Global." + | Some true when local -> + error "Use only prefix \"Local\"." + | None -> + if local then + Flags.if_verbose + Pp.warning "Obsolete syntax: use \"Local\" as a prefix."; + local + | Some b -> b in + locality_flag := None; + local -- cgit v1.2.3