From 164c6861860e6b52818c031f901ffeff91fca16a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 26 Jan 2016 16:56:33 +0100 Subject: Imported Upstream version 8.5 --- CHANGES | 50 +- INSTALL.doc | 4 +- Makefile.build | 17 +- Makefile.common | 3 +- checker/check.ml | 2 +- checker/check.mllib | 4 +- checker/check_stat.ml | 2 +- checker/check_stat.mli | 2 +- checker/checker.ml | 2 +- checker/cic.mli | 2 +- checker/closure.ml | 2 +- checker/closure.mli | 2 +- checker/indtypes.ml | 2 +- checker/indtypes.mli | 2 +- checker/inductive.ml | 2 +- checker/inductive.mli | 2 +- checker/mod_checking.mli | 2 +- checker/modops.ml | 2 +- checker/modops.mli | 2 +- checker/print.ml | 2 +- checker/reduction.ml | 2 +- checker/reduction.mli | 2 +- checker/safe_typing.ml | 2 +- checker/safe_typing.mli | 2 +- checker/subtyping.ml | 2 +- checker/subtyping.mli | 2 +- checker/term.ml | 2 +- checker/type_errors.ml | 2 +- checker/type_errors.mli | 2 +- checker/typeops.ml | 2 +- checker/typeops.mli | 2 +- checker/univ.ml | 2 +- checker/univ.mli | 4 +- checker/validate.ml | 2 +- checker/values.ml | 4 +- checker/votour.ml | 2 +- config/coq_config.mli | 2 +- configure.ml | 8 +- dev/db | 2 - dev/db_printers.ml | 2 +- dev/doc/README-V1-V5 | 11 +- dev/doc/versions-history.tex | 1 + dev/header | 2 +- dev/make-macos-dmg.sh | 31 + dev/printers.mllib | 10 +- dev/top_printers.ml | 2 +- dev/v8-syntax/syntax-v8.tex | 2 +- doc/stdlib/index-list.html.template | 8 +- grammar/argextend.ml4 | 2 +- grammar/grammar.mllib | 4 +- grammar/q_constr.ml4 | 2 +- grammar/q_coqast.ml4 | 2 +- grammar/q_util.ml4 | 2 +- grammar/q_util.mli | 2 +- grammar/tacextend.ml4 | 2 +- grammar/vernacextend.ml4 | 2 +- ide/MacOS/Info.plist.template | 2 +- ide/config_lexer.mll | 2 +- ide/coq.ml | 2 +- ide/coq.mli | 2 +- ide/coqOps.ml | 2 +- ide/coqOps.mli | 2 +- ide/coq_commands.ml | 2 +- ide/coq_lex.mll | 2 +- ide/coqide.ml | 2 +- ide/coqide.mli | 2 +- ide/coqide_main.ml4 | 2 +- ide/fileOps.ml | 2 +- ide/fileOps.mli | 2 +- ide/gtk_parsing.ml | 2 +- ide/ide_slave.ml | 2 +- ide/ideutils.ml | 2 +- ide/ideutils.mli | 2 +- ide/interface.mli | 2 +- ide/nanoPG.ml | 2 +- ide/preferences.ml | 42 +- ide/preferences.mli | 2 +- ide/project_file.ml4 | 7 +- ide/sentence.ml | 2 +- ide/sentence.mli | 2 +- ide/session.ml | 2 +- ide/session.mli | 2 +- ide/tags.ml | 2 +- ide/tags.mli | 2 +- ide/utf8_convert.mll | 2 +- ide/wg_Command.ml | 2 +- ide/wg_Command.mli | 2 +- ide/wg_Completion.ml | 2 +- ide/wg_Completion.mli | 2 +- ide/wg_Detachable.ml | 2 +- ide/wg_Detachable.mli | 2 +- ide/wg_Find.ml | 2 +- ide/wg_Find.mli | 2 +- ide/wg_MessageView.ml | 2 +- ide/wg_MessageView.mli | 2 +- ide/wg_Notebook.ml | 2 +- ide/wg_Notebook.mli | 2 +- ide/wg_ProofView.ml | 2 +- ide/wg_ProofView.mli | 2 +- ide/wg_ScriptView.ml | 2 +- ide/wg_ScriptView.mli | 2 +- ide/wg_Segment.ml | 2 +- ide/wg_Segment.mli | 2 +- ide/xmlprotocol.ml | 2 +- ide/xmlprotocol.mli | 2 +- interp/constrarg.ml | 2 +- interp/constrarg.mli | 2 +- interp/constrexpr_ops.ml | 2 +- interp/constrexpr_ops.mli | 2 +- interp/constrextern.ml | 17 +- interp/constrextern.mli | 2 +- interp/constrintern.ml | 4 +- interp/constrintern.mli | 2 +- interp/coqlib.ml | 2 +- interp/coqlib.mli | 2 +- interp/dumpglob.ml | 9 +- interp/dumpglob.mli | 2 +- interp/genintern.ml | 2 +- interp/genintern.mli | 2 +- interp/implicit_quantifiers.ml | 2 +- interp/implicit_quantifiers.mli | 2 +- interp/interp.mllib | 2 +- interp/modintern.ml | 2 +- interp/modintern.mli | 2 +- interp/notation.ml | 2 +- interp/notation.mli | 2 +- interp/notation_ops.ml | 2 +- interp/notation_ops.mli | 2 +- interp/ppextend.ml | 2 +- interp/ppextend.mli | 2 +- interp/reserve.ml | 2 +- interp/reserve.mli | 2 +- interp/smartlocate.ml | 2 +- interp/smartlocate.mli | 2 +- interp/stdarg.ml | 2 +- interp/stdarg.mli | 2 +- interp/syntax_def.ml | 2 +- interp/syntax_def.mli | 2 +- interp/topconstr.ml | 46 +- interp/topconstr.mli | 2 +- intf/constrexpr.mli | 2 +- intf/decl_kinds.mli | 2 +- intf/evar_kinds.mli | 2 +- intf/extend.mli | 2 +- intf/genredexpr.mli | 2 +- intf/glob_term.mli | 2 +- intf/locus.mli | 2 +- intf/misctypes.mli | 2 +- intf/notation_term.mli | 2 +- intf/pattern.mli | 2 +- intf/tacexpr.mli | 4 +- intf/vernacexpr.mli | 2 +- kernel/cbytecodes.ml | 2 +- kernel/cbytecodes.mli | 2 +- kernel/cbytegen.ml | 4 +- kernel/cemitcodes.ml | 2 +- kernel/closure.ml | 4 +- kernel/closure.mli | 2 +- kernel/constr.ml | 2 +- kernel/constr.mli | 2 +- kernel/context.ml | 2 +- kernel/context.mli | 2 +- kernel/conv_oracle.ml | 2 +- kernel/conv_oracle.mli | 2 +- kernel/cooking.ml | 2 +- kernel/cooking.mli | 2 +- kernel/csymtable.ml | 2 +- kernel/csymtable.mli | 2 +- kernel/declarations.mli | 25 +- kernel/declareops.ml | 2 +- kernel/declareops.mli | 2 +- kernel/entries.mli | 2 +- kernel/environ.ml | 2 +- kernel/environ.mli | 2 +- kernel/esubst.ml | 2 +- kernel/esubst.mli | 2 +- kernel/evar.ml | 2 +- kernel/evar.mli | 2 +- kernel/fast_typeops.ml | 8 +- kernel/fast_typeops.mli | 2 +- kernel/indtypes.ml | 73 +- kernel/indtypes.mli | 2 +- kernel/inductive.ml | 2 +- kernel/inductive.mli | 2 +- kernel/mod_subst.ml | 2 +- kernel/mod_subst.mli | 2 +- kernel/mod_typing.ml | 130 +- kernel/mod_typing.mli | 26 +- kernel/modops.ml | 9 +- kernel/modops.mli | 7 +- kernel/names.ml | 2 +- kernel/names.mli | 12 +- kernel/nativecode.ml | 2 +- kernel/nativecode.mli | 2 +- kernel/nativeconv.ml | 2 +- kernel/nativeconv.mli | 2 +- kernel/nativeinstr.mli | 2 +- kernel/nativelambda.ml | 2 +- kernel/nativelambda.mli | 2 +- kernel/nativelib.ml | 14 +- kernel/nativelib.mli | 2 +- kernel/nativelibrary.ml | 2 +- kernel/nativelibrary.mli | 2 +- kernel/nativevalues.ml | 2 +- kernel/nativevalues.mli | 2 +- kernel/opaqueproof.ml | 2 +- kernel/opaqueproof.mli | 6 +- kernel/pre_env.ml | 2 +- kernel/pre_env.mli | 2 +- kernel/primitives.ml | 2 +- kernel/primitives.mli | 2 +- kernel/reduction.ml | 4 +- kernel/reduction.mli | 2 +- kernel/retroknowledge.ml | 2 +- kernel/retroknowledge.mli | 2 +- kernel/safe_typing.ml | 4 +- kernel/safe_typing.mli | 2 +- kernel/sorts.ml | 2 +- kernel/sorts.mli | 2 +- kernel/subtyping.ml | 2 +- kernel/subtyping.mli | 2 +- kernel/term.ml | 2 +- kernel/term.mli | 2 +- kernel/term_typing.ml | 15 +- kernel/term_typing.mli | 2 +- kernel/type_errors.ml | 2 +- kernel/type_errors.mli | 2 +- kernel/typeops.ml | 2 +- kernel/typeops.mli | 2 +- kernel/univ.ml | 12 +- kernel/univ.mli | 2 +- kernel/vars.ml | 2 +- kernel/vars.mli | 4 +- kernel/vconv.mli | 2 +- kernel/vm.ml | 2 +- kernel/vm.mli | 3 + lib/aux_file.ml | 2 +- lib/aux_file.mli | 2 +- lib/bigint.ml | 2 +- lib/bigint.mli | 2 +- lib/cMap.ml | 4 +- lib/cMap.mli | 4 +- lib/cSet.ml | 2 +- lib/cSet.mli | 2 +- lib/cSig.mli | 31 + lib/cString.ml | 2 +- lib/cString.mli | 2 +- lib/cThread.ml | 2 +- lib/cThread.mli | 2 +- lib/cUnix.ml | 2 +- lib/cUnix.mli | 2 +- lib/canary.ml | 2 +- lib/canary.mli | 2 +- lib/clib.mllib | 4 +- lib/control.ml | 2 +- lib/control.mli | 2 +- lib/deque.ml | 2 +- lib/deque.mli | 2 +- lib/dyn.ml | 2 +- lib/dyn.mli | 2 +- lib/envars.ml | 7 +- lib/envars.mli | 2 +- lib/ephemeron.ml | 2 +- lib/ephemeron.mli | 2 +- lib/explore.ml | 2 +- lib/explore.mli | 2 +- lib/feedback.ml | 2 +- lib/feedback.mli | 2 +- lib/flags.ml | 4 +- lib/flags.mli | 4 +- lib/future.ml | 2 +- lib/future.mli | 2 +- lib/genarg.ml | 2 +- lib/genarg.mli | 2 +- lib/hMap.ml | 2 +- lib/hMap.mli | 2 +- lib/hashcons.ml | 2 +- lib/hashcons.mli | 2 +- lib/hashset.ml | 2 +- lib/hashset.mli | 2 +- lib/heap.ml | 2 +- lib/heap.mli | 2 +- lib/hook.ml | 2 +- lib/hook.mli | 2 +- lib/iStream.ml | 2 +- lib/iStream.mli | 2 +- lib/int.ml | 2 +- lib/int.mli | 2 +- lib/loc.ml | 4 +- lib/loc.mli | 2 +- lib/option.ml | 2 +- lib/option.mli | 2 +- lib/pp.ml | 2 +- lib/pp.mli | 2 +- lib/pp_control.ml | 2 +- lib/pp_control.mli | 2 +- lib/ppstyle.ml | 2 +- lib/ppstyle.mli | 2 +- lib/predicate.ml | 9 +- lib/predicate.mli | 85 +- lib/profile.ml | 2 +- lib/profile.mli | 2 +- lib/remoteCounter.ml | 2 +- lib/remoteCounter.mli | 2 +- lib/richpp.ml | 2 +- lib/richpp.mli | 2 +- lib/rtree.ml | 2 +- lib/rtree.mli | 2 +- lib/serialize.ml | 2 +- lib/serialize.mli | 2 +- lib/spawn.ml | 10 +- lib/spawn.mli | 2 +- lib/system.ml | 84 +- lib/system.mli | 4 +- lib/terminal.ml | 2 +- lib/terminal.mli | 2 +- lib/trie.ml | 2 +- lib/trie.mli | 2 +- lib/unicode.mli | 2 +- lib/unionfind.ml | 2 +- lib/unionfind.mli | 2 +- lib/util.mli | 2 +- lib/xml_datatype.mli | 2 +- lib/xml_printer.ml | 2 +- lib/xml_printer.mli | 2 +- library/declare.ml | 23 +- library/declare.mli | 7 +- library/declaremods.ml | 25 +- library/declaremods.mli | 9 +- library/decls.ml | 2 +- library/decls.mli | 2 +- library/dischargedhypsmap.ml | 2 +- library/dischargedhypsmap.mli | 2 +- library/global.ml | 6 +- library/global.mli | 2 +- library/globnames.ml | 2 +- library/globnames.mli | 2 +- library/goptions.ml | 2 +- library/goptions.mli | 4 +- library/heads.ml | 2 +- library/heads.mli | 2 +- library/impargs.ml | 2 +- library/impargs.mli | 2 +- library/keys.ml | 2 +- library/keys.mli | 2 +- library/kindops.ml | 2 +- library/kindops.mli | 2 +- library/lib.ml | 8 +- library/lib.mli | 6 +- library/libnames.ml | 2 +- library/libnames.mli | 4 +- library/libobject.ml | 2 +- library/libobject.mli | 2 +- library/library.ml | 5 +- library/library.mli | 5 +- library/loadpath.ml | 2 +- library/loadpath.mli | 2 +- library/nameops.ml | 2 +- library/nameops.mli | 2 +- library/nametab.ml | 2 +- library/nametab.mli | 2 +- library/states.ml | 2 +- library/states.mli | 2 +- library/summary.ml | 2 +- library/summary.mli | 2 +- library/universes.ml | 24 +- library/universes.mli | 2 +- man/coqdep.1 | 65 +- man/coqide.1 | 6 + man/coqtop.1 | 6 + parsing/compat.ml4 | 2 +- parsing/egramcoq.ml | 2 +- parsing/egramcoq.mli | 2 +- parsing/egramml.ml | 2 +- parsing/egramml.mli | 2 +- parsing/g_constr.ml4 | 4 +- parsing/g_ltac.ml4 | 6 +- parsing/g_prim.ml4 | 2 +- parsing/g_proofs.ml4 | 2 +- parsing/g_tactic.ml4 | 32 +- parsing/g_vernac.ml4 | 2 +- parsing/lexer.ml4 | 8 +- parsing/lexer.mli | 4 +- parsing/pcoq.ml4 | 2 +- parsing/pcoq.mli | 2 +- parsing/tok.ml | 3 +- parsing/tok.mli | 2 +- plugins/btauto/g_btauto.ml4 | 2 +- plugins/cc/ccalgo.ml | 2 +- plugins/cc/ccalgo.mli | 8 +- plugins/cc/ccproof.ml | 2 +- plugins/cc/ccproof.mli | 2 +- plugins/cc/cctac.ml | 6 +- plugins/cc/g_congruence.ml4 | 2 +- plugins/decl_mode/decl_expr.mli | 2 +- plugins/decl_mode/decl_interp.ml | 2 +- plugins/decl_mode/decl_interp.mli | 2 +- plugins/decl_mode/decl_mode.ml | 2 +- plugins/decl_mode/decl_mode.mli | 2 +- plugins/decl_mode/decl_proof_instr.ml | 2 +- plugins/decl_mode/decl_proof_instr.mli | 2 +- plugins/decl_mode/g_decl_mode.ml4 | 2 +- plugins/decl_mode/ppdecl_proof.ml | 2 +- plugins/derive/derive.ml | 2 +- plugins/derive/derive.mli | 2 +- plugins/derive/g_derive.ml4 | 2 +- plugins/extraction/ExtrOcamlBasic.v | 2 +- plugins/extraction/ExtrOcamlBigIntConv.v | 2 +- plugins/extraction/ExtrOcamlIntConv.v | 2 +- plugins/extraction/ExtrOcamlNatBigInt.v | 2 +- plugins/extraction/ExtrOcamlNatInt.v | 2 +- plugins/extraction/ExtrOcamlString.v | 2 +- plugins/extraction/ExtrOcamlZBigInt.v | 2 +- plugins/extraction/ExtrOcamlZInt.v | 2 +- plugins/extraction/big.ml | 2 +- plugins/extraction/common.ml | 7 +- plugins/extraction/common.mli | 2 +- plugins/extraction/extract_env.ml | 138 +- plugins/extraction/extract_env.mli | 2 +- plugins/extraction/extraction.ml | 176 +- plugins/extraction/extraction.mli | 2 +- plugins/extraction/g_extraction.ml4 | 2 +- plugins/extraction/haskell.ml | 89 +- plugins/extraction/haskell.mli | 2 +- plugins/extraction/json.ml | 2 +- plugins/extraction/miniml.mli | 17 +- plugins/extraction/mlutil.ml | 243 +- plugins/extraction/mlutil.mli | 9 +- plugins/extraction/modutil.ml | 50 +- plugins/extraction/modutil.mli | 2 +- plugins/extraction/ocaml.ml | 169 +- plugins/extraction/ocaml.mli | 2 +- plugins/extraction/scheme.ml | 7 +- plugins/extraction/scheme.mli | 2 +- plugins/extraction/table.ml | 121 +- plugins/extraction/table.mli | 29 +- plugins/firstorder/formula.ml | 2 +- plugins/firstorder/formula.mli | 2 +- plugins/firstorder/g_ground.ml4 | 2 +- plugins/firstorder/ground.ml | 2 +- plugins/firstorder/ground.mli | 2 +- plugins/firstorder/instances.ml | 2 +- plugins/firstorder/instances.mli | 2 +- plugins/firstorder/rules.ml | 2 +- plugins/firstorder/rules.mli | 2 +- plugins/firstorder/sequent.ml | 2 +- plugins/firstorder/sequent.mli | 4 +- plugins/firstorder/unify.ml | 2 +- plugins/firstorder/unify.mli | 2 +- plugins/fourier/Fourier.v | 2 +- plugins/fourier/Fourier_util.v | 2 +- plugins/fourier/fourier.ml | 2 +- plugins/fourier/fourierR.ml | 2 +- plugins/fourier/g_fourier.ml4 | 2 +- plugins/funind/Recdef.v | 2 +- plugins/funind/functional_principles_proofs.mli | 2 +- plugins/funind/functional_principles_types.mli | 2 +- plugins/funind/g_indfun.ml4 | 2 +- plugins/funind/glob_term_to_relation.ml | 2 +- plugins/funind/invfun.ml | 2 +- plugins/funind/merge.ml | 2 +- plugins/funind/recdef.ml | 14 +- plugins/micromega/Env.v | 2 +- plugins/micromega/EnvRing.v | 2 +- plugins/micromega/Lia.v | 2 +- plugins/micromega/MExtraction.v | 2 +- plugins/micromega/OrderedRing.v | 2 +- plugins/micromega/Psatz.v | 2 +- plugins/micromega/QMicromega.v | 2 +- plugins/micromega/RMicromega.v | 2 +- plugins/micromega/Refl.v | 2 +- plugins/micromega/RingMicromega.v | 2 +- plugins/micromega/Tauto.v | 2 +- plugins/micromega/VarMap.v | 2 +- plugins/micromega/ZCoeff.v | 2 +- plugins/micromega/ZMicromega.v | 2 +- plugins/micromega/certificate.ml | 2 +- plugins/micromega/coq_micromega.ml | 2 +- plugins/micromega/csdpcert.ml | 2 +- plugins/micromega/g_micromega.ml4 | 2 +- plugins/micromega/mutils.ml | 2 +- plugins/micromega/persistent_cache.ml | 2 +- plugins/micromega/polynomial.ml | 2 +- plugins/micromega/sos.mli | 2 +- plugins/micromega/sos_types.ml | 2 +- plugins/nsatz/Nsatz.v | 2 +- plugins/nsatz/ideal.ml | 2 +- plugins/nsatz/nsatz.ml4 | 2 +- plugins/nsatz/polynom.ml | 2 +- plugins/nsatz/polynom.mli | 2 +- plugins/omega/Omega.v | 2 +- plugins/omega/OmegaPlugin.v | 2 +- plugins/omega/OmegaTactic.v | 2 +- plugins/omega/PreOmega.v | 2 +- plugins/omega/coq_omega.ml | 2 +- plugins/omega/g_omega.ml4 | 2 +- plugins/omega/omega.ml | 2 +- plugins/quote/Quote.v | 2 +- plugins/quote/g_quote.ml4 | 2 +- plugins/quote/quote.ml | 6 +- plugins/romega/refl_omega.ml | 8 +- plugins/rtauto/Bintree.v | 2 +- plugins/rtauto/Rtauto.v | 2 +- plugins/rtauto/g_rtauto.ml4 | 2 +- plugins/rtauto/proof_search.ml | 2 +- plugins/rtauto/proof_search.mli | 2 +- plugins/rtauto/refl_tauto.ml | 2 +- plugins/rtauto/refl_tauto.mli | 2 +- plugins/setoid_ring/ArithRing.v | 2 +- plugins/setoid_ring/BinList.v | 2 +- plugins/setoid_ring/Cring.v | 2 +- plugins/setoid_ring/Field.v | 2 +- plugins/setoid_ring/Field_tac.v | 2 +- plugins/setoid_ring/Field_theory.v | 2 +- plugins/setoid_ring/InitialRing.v | 8 +- plugins/setoid_ring/NArithRing.v | 2 +- plugins/setoid_ring/Ncring.v | 2 +- plugins/setoid_ring/Ncring_initial.v | 6 +- plugins/setoid_ring/Ncring_polynom.v | 2 +- plugins/setoid_ring/Ncring_tac.v | 2 +- plugins/setoid_ring/Ring.v | 2 +- plugins/setoid_ring/Ring_base.v | 2 +- plugins/setoid_ring/Ring_polynom.v | 2 +- plugins/setoid_ring/Ring_theory.v | 2 +- plugins/setoid_ring/ZArithRing.v | 2 +- plugins/setoid_ring/newring.ml4 | 2 +- plugins/syntax/nat_syntax.ml | 2 +- plugins/syntax/numbers_syntax.ml | 2 +- plugins/syntax/r_syntax.ml | 2 +- plugins/syntax/z_syntax.ml | 2 +- plugins/xml/README | 19 +- pretyping/arguments_renaming.ml | 2 +- pretyping/arguments_renaming.mli | 2 +- pretyping/cases.ml | 2 +- pretyping/cases.mli | 2 +- pretyping/cbv.ml | 2 +- pretyping/cbv.mli | 2 +- pretyping/classops.ml | 2 +- pretyping/classops.mli | 2 +- pretyping/coercion.ml | 4 +- pretyping/coercion.mli | 2 +- pretyping/constr_matching.ml | 2 +- pretyping/constr_matching.mli | 2 +- pretyping/detyping.ml | 16 +- pretyping/detyping.mli | 2 +- pretyping/evarconv.ml | 2 +- pretyping/evarconv.mli | 2 +- pretyping/evarsolve.ml | 22 +- pretyping/evarsolve.mli | 5 +- pretyping/evarutil.ml | 2 +- pretyping/evarutil.mli | 2 +- pretyping/evd.ml | 16 +- pretyping/evd.mli | 4 +- pretyping/find_subterm.ml | 2 +- pretyping/find_subterm.mli | 2 +- pretyping/glob_ops.ml | 2 +- pretyping/glob_ops.mli | 2 +- pretyping/indrec.ml | 2 +- pretyping/indrec.mli | 2 +- pretyping/inductiveops.ml | 2 +- pretyping/inductiveops.mli | 2 +- pretyping/locusops.ml | 2 +- pretyping/locusops.mli | 2 +- pretyping/miscops.ml | 2 +- pretyping/miscops.mli | 2 +- pretyping/namegen.ml | 2 +- pretyping/namegen.mli | 2 +- pretyping/nativenorm.ml | 2 +- pretyping/nativenorm.mli | 2 +- pretyping/patternops.ml | 31 +- pretyping/patternops.mli | 5 +- pretyping/pretype_errors.ml | 2 +- pretyping/pretype_errors.mli | 2 +- pretyping/pretyping.ml | 66 +- pretyping/pretyping.mli | 2 +- pretyping/program.ml | 2 +- pretyping/program.mli | 2 +- pretyping/recordops.ml | 2 +- pretyping/recordops.mli | 2 +- pretyping/redops.ml | 2 +- pretyping/redops.mli | 2 +- pretyping/reductionops.ml | 15 +- pretyping/reductionops.mli | 2 +- pretyping/retyping.ml | 2 +- pretyping/retyping.mli | 2 +- pretyping/tacred.ml | 2 +- pretyping/tacred.mli | 2 +- pretyping/termops.ml | 4 +- pretyping/termops.mli | 2 +- pretyping/typeclasses.ml | 2 +- pretyping/typeclasses.mli | 2 +- pretyping/typeclasses_errors.ml | 2 +- pretyping/typeclasses_errors.mli | 2 +- pretyping/typing.ml | 20 +- pretyping/typing.mli | 2 +- pretyping/unification.ml | 27 +- pretyping/unification.mli | 4 +- pretyping/vnorm.ml | 11 +- pretyping/vnorm.mli | 2 +- printing/genprint.ml | 2 +- printing/genprint.mli | 2 +- printing/miscprint.ml | 2 +- printing/miscprint.mli | 2 +- printing/ppannotation.ml | 2 +- printing/ppannotation.mli | 2 +- printing/ppconstr.ml | 12 +- printing/ppconstr.mli | 2 +- printing/ppconstrsig.mli | 2 +- printing/pptactic.ml | 5 +- printing/pptactic.mli | 2 +- printing/pptacticsig.mli | 2 +- printing/pputils.ml | 2 +- printing/pputils.mli | 2 +- printing/ppvernac.ml | 2 +- printing/ppvernac.mli | 2 +- printing/ppvernacsig.mli | 2 +- printing/prettyp.ml | 2 +- printing/prettyp.mli | 2 +- printing/printer.ml | 2 +- printing/printer.mli | 2 +- printing/printmod.ml | 2 +- printing/printmod.mli | 2 +- printing/printmodsig.mli | 2 +- printing/richprinter.mli | 2 +- proofs/clenv.ml | 6 +- proofs/clenv.mli | 4 +- proofs/clenvtac.ml | 2 +- proofs/clenvtac.mli | 2 +- proofs/evar_refiner.ml | 2 +- proofs/evar_refiner.mli | 2 +- proofs/goal.ml | 2 +- proofs/goal.mli | 2 +- proofs/logic.ml | 2 +- proofs/logic.mli | 2 +- proofs/logic_monad.ml | 2 +- proofs/logic_monad.mli | 2 +- proofs/pfedit.ml | 12 +- proofs/pfedit.mli | 9 +- proofs/proof.ml | 2 +- proofs/proof.mli | 2 +- proofs/proof_global.ml | 40 +- proofs/proof_global.mli | 19 +- proofs/proof_type.ml | 2 +- proofs/proof_type.mli | 2 +- proofs/proof_using.ml | 2 +- proofs/proof_using.mli | 2 +- proofs/proofview.ml | 67 +- proofs/proofview.mli | 6 +- proofs/proofview_monad.ml | 25 +- proofs/proofview_monad.mli | 14 +- proofs/redexpr.ml | 2 +- proofs/redexpr.mli | 2 +- proofs/refiner.ml | 2 +- proofs/refiner.mli | 2 +- proofs/tacmach.ml | 2 +- proofs/tacmach.mli | 2 +- proofs/tactic_debug.ml | 2 +- proofs/tactic_debug.mli | 2 +- stm/asyncTaskQueue.ml | 7 +- stm/asyncTaskQueue.mli | 2 +- stm/coqworkmgrApi.ml | 2 +- stm/coqworkmgrApi.mli | 2 +- stm/dag.ml | 2 +- stm/dag.mli | 2 +- stm/lemmas.ml | 65 +- stm/lemmas.mli | 17 +- stm/proofworkertop.ml | 2 +- stm/queryworkertop.ml | 2 +- stm/spawned.ml | 2 +- stm/spawned.mli | 2 +- stm/stm.ml | 36 +- stm/stm.mli | 3 + stm/tQueue.ml | 2 +- stm/tQueue.mli | 2 +- stm/tacworkertop.ml | 2 +- stm/texmacspp.ml | 2 +- stm/texmacspp.mli | 2 +- stm/vcs.ml | 2 +- stm/vcs.mli | 2 +- stm/vernac_classifier.ml | 2 +- stm/vernac_classifier.mli | 2 +- stm/vio_checking.ml | 4 +- stm/vio_checking.mli | 2 +- stm/workerPool.ml | 2 +- stm/workerPool.mli | 2 +- tactics/auto.ml | 2 +- tactics/auto.mli | 2 +- tactics/autorewrite.ml | 2 +- tactics/autorewrite.mli | 2 +- tactics/btermdn.ml | 2 +- tactics/btermdn.mli | 2 +- tactics/class_tactics.ml | 2 +- tactics/class_tactics.mli | 2 +- tactics/contradiction.ml | 2 +- tactics/contradiction.mli | 2 +- tactics/coretactics.ml4 | 6 +- tactics/dnet.ml | 2 +- tactics/dnet.mli | 2 +- tactics/eauto.ml4 | 10 +- tactics/eauto.mli | 2 +- tactics/elim.ml | 2 +- tactics/elim.mli | 2 +- tactics/elimschemes.ml | 2 +- tactics/elimschemes.mli | 2 +- tactics/eqdecide.ml | 2 +- tactics/eqdecide.mli | 2 +- tactics/eqschemes.ml | 13 +- tactics/eqschemes.mli | 2 +- tactics/equality.ml | 44 +- tactics/equality.mli | 2 +- tactics/evar_tactics.ml | 2 +- tactics/evar_tactics.mli | 2 +- tactics/extraargs.ml4 | 2 +- tactics/extraargs.mli | 2 +- tactics/extratactics.ml4 | 29 +- tactics/extratactics.mli | 2 +- tactics/ftactic.ml | 4 +- tactics/ftactic.mli | 2 +- tactics/g_class.ml4 | 2 +- tactics/g_eqdecide.ml4 | 2 +- tactics/g_rewrite.ml4 | 2 +- tactics/geninterp.ml | 2 +- tactics/geninterp.mli | 2 +- tactics/hints.ml | 8 +- tactics/hints.mli | 2 +- tactics/hipattern.ml4 | 2 +- tactics/hipattern.mli | 2 +- tactics/inv.ml | 2 +- tactics/inv.mli | 2 +- tactics/leminv.ml | 2 +- tactics/leminv.mli | 2 +- tactics/rewrite.ml | 42 +- tactics/rewrite.mli | 2 +- tactics/taccoerce.ml | 2 +- tactics/taccoerce.mli | 2 +- tactics/tacenv.ml | 2 +- tactics/tacenv.mli | 2 +- tactics/tacintern.ml | 6 +- tactics/tacintern.mli | 2 +- tactics/tacinterp.ml | 24 +- tactics/tacinterp.mli | 2 +- tactics/tacsubst.ml | 2 +- tactics/tacsubst.mli | 2 +- tactics/tactic_matching.ml | 2 +- tactics/tactic_option.ml | 2 +- tactics/tactic_option.mli | 2 +- tactics/tacticals.ml | 4 +- tactics/tacticals.mli | 2 +- tactics/tactics.ml | 109 +- tactics/tactics.mli | 7 +- tactics/tauto.ml4 | 2 +- tactics/term_dnet.ml | 2 +- tactics/term_dnet.mli | 2 +- test-suite/Makefile | 5 +- test-suite/bench/lists-100.v | 2 +- test-suite/bench/lists_100.v | 2 +- test-suite/bugs/closed/3249.v | 4 +- test-suite/bugs/closed/3257.v | 5 + test-suite/bugs/closed/3285.v | 2 +- test-suite/bugs/closed/3286.v | 8 +- test-suite/bugs/closed/3314.v | 4 +- test-suite/bugs/closed/3330.v | 2 +- test-suite/bugs/closed/3347.v | 2 +- test-suite/bugs/closed/3354.v | 2 +- test-suite/bugs/closed/3467.v | 2 +- test-suite/bugs/closed/3487.v | 2 +- test-suite/bugs/closed/3554.v | 1 + test-suite/bugs/closed/3682.v | 2 +- test-suite/bugs/closed/3684.v | 2 +- test-suite/bugs/closed/3685.v | 4 +- test-suite/bugs/closed/3686.v | 4 +- test-suite/bugs/closed/3690.v | 2 +- test-suite/bugs/closed/3699.v | 16 +- test-suite/bugs/closed/3735.v | 4 + test-suite/bugs/closed/3743.v | 2 +- test-suite/bugs/closed/3746.v | 92 + test-suite/bugs/closed/3807.v | 33 + test-suite/bugs/closed/3848.v | 22 + test-suite/bugs/closed/3881.v | 2 +- test-suite/bugs/closed/3923.v | 33 + test-suite/bugs/closed/3998.v | 24 + test-suite/bugs/closed/4116.v | 6 +- test-suite/bugs/closed/4149.v | 4 + test-suite/bugs/closed/4256.v | 43 + test-suite/bugs/closed/4273.v | 9 + test-suite/bugs/closed/4284.v | 6 + test-suite/bugs/closed/4287.v | 6 +- test-suite/bugs/closed/4293.v | 7 + test-suite/bugs/closed/4363.v | 9 + test-suite/bugs/closed/4400.v | 19 + test-suite/bugs/closed/4404.v | 4 + test-suite/bugs/closed/4412.v | 4 + test-suite/bugs/closed/4420.v | 19 + test-suite/bugs/closed/4429.v | 31 + test-suite/bugs/closed/4433.v | 29 + test-suite/bugs/closed/4443.v | 31 + test-suite/bugs/closed/4453.v | 8 + test-suite/bugs/closed/4456.v | 647 ++++++ test-suite/bugs/closed/4462.v | 7 + test-suite/bugs/closed/4467.v | 15 + test-suite/bugs/closed/4480.v | 12 + test-suite/bugs/closed/4484.v | 10 + test-suite/bugs/closed/931.v | 2 +- test-suite/bugs/closed/HoTT_coq_077.v | 2 +- test-suite/bugs/closed/HoTT_coq_090.v | 2 +- test-suite/bugs/closed/HoTT_coq_114.v | 2 +- test-suite/bugs/opened/3248.v | 4 +- test-suite/bugs/opened/3277.v | 2 +- test-suite/bugs/opened/3278.v | 8 +- test-suite/bugs/opened/3304.v | 2 +- test-suite/bugs/opened/3459.v | 4 +- test-suite/bugs/opened/3554.v | 1 - test-suite/bugs/opened/3848.v | 22 - test-suite/complexity/f_equal.v | 14 + test-suite/failure/Tauto.v | 2 +- test-suite/failure/clash_cons.v | 2 +- test-suite/failure/fixpoint1.v | 2 +- test-suite/failure/guard.v | 2 +- test-suite/failure/illtype1.v | 2 +- test-suite/failure/positivity.v | 2 +- test-suite/failure/redef.v | 2 +- test-suite/failure/search.v | 2 +- test-suite/ideal-features/Apply.v | 2 +- test-suite/kernel/vm-univ.v | 145 -- test-suite/misc/berardi_test.v | 2 +- test-suite/output/Existentials.out | 4 +- test-suite/output/Extraction_matchs_2413.out | 2 +- test-suite/success/Case22.v | 44 + test-suite/success/Cases.v | 7 + test-suite/success/Check.v | 2 +- test-suite/success/Field.v | 2 +- test-suite/success/Notations.v | 6 + test-suite/success/Tauto.v | 2 +- test-suite/success/TestRefine.v | 2 +- test-suite/success/destruct.v | 4 +- test-suite/success/eauto.v | 2 +- test-suite/success/eqdecide.v | 2 +- test-suite/success/extraction.v | 2 +- test-suite/success/extraction_impl.v | 82 + test-suite/success/inds_type_sec.v | 2 +- test-suite/success/induct.v | 2 +- test-suite/success/intros.v | 31 +- test-suite/success/keyedrewrite.v | 37 + test-suite/success/mutual_ind.v | 2 +- test-suite/success/polymorphism.v | 4 +- test-suite/success/primitiveproj.v | 15 +- test-suite/success/proof_using.v | 3 +- test-suite/success/refine.v | 2 +- test-suite/success/unfold.v | 2 +- test-suite/success/unshelve.v | 11 + test-suite/success/vm_univ_poly.v | 141 ++ test-suite/success/vm_univ_poly_match.v | 28 + test-suite/typeclasses/NewSetoid.v | 2 +- theories/Arith/Arith.v | 2 +- theories/Arith/Arith_base.v | 2 +- theories/Arith/Between.v | 2 +- theories/Arith/Bool_nat.v | 2 +- theories/Arith/Compare.v | 2 +- theories/Arith/Compare_dec.v | 2 +- theories/Arith/Div2.v | 2 +- theories/Arith/EqNat.v | 2 +- theories/Arith/Euclid.v | 2 +- theories/Arith/Even.v | 2 +- theories/Arith/Factorial.v | 2 +- theories/Arith/Gt.v | 2 +- theories/Arith/Le.v | 2 +- theories/Arith/Lt.v | 2 +- theories/Arith/Max.v | 2 +- theories/Arith/Min.v | 2 +- theories/Arith/Minus.v | 2 +- theories/Arith/Mult.v | 2 +- theories/Arith/PeanoNat.v | 2 +- theories/Arith/Peano_dec.v | 2 +- theories/Arith/Wf_nat.v | 2 +- theories/Bool/Bool.v | 2 +- theories/Bool/BoolEq.v | 2 +- theories/Bool/Bvector.v | 2 +- theories/Bool/DecBool.v | 2 +- theories/Bool/IfProp.v | 2 +- theories/Bool/Sumbool.v | 2 +- theories/Bool/Zerob.v | 2 +- theories/Classes/CEquivalence.v | 2 +- theories/Classes/CMorphisms.v | 16 +- theories/Classes/CRelationClasses.v | 2 +- theories/Classes/DecidableClass.v | 2 +- theories/Classes/EquivDec.v | 2 +- theories/Classes/Equivalence.v | 2 +- theories/Classes/Init.v | 2 +- theories/Classes/Morphisms.v | 2 +- theories/Classes/Morphisms_Prop.v | 2 +- theories/Classes/Morphisms_Relations.v | 2 +- theories/Classes/RelationClasses.v | 6 +- theories/Classes/SetoidClass.v | 2 +- theories/Classes/SetoidDec.v | 2 +- theories/Classes/SetoidTactics.v | 2 +- theories/Compat/AdmitAxiom.v | 15 + theories/Compat/Coq84.v | 6 +- theories/Compat/Coq85.v | 2 +- theories/Compat/vo.itarget | 1 + theories/FSets/FMapFacts.v | 2 +- theories/FSets/FMapPositive.v | 2 +- theories/Init/Datatypes.v | 2 +- theories/Init/Logic.v | 2 +- theories/Init/Logic_Type.v | 2 +- theories/Init/Nat.v | 2 +- theories/Init/Notations.v | 2 +- theories/Init/Peano.v | 2 +- theories/Init/Prelude.v | 2 +- theories/Init/Specif.v | 2 +- theories/Init/Tactics.v | 2 +- theories/Init/Wf.v | 2 +- theories/Lists/List.v | 3 +- theories/Lists/ListDec.v | 2 +- theories/Lists/ListSet.v | 2 +- theories/Lists/ListTactics.v | 2 +- theories/Lists/StreamMemo.v | 2 +- theories/Lists/Streams.v | 2 +- theories/Logic/Berardi.v | 2 +- theories/Logic/ChoiceFacts.v | 2 +- theories/Logic/Classical.v | 2 +- theories/Logic/ClassicalChoice.v | 2 +- theories/Logic/ClassicalDescription.v | 2 +- theories/Logic/ClassicalEpsilon.v | 2 +- theories/Logic/ClassicalFacts.v | 7 +- theories/Logic/ClassicalUniqueChoice.v | 2 +- theories/Logic/Classical_Pred_Type.v | 2 +- theories/Logic/Classical_Prop.v | 2 +- theories/Logic/ConstructiveEpsilon.v | 2 +- theories/Logic/Decidable.v | 2 +- theories/Logic/Description.v | 2 +- theories/Logic/Diaconescu.v | 2 +- theories/Logic/Epsilon.v | 2 +- theories/Logic/Eqdep.v | 2 +- theories/Logic/EqdepFacts.v | 2 +- theories/Logic/Eqdep_dec.v | 2 +- theories/Logic/ExtensionalityFacts.v | 2 +- theories/Logic/FinFun.v | 2 +- theories/Logic/FunctionalExtensionality.v | 2 +- theories/Logic/Hurkens.v | 192 +- theories/Logic/IndefiniteDescription.v | 2 +- theories/Logic/JMeq.v | 2 +- theories/Logic/ProofIrrelevance.v | 2 +- theories/Logic/ProofIrrelevanceFacts.v | 2 +- theories/Logic/RelationalChoice.v | 2 +- theories/Logic/SetIsType.v | 2 +- theories/Logic/WKL.v | 8 +- theories/Logic/WeakFan.v | 4 +- theories/MMaps/MMapAVL.v | 2158 ----------------- theories/MMaps/MMapFacts.v | 2434 -------------------- theories/MMaps/MMapInterface.v | 292 --- theories/MMaps/MMapList.v | 1144 --------- theories/MMaps/MMapPositive.v | 698 ------ theories/MMaps/MMapWeakList.v | 687 ------ theories/MMaps/MMaps.v | 16 - theories/MMaps/vo.itarget | 7 - theories/NArith/BinNat.v | 2 +- theories/NArith/BinNatDef.v | 2 +- theories/NArith/NArith.v | 2 +- theories/NArith/Ndec.v | 2 +- theories/NArith/Ndigits.v | 2 +- theories/NArith/Ndist.v | 2 +- theories/NArith/Ndiv_def.v | 2 +- theories/NArith/Ngcd_def.v | 2 +- theories/NArith/Nnat.v | 2 +- theories/NArith/Nsqrt_def.v | 2 +- theories/Numbers/BigNumPrelude.v | 2 +- theories/Numbers/BinNums.v | 2 +- theories/Numbers/Cyclic/Abstract/CyclicAxioms.v | 2 +- theories/Numbers/Cyclic/Abstract/NZCyclic.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v | 2 +- .../Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v | 2 +- theories/Numbers/Cyclic/Int31/Cyclic31.v | 2 +- theories/Numbers/Cyclic/Int31/Int31.v | 2 +- theories/Numbers/Cyclic/Int31/Ring31.v | 2 +- theories/Numbers/Cyclic/ZModulo/ZModulo.v | 2 +- theories/Numbers/Integer/Abstract/ZAdd.v | 2 +- theories/Numbers/Integer/Abstract/ZAddOrder.v | 2 +- theories/Numbers/Integer/Abstract/ZAxioms.v | 2 +- theories/Numbers/Integer/Abstract/ZBase.v | 2 +- theories/Numbers/Integer/Abstract/ZBits.v | 2 +- theories/Numbers/Integer/Abstract/ZDivEucl.v | 4 +- theories/Numbers/Integer/Abstract/ZDivFloor.v | 4 +- theories/Numbers/Integer/Abstract/ZDivTrunc.v | 4 +- theories/Numbers/Integer/Abstract/ZGcd.v | 2 +- theories/Numbers/Integer/Abstract/ZLcm.v | 2 +- theories/Numbers/Integer/Abstract/ZLt.v | 2 +- theories/Numbers/Integer/Abstract/ZMaxMin.v | 2 +- theories/Numbers/Integer/Abstract/ZMul.v | 2 +- theories/Numbers/Integer/Abstract/ZMulOrder.v | 2 +- theories/Numbers/Integer/Abstract/ZParity.v | 2 +- theories/Numbers/Integer/Abstract/ZPow.v | 2 +- theories/Numbers/Integer/Abstract/ZProperties.v | 2 +- theories/Numbers/Integer/Abstract/ZSgnAbs.v | 2 +- theories/Numbers/Integer/BigZ/BigZ.v | 2 +- theories/Numbers/Integer/BigZ/ZMake.v | 2 +- theories/Numbers/Integer/Binary/ZBinary.v | 2 +- theories/Numbers/Integer/NatPairs/ZNatPairs.v | 2 +- theories/Numbers/Integer/SpecViaZ/ZSig.v | 2 +- theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v | 2 +- theories/Numbers/NaryFunctions.v | 2 +- theories/Numbers/NatInt/NZAdd.v | 2 +- theories/Numbers/NatInt/NZAddOrder.v | 2 +- theories/Numbers/NatInt/NZAxioms.v | 2 +- theories/Numbers/NatInt/NZBase.v | 2 +- theories/Numbers/NatInt/NZBits.v | 2 +- theories/Numbers/NatInt/NZDiv.v | 4 +- theories/Numbers/NatInt/NZDomain.v | 2 +- theories/Numbers/NatInt/NZGcd.v | 2 +- theories/Numbers/NatInt/NZLog.v | 2 +- theories/Numbers/NatInt/NZMul.v | 2 +- theories/Numbers/NatInt/NZMulOrder.v | 2 +- theories/Numbers/NatInt/NZOrder.v | 2 +- theories/Numbers/NatInt/NZParity.v | 2 +- theories/Numbers/NatInt/NZPow.v | 2 +- theories/Numbers/NatInt/NZProperties.v | 2 +- theories/Numbers/NatInt/NZSqrt.v | 2 +- theories/Numbers/Natural/Abstract/NAdd.v | 2 +- theories/Numbers/Natural/Abstract/NAddOrder.v | 2 +- theories/Numbers/Natural/Abstract/NAxioms.v | 2 +- theories/Numbers/Natural/Abstract/NBase.v | 2 +- theories/Numbers/Natural/Abstract/NBits.v | 2 +- theories/Numbers/Natural/Abstract/NDefOps.v | 2 +- theories/Numbers/Natural/Abstract/NDiv.v | 4 +- theories/Numbers/Natural/Abstract/NGcd.v | 2 +- theories/Numbers/Natural/Abstract/NIso.v | 2 +- theories/Numbers/Natural/Abstract/NLcm.v | 2 +- theories/Numbers/Natural/Abstract/NLog.v | 2 +- theories/Numbers/Natural/Abstract/NMaxMin.v | 2 +- theories/Numbers/Natural/Abstract/NMulOrder.v | 2 +- theories/Numbers/Natural/Abstract/NOrder.v | 2 +- theories/Numbers/Natural/Abstract/NParity.v | 4 +- theories/Numbers/Natural/Abstract/NPow.v | 2 +- theories/Numbers/Natural/Abstract/NProperties.v | 2 +- theories/Numbers/Natural/Abstract/NSqrt.v | 2 +- theories/Numbers/Natural/Abstract/NStrongRec.v | 2 +- theories/Numbers/Natural/Abstract/NSub.v | 2 +- theories/Numbers/Natural/BigN/BigN.v | 2 +- theories/Numbers/Natural/BigN/NMake.v | 2 +- theories/Numbers/Natural/BigN/NMake_gen.ml | 2 +- theories/Numbers/Natural/BigN/Nbasic.v | 2 +- theories/Numbers/Natural/Binary/NBinary.v | 2 +- theories/Numbers/Natural/Peano/NPeano.v | 2 +- theories/Numbers/Natural/SpecViaZ/NSig.v | 2 +- theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v | 2 +- theories/Numbers/NumPrelude.v | 2 +- theories/Numbers/Rational/BigQ/BigQ.v | 2 +- theories/Numbers/Rational/BigQ/QMake.v | 2 +- theories/Numbers/Rational/SpecViaQ/QSig.v | 2 +- theories/PArith/BinPos.v | 2 +- theories/PArith/BinPosDef.v | 2 +- theories/PArith/PArith.v | 2 +- theories/PArith/POrderedType.v | 2 +- theories/PArith/Pnat.v | 2 +- theories/Program/Basics.v | 2 +- theories/Program/Combinators.v | 2 +- theories/Program/Equality.v | 2 +- theories/Program/Program.v | 2 +- theories/Program/Subset.v | 4 +- theories/Program/Syntax.v | 2 +- theories/Program/Tactics.v | 2 +- theories/Program/Utils.v | 2 +- theories/Program/Wf.v | 2 +- theories/QArith/QArith.v | 2 +- theories/QArith/QArith_base.v | 2 +- theories/QArith/QOrderedType.v | 2 +- theories/QArith/Qabs.v | 2 +- theories/QArith/Qcanon.v | 2 +- theories/QArith/Qfield.v | 2 +- theories/QArith/Qminmax.v | 2 +- theories/QArith/Qpower.v | 2 +- theories/QArith/Qreals.v | 2 +- theories/QArith/Qreduction.v | 2 +- theories/QArith/Qring.v | 2 +- theories/QArith/Qround.v | 2 +- theories/Reals/Alembert.v | 2 +- theories/Reals/AltSeries.v | 2 +- theories/Reals/ArithProp.v | 2 +- theories/Reals/Binomial.v | 2 +- theories/Reals/Cauchy_prod.v | 2 +- theories/Reals/Cos_plus.v | 2 +- theories/Reals/Cos_rel.v | 2 +- theories/Reals/DiscrR.v | 2 +- theories/Reals/Exp_prop.v | 2 +- theories/Reals/Integration.v | 2 +- theories/Reals/MVT.v | 2 +- theories/Reals/Machin.v | 2 +- theories/Reals/NewtonInt.v | 2 +- theories/Reals/PSeries_reg.v | 2 +- theories/Reals/PartSum.v | 2 +- theories/Reals/RIneq.v | 2 +- theories/Reals/RList.v | 2 +- theories/Reals/ROrderedType.v | 2 +- theories/Reals/R_Ifp.v | 2 +- theories/Reals/R_sqr.v | 2 +- theories/Reals/R_sqrt.v | 2 +- theories/Reals/Ranalysis.v | 2 +- theories/Reals/Ranalysis1.v | 2 +- theories/Reals/Ranalysis2.v | 2 +- theories/Reals/Ranalysis3.v | 2 +- theories/Reals/Ranalysis4.v | 2 +- theories/Reals/Ranalysis5.v | 2 +- theories/Reals/Ranalysis_reg.v | 2 +- theories/Reals/Ratan.v | 2 +- theories/Reals/Raxioms.v | 2 +- theories/Reals/Rbase.v | 2 +- theories/Reals/Rbasic_fun.v | 2 +- theories/Reals/Rcomplete.v | 2 +- theories/Reals/Rdefinitions.v | 2 +- theories/Reals/Rderiv.v | 2 +- theories/Reals/Reals.v | 2 +- theories/Reals/Rfunctions.v | 2 +- theories/Reals/Rgeom.v | 2 +- theories/Reals/RiemannInt.v | 2 +- theories/Reals/RiemannInt_SF.v | 2 +- theories/Reals/Rlimit.v | 2 +- theories/Reals/Rlogic.v | 2 +- theories/Reals/Rminmax.v | 2 +- theories/Reals/Rpow_def.v | 2 +- theories/Reals/Rpower.v | 2 +- theories/Reals/Rprod.v | 2 +- theories/Reals/Rseries.v | 2 +- theories/Reals/Rsigma.v | 2 +- theories/Reals/Rsqrt_def.v | 2 +- theories/Reals/Rtopology.v | 2 +- theories/Reals/Rtrigo.v | 2 +- theories/Reals/Rtrigo1.v | 2 +- theories/Reals/Rtrigo_alt.v | 2 +- theories/Reals/Rtrigo_calc.v | 2 +- theories/Reals/Rtrigo_def.v | 2 +- theories/Reals/Rtrigo_fun.v | 2 +- theories/Reals/Rtrigo_reg.v | 2 +- theories/Reals/SeqProp.v | 2 +- theories/Reals/SeqSeries.v | 2 +- theories/Reals/SplitAbsolu.v | 2 +- theories/Reals/SplitRmult.v | 2 +- theories/Reals/Sqrt_reg.v | 2 +- theories/Relations/Operators_Properties.v | 2 +- theories/Relations/Relation_Definitions.v | 2 +- theories/Relations/Relation_Operators.v | 2 +- theories/Relations/Relations.v | 2 +- theories/Setoids/Setoid.v | 2 +- theories/Sets/Classical_sets.v | 2 +- theories/Sets/Constructive_sets.v | 2 +- theories/Sets/Cpo.v | 2 +- theories/Sets/Ensembles.v | 2 +- theories/Sets/Finite_sets.v | 2 +- theories/Sets/Finite_sets_facts.v | 2 +- theories/Sets/Image.v | 2 +- theories/Sets/Infinite_sets.v | 2 +- theories/Sets/Integers.v | 2 +- theories/Sets/Multiset.v | 2 +- theories/Sets/Partial_Order.v | 2 +- theories/Sets/Permut.v | 2 +- theories/Sets/Powerset.v | 2 +- theories/Sets/Powerset_Classical_facts.v | 2 +- theories/Sets/Powerset_facts.v | 2 +- theories/Sets/Relations_1.v | 2 +- theories/Sets/Relations_1_facts.v | 2 +- theories/Sets/Relations_2.v | 2 +- theories/Sets/Relations_2_facts.v | 2 +- theories/Sets/Relations_3.v | 2 +- theories/Sets/Relations_3_facts.v | 2 +- theories/Sets/Uniset.v | 2 +- theories/Sorting/Heap.v | 2 +- theories/Sorting/Mergesort.v | 2 +- theories/Sorting/PermutEq.v | 2 +- theories/Sorting/PermutSetoid.v | 2 +- theories/Sorting/Permutation.v | 2 +- theories/Sorting/Sorted.v | 2 +- theories/Sorting/Sorting.v | 2 +- theories/Strings/Ascii.v | 2 +- theories/Strings/String.v | 2 +- theories/Structures/EqualitiesFacts.v | 4 +- theories/Structures/OrderedType.v | 2 +- theories/Structures/OrdersEx.v | 2 +- theories/Structures/OrdersFacts.v | 2 +- theories/Structures/OrdersLists.v | 4 +- theories/Unicode/Utf8.v | 2 +- theories/Unicode/Utf8_core.v | 2 +- theories/Wellfounded/Disjoint_Union.v | 2 +- theories/Wellfounded/Inclusion.v | 2 +- theories/Wellfounded/Inverse_Image.v | 2 +- .../Wellfounded/Lexicographic_Exponentiation.v | 4 +- theories/Wellfounded/Lexicographic_Product.v | 2 +- theories/Wellfounded/Transitive_Closure.v | 2 +- theories/Wellfounded/Union.v | 2 +- theories/Wellfounded/Well_Ordering.v | 2 +- theories/Wellfounded/Wellfounded.v | 2 +- theories/ZArith/BinInt.v | 2 +- theories/ZArith/BinIntDef.v | 2 +- theories/ZArith/Wf_Z.v | 2 +- theories/ZArith/ZArith.v | 2 +- theories/ZArith/ZArith_base.v | 2 +- theories/ZArith/ZArith_dec.v | 2 +- theories/ZArith/Zabs.v | 2 +- theories/ZArith/Zbool.v | 2 +- theories/ZArith/Zcompare.v | 2 +- theories/ZArith/Zcomplements.v | 2 +- theories/ZArith/Zdigits.v | 2 +- theories/ZArith/Zdiv.v | 4 +- theories/ZArith/Zeuclid.v | 2 +- theories/ZArith/Zeven.v | 2 +- theories/ZArith/Zgcd_alt.v | 2 +- theories/ZArith/Zhints.v | 2 +- theories/ZArith/Zlogarithm.v | 2 +- theories/ZArith/Zmax.v | 2 +- theories/ZArith/Zmin.v | 2 +- theories/ZArith/Zminmax.v | 2 +- theories/ZArith/Zmisc.v | 2 +- theories/ZArith/Znat.v | 2 +- theories/ZArith/Znumtheory.v | 2 +- theories/ZArith/Zorder.v | 2 +- theories/ZArith/Zpow_alt.v | 4 +- theories/ZArith/Zpow_def.v | 2 +- theories/ZArith/Zpow_facts.v | 2 +- theories/ZArith/Zpower.v | 2 +- theories/ZArith/Zquot.v | 4 +- theories/ZArith/Zsqrt_compat.v | 2 +- theories/ZArith/Zwf.v | 2 +- theories/ZArith/auxiliary.v | 2 +- theories/theories.itarget | 1 - tools/compat5.ml | 2 +- tools/compat5.mlp | 2 +- tools/compat5b.ml | 2 +- tools/compat5b.mlp | 2 +- tools/coq_makefile.ml | 2 +- tools/coq_tex.ml | 2 +- tools/coqc.ml | 2 +- tools/coqdep.ml | 61 +- tools/coqdep_boot.ml | 14 +- tools/coqdep_common.ml | 38 +- tools/coqdep_common.mli | 24 +- tools/coqdep_lexer.mli | 2 +- tools/coqdep_lexer.mll | 2 +- tools/coqdoc/alpha.ml | 2 +- tools/coqdoc/alpha.mli | 2 +- tools/coqdoc/cdglobals.ml | 2 +- tools/coqdoc/cpretty.mli | 2 +- tools/coqdoc/cpretty.mll | 2 +- tools/coqdoc/index.ml | 2 +- tools/coqdoc/index.mli | 2 +- tools/coqdoc/main.ml | 2 +- tools/coqdoc/output.ml | 2 +- tools/coqdoc/output.mli | 2 +- tools/coqdoc/tokens.ml | 2 +- tools/coqdoc/tokens.mli | 2 +- tools/coqmktop.ml | 4 +- tools/coqwc.mll | 2 +- tools/coqworkmgr.ml | 2 +- tools/fake_ide.ml | 2 +- tools/gallina.ml | 2 +- tools/gallina_lexer.mll | 2 +- toplevel/assumptions.ml | 4 +- toplevel/assumptions.mli | 2 +- toplevel/auto_ind_decl.ml | 2 +- toplevel/auto_ind_decl.mli | 2 +- toplevel/cerrors.ml | 2 +- toplevel/cerrors.mli | 2 +- toplevel/class.ml | 2 +- toplevel/class.mli | 2 +- toplevel/classes.ml | 4 +- toplevel/classes.mli | 2 +- toplevel/command.ml | 13 +- toplevel/command.mli | 2 +- toplevel/coqinit.ml | 2 +- toplevel/coqinit.mli | 2 +- toplevel/coqloop.ml | 2 +- toplevel/coqloop.mli | 2 +- toplevel/coqtop.ml | 11 +- toplevel/coqtop.mli | 2 +- toplevel/discharge.ml | 2 +- toplevel/discharge.mli | 2 +- toplevel/g_obligations.ml4 | 2 +- toplevel/himsg.ml | 9 +- toplevel/himsg.mli | 2 +- toplevel/ind_tables.ml | 2 +- toplevel/ind_tables.mli | 2 +- toplevel/indschemes.ml | 23 +- toplevel/indschemes.mli | 2 +- toplevel/locality.ml | 2 +- toplevel/locality.mli | 2 +- toplevel/metasyntax.ml | 2 +- toplevel/metasyntax.mli | 2 +- toplevel/mltop.ml | 2 +- toplevel/mltop.mli | 2 +- toplevel/obligations.ml | 43 +- toplevel/obligations.mli | 6 +- toplevel/record.ml | 2 +- toplevel/record.mli | 2 +- toplevel/search.ml | 2 +- toplevel/search.mli | 2 +- toplevel/usage.ml | 5 +- toplevel/usage.mli | 2 +- toplevel/vernac.ml | 8 +- toplevel/vernac.mli | 6 +- toplevel/vernacentries.ml | 21 +- toplevel/vernacentries.mli | 2 +- toplevel/vernacinterp.ml | 2 +- toplevel/vernacinterp.mli | 2 +- 1306 files changed, 5000 insertions(+), 10164 deletions(-) create mode 100755 dev/make-macos-dmg.sh create mode 100644 test-suite/bugs/closed/3257.v create mode 100644 test-suite/bugs/closed/3554.v create mode 100644 test-suite/bugs/closed/3735.v create mode 100644 test-suite/bugs/closed/3746.v create mode 100644 test-suite/bugs/closed/3807.v create mode 100644 test-suite/bugs/closed/3848.v create mode 100644 test-suite/bugs/closed/3923.v create mode 100644 test-suite/bugs/closed/3998.v create mode 100644 test-suite/bugs/closed/4149.v create mode 100644 test-suite/bugs/closed/4256.v create mode 100644 test-suite/bugs/closed/4273.v create mode 100644 test-suite/bugs/closed/4284.v create mode 100644 test-suite/bugs/closed/4293.v create mode 100644 test-suite/bugs/closed/4363.v create mode 100644 test-suite/bugs/closed/4400.v create mode 100644 test-suite/bugs/closed/4404.v create mode 100644 test-suite/bugs/closed/4412.v create mode 100644 test-suite/bugs/closed/4420.v create mode 100644 test-suite/bugs/closed/4429.v create mode 100644 test-suite/bugs/closed/4433.v create mode 100644 test-suite/bugs/closed/4443.v create mode 100644 test-suite/bugs/closed/4453.v create mode 100644 test-suite/bugs/closed/4456.v create mode 100644 test-suite/bugs/closed/4462.v create mode 100644 test-suite/bugs/closed/4467.v create mode 100644 test-suite/bugs/closed/4480.v create mode 100644 test-suite/bugs/closed/4484.v delete mode 100644 test-suite/bugs/opened/3554.v delete mode 100644 test-suite/bugs/opened/3848.v create mode 100644 test-suite/complexity/f_equal.v delete mode 100644 test-suite/kernel/vm-univ.v create mode 100644 test-suite/success/extraction_impl.v create mode 100644 test-suite/success/unshelve.v create mode 100644 test-suite/success/vm_univ_poly.v create mode 100644 test-suite/success/vm_univ_poly_match.v create mode 100644 theories/Compat/AdmitAxiom.v delete mode 100644 theories/MMaps/MMapAVL.v delete mode 100644 theories/MMaps/MMapFacts.v delete mode 100644 theories/MMaps/MMapInterface.v delete mode 100644 theories/MMaps/MMapList.v delete mode 100644 theories/MMaps/MMapPositive.v delete mode 100644 theories/MMaps/MMapWeakList.v delete mode 100644 theories/MMaps/MMaps.v delete mode 100644 theories/MMaps/vo.itarget diff --git a/CHANGES b/CHANGES index 7b50dfae..531d5049 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,33 @@ +Changes from V8.5beta3 to V8.5 +============================== + +Tools + +- Flag "-compat 8.4" now loads Coq.Compat.Coq84. The standard way of + putting Coq in v8.4 compatibility mode is to pass the command line flag + "-compat 8.4". It can be followed by "-require Coq.Compat.AdmitAxiom" + if the 8.4 behavior of admit is needed, in which case it uses an axiom. + +Specification language + +- Syntax "$(tactic)$" changed to "ltac:(tactic)". + +Tactics + +- Syntax "destruct !hyp" changed to "destruct (hyp)", and similarly + for induction (rare source of incompatibilities easily solvable by + removing parentheses around "hyp" when not for the purpose of keeping + the hypothesis). +- Syntax "p/c" for on-the-fly application of a lemma c before + introducing along pattern p changed to p%c1..%cn. The feature and + syntax are in experimental stage. +- "Proof using" does not clear unused section variables. +- Tactic "refine" has been changed back to the 8.4 behavior of shelving subgoals + that occur in other subgoals. The "refine" tactic of 8.5beta3 has been + renamed "simple refine"; it does not shelve any subgoal. +- New tactical "unshelve tac" which grab existential variables put on + the tactic shelve by the execution of "tac". + Changes from V8.5beta2 to V8.5beta3 =================================== @@ -9,6 +39,7 @@ Vernacular commands declaration of all polymorphic universes appearing in a definition when introducing it. - New command "Show id" to show goal named id. +- Option "Virtual Machine" removed. Tactics @@ -67,6 +98,14 @@ Tools - The -require and -load-vernac-object command-line options now take a logical path of a given library rather than a physical path, thus they behave like Require [Import] path. +- The -vm command-line option has been removed. + +Standard Library + + - There is now a Coq.Compat.Coq84 library, which sets the various compatibility + options and does a few redefinitions to make Coq behave more like Coq v8.4. + The standard way of putting Coq in v8.4 compatibility mode is to pass the command + line flags "-require Coq.Compat.Coq84 -compat 8.4". Changes from V8.5beta1 to V8.5beta2 =================================== @@ -76,6 +115,10 @@ Logic - The VM now supports inductive types with up to 8388851 non-constant constructors and up to 8388607 constant ones. +Specification language + +- Syntax "$(tactic)$" changed to "ltac: tactic". + Tactics - A script using the admit tactic can no longer be concluded by either @@ -100,8 +143,6 @@ API - The interface of [change] has changed to take a [change_arg], which can be built from a [constr] using [make_change_arg]. -- [pattern_of_constr] now returns a triplet including the cleaned-up - [evar_map], removing the evars that were turned into metas. Changes from V8.4 to V8.5beta1 ============================== @@ -397,6 +438,9 @@ Program - "Solve Obligations using" changed to "Solve Obligations with", consistent with "Proof with". - Program Lemma, Definition now respect automatic introduction. +- Program Lemma, Definition, etc.. now interpret "->" like Lemma and + Definition as a non-dependent arrow (potential source of + incompatibility). - Add/document "Set Hide Obligations" (to hide obligations in the final term inside an implicit argument) and "Set Shrink Obligations" (to minimize dependencies of obligations defined by tactics). @@ -453,11 +497,9 @@ Interfaces documentation of OCaml's Str module for the supported syntax. - Many CoqIDE windows, including the query one, are now detachable to improve usability on multi screen work stations. - - Coqtop/coqc outputs highlighted syntax. Colors can be configured thanks to the COQ_COLORS environment variable, and their current state can be displayed with the -list-tags command line option. - - Third party user interfaces can install their main loop in $COQLIB/toploop and call coqtop with the -toploop flag to select it. diff --git a/INSTALL.doc b/INSTALL.doc index 76588005..2472d2b2 100644 --- a/INSTALL.doc +++ b/INSTALL.doc @@ -22,8 +22,8 @@ To produce all the documents, the following tools are needed: - dvips - bibtex - makeindex - - fig2dev - - convert + - fig2dev (transfig) + - convert (ImageMagick) - hevea - hacha diff --git a/Makefile.build b/Makefile.build index 0455a247..48f448ce 100644 --- a/Makefile.build +++ b/Makefile.build @@ -132,10 +132,11 @@ SYSMOD:=str unix dynlink threads SYSCMA:=$(addsuffix .cma,$(SYSMOD)) SYSCMXA:=$(addsuffix .cmxa,$(SYSMOD)) +# We do not repeat the dependencies already in SYSMOD here ifeq ($(CAMLP4),camlp5) P4CMA:=gramlib.cma else -P4CMA:=dynlink.cma camlp4lib.cma +P4CMA:=camlp4lib.cma endif @@ -294,9 +295,10 @@ checker/check.cmxa: | md5chk checker/check.mllib.d # Csdp to micromega special targets ########################################################################### -plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ)) +plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ)) \ + $(addsuffix $(BESTLIB), lib/clib) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,nums unix) + $(HIDE)$(call bestocaml,,nums unix clib) ########################################################################### # CoqIde special targets @@ -494,7 +496,7 @@ check: validate test-suite test-suite: world $(ALLSTDLIB).v $(MAKE) $(MAKE_TSOPTS) clean $(MAKE) $(MAKE_TSOPTS) all - $(HIDE)if grep -F 'Error!' test-suite/summary.log ; then false; fi + $(MAKE) $(MAKE_TSOPTS) report ################################################################## # partial targets: 1) core ML parts @@ -553,7 +555,6 @@ program: $(PROGRAMVO) structures: $(STRUCTURESVO) vectors: $(VECTORSVO) msets: $(MSETSVO) -mmaps: $(MMAPSVO) compat: $(COMPATVO) noreal: unicode logic arith bool zarith qarith lists sets fsets \ @@ -586,9 +587,9 @@ pluginsbyte: $(PLUGINS) ########################################################################### theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) | theories/Init/%.v.d - $(SHOW)'COQC -noinit $<' + $(SHOW)'COQC $(COQ_XML) -noinit $<' $(HIDE)rm -f theories/Init/$*.glob - $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq + $(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml $(OCAML) $< $(TOTARGET) @@ -882,7 +883,7 @@ dev/printers.cma: | dev/printers.mllib.d $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $^ -o test-printer @rm -f test-printer $(SHOW)'OCAMLC -a $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $^ -linkall -a -o $@ + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $^ -linkall -a -o $@ grammar/grammar.cma: | grammar/grammar.mllib.d $(SHOW)'Testing $@' diff --git a/Makefile.common b/Makefile.common index 92a48cd6..1a903539 100644 --- a/Makefile.common +++ b/Makefile.common @@ -293,7 +293,6 @@ STRINGSVO:=$(call cat_vo_itarget, theories/Strings) SETSVO:=$(call cat_vo_itarget, theories/Sets) FSETSVO:=$(call cat_vo_itarget, theories/FSets) MSETSVO:=$(call cat_vo_itarget, theories/MSets) -MMAPSVO:=$(call cat_vo_itarget, theories/MMaps) RELATIONSVO:=$(call cat_vo_itarget, theories/Relations) WELLFOUNDEDVO:=$(call cat_vo_itarget, theories/Wellfounded) REALSVO:=$(call cat_vo_itarget, theories/Reals) @@ -310,7 +309,7 @@ THEORIESVO:=\ $(RELATIONSVO) $(WELLFOUNDEDVO) $(SETOIDSVO) \ $(LISTSVO) $(STRINGSVO) \ $(PARITHVO) $(NARITHVO) $(ZARITHVO) \ - $(SETSVO) $(FSETSVO) $(MSETSVO) $(MMAPSVO) \ + $(SETSVO) $(FSETSVO) $(MSETSVO) \ $(REALSVO) $(SORTINGVO) $(QARITHVO) \ $(NUMBERSVO) $(STRUCTURESVO) $(VECTORSVO) \ $(COMPATVO) diff --git a/checker/check.ml b/checker/check.ml index 21c8f1c5..3a5c9121 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* universes -> bool (** {6 Support for universe polymorphism } *) (** Polymorphic maps from universe levels to 'a *) -module LMap : Map.S with type key = universe_level +module LMap : CSig.MapS with type key = universe_level module LSet : CSig.SetS with type elt = universe_level type 'a universe_map = 'a LMap.t diff --git a/checker/validate.ml b/checker/validate.ml index 63180f05..c434ef09 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Require Import command.

theories/MSets/MSetPositive.v theories/MSets/MSetToFiniteSet.v (theories/MSets/MSets.v) - theories/MMaps/MMapAVL.v - theories/MMaps/MMapFacts.v - theories/MMaps/MMapInterface.v - theories/MMaps/MMapList.v - theories/MMaps/MMapPositive.v - theories/MMaps/MMapWeakList.v - (theories/MMaps/MMaps.v)
FSets: @@ -617,6 +610,7 @@ through the Require Import command.

Compatibility wrappers for previous versions of Coq
+ theories/Compat/AdmitAxiom.v theories/Compat/Coq84.v theories/Compat/Coq85.v
diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index fe0959dd..8def9537 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* CFBundleGetInfoString Coq_vVERSION NSHumanReadableCopyright - Copyright 1999-2015, The Coq Development Team INRIA - CNRS - LIX - LRI - PPS + Copyright 1999-2016, The Coq Development Team INRIA - CNRS - LIX - LRI - PPS CFBundleHelpBookFolder share/doc/coq/html/ CFAppleHelpAnchor diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll index 36715356..ac9cc57b 100644 --- a/ide/config_lexer.mll +++ b/ide/config_lexer.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ())) () = ~f:(fun s -> current.project_file_name <- s) current.project_file_name in - let update_modifiers prefix mds = - let change ~path ~key ~modi ~changed = - if CString.is_sub prefix path 0 then - ignore (GtkData.AccelMap.change_entry ~key ~modi:mds ~replace:true path) - in - GtkData.AccelMap.foreach change - in let help_string = "restart to apply" in let the_valid_mod = str_to_mod_list current.modifiers_valid in let modifier_for_tactics = - let cb l = - current.modifier_for_tactics <- mod_list_to_str l; - update_modifiers "/Tactics/" l - in modifiers ~allow:the_valid_mod - ~f:cb + ~f:(fun l -> current.modifier_for_tactics <- mod_list_to_str l) ~help:help_string "Modifiers for Tactics Menu" (str_to_mod_list current.modifier_for_tactics) in let modifier_for_templates = - let cb l = - current.modifier_for_templates <- mod_list_to_str l; - update_modifiers "/Templates/" l - in modifiers ~allow:the_valid_mod - ~f:cb + ~f:(fun l -> current.modifier_for_templates <- mod_list_to_str l) ~help:help_string "Modifiers for Templates Menu" (str_to_mod_list current.modifier_for_templates) in let modifier_for_navigation = - let cb l = - current.modifier_for_navigation <- mod_list_to_str l; - update_modifiers "/Navigation/" l - in modifiers ~allow:the_valid_mod - ~f:cb + ~f:(fun l -> current.modifier_for_navigation <- mod_list_to_str l) ~help:help_string "Modifiers for Navigation Menu" (str_to_mod_list current.modifier_for_navigation) in let modifier_for_display = - let cb l = - current.modifier_for_display <- mod_list_to_str l; - update_modifiers "/View/" l - in modifiers ~allow:the_valid_mod - ~f:cb + ~f:(fun l -> current.modifier_for_display <- mod_list_to_str l) ~help:help_string "Modifiers for View Menu" (str_to_mod_list current.modifier_for_display) @@ -777,6 +754,13 @@ let configure ?(apply=(fun () -> ())) () = "Allowed modifiers" the_valid_mod in + let modifier_notice = + let b = GPack.hbox () in + let _lbl = + GMisc.label ~markup:"You need to restart CoqIDE after changing these settings" + ~packing:b#add () in + custom b (fun () -> ()) true + in let cmd_editor = let predefined = [ "emacs %s"; "vi %s"; "NOTEPAD %s" ] in combo @@ -878,7 +862,7 @@ let configure ?(apply=(fun () -> ())) () = [automatic_tactics]); Section("Shortcuts", Some `PREFERENCES, [modifiers_valid; modifier_for_tactics; - modifier_for_templates; modifier_for_display; modifier_for_navigation]); + modifier_for_templates; modifier_for_display; modifier_for_navigation; modifier_notice]); Section("Misc", Some `ADD, misc)] in diff --git a/ide/preferences.mli b/ide/preferences.mli index 1e4f152c..4095eb66 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ] -> "" | [< 'c; s >] -> (String.make 1 c)^(parse_string2 s) + | [< >] -> raise Parsing_error and parse_skip_comment = parser | [< ''\n'; s >] -> s | [< 'c; s >] -> parse_skip_comment s @@ -47,7 +48,7 @@ let parse f = res let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) l = function - | [] -> opts,List.rev l + | [] -> opts, l | ("-h"|"--help") :: _ -> raise Parsing_error | ("-no-opt"|"-byte") :: r -> @@ -127,6 +128,10 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) else if (Filename.check_suffix f ".mlpack") then MLPACK f else Subdir f) :: l) r +let process_cmd_line orig_dir opts l args = + let (opts, l) = process_cmd_line orig_dir opts l args in + opts, List.rev l + let rec post_canonize f = if Filename.basename f = Filename.current_dir_name then let dir = Filename.dirname f in diff --git a/ide/sentence.ml b/ide/sentence.ml index dd6b10a4..0f6c1168 100644 --- a/ide/sentence.ml +++ b/ide/sentence.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + match r with + | VarRef v -> make_qualid DirPath.empty v + | ConstRef c -> make_qualid DirPath.empty Names.(Label.to_id (con_label c)) + | IndRef (i,_) | ConstructRef ((i,_),_) -> + make_qualid DirPath.empty Names.(Label.to_id (mind_label i)) + let default_extern_reference loc vars r = - Qualid (loc,shortest_qualid_of_global vars r) + Qualid (loc,safe_shortest_qualid_of_global vars r) let my_extern_reference = ref default_extern_reference @@ -438,8 +447,8 @@ let is_projection nargs = function | Some r when not !Flags.in_debugger && not !Flags.raw_print && !print_projections -> (try let n = Recordops.find_projection_nparams r + 1 in - if n <= nargs then None - else Some n + if n <= nargs then Some n + else None with Not_found -> None) | _ -> None diff --git a/interp/constrextern.mli b/interp/constrextern.mli index b797e455..bf1f529c 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (function |Name id -> Some (id, Impargs.Manual, (true,true)) - |Anonymous -> anomaly (Pp.str "Anonymous implicit argument")) + |Anonymous -> Some (Id.of_string "_", Impargs.Manual, (true,true))) |Explicit -> fun _ -> None let impls_type_list ?(args = []) = diff --git a/interp/constrintern.mli b/interp/constrintern.mli index b671c988..22cf910b 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty)) - else + | NoGlob -> () + | _ when not (Loc.is_ghost loc) -> let bl,el = interval loc in dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" bl el filepath modpath ident ty) + | _ -> () let dump_reference loc modpath ident ty = let filepath = Names.DirPath.to_string (Lib.library_dp ()) in diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 428189be..a7c79911 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - List.fold_left vars_of (List.fold_left vars_of [] l2) l1 - (* assume the ntn is applicative and does not instantiate the head !! *) - | CPatDelimiters(_,_,c) -> vars_of ids c - | CPatAtom (_, Some (Libnames.Ident (_, x))) -> x::ids - | _ -> ids in - vars_of [] - -let ids_of_cases_tomatch tms = - List.fold_right - (fun (_,(ona,indnal)) l -> - Option.fold_right (fun t -> (@) (ids_of_cases_indtype t)) - indnal (Option.fold_right (Loc.down_located name_cons) ona l)) - tms [] - let is_constructor id = - try ignore (Nametab.locate_extended (qualid_of_ident id)); true - with Not_found -> true + try Globnames.isConstructRef + (Smartlocate.global_of_extended_global + (Nametab.locate_extended (qualid_of_ident id))) + with Not_found -> false let rec cases_pattern_fold_names f a = function | CPatRecord (_, l) -> @@ -82,6 +66,17 @@ let ids_of_pattern_list = (List.fold_left (cases_pattern_fold_names Id.Set.add))) Id.Set.empty +let ids_of_cases_indtype p = + Id.Set.elements (cases_pattern_fold_names Id.Set.add Id.Set.empty p) + +let ids_of_cases_tomatch tms = + List.fold_right + (fun (_,(ona,indnal)) l -> + Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t) + indnal + (Option.fold_right (Loc.down_located (name_fold Id.Set.add)) ona l)) + tms Id.Set.empty + let rec fold_constr_expr_binders g f n acc b = function | (nal,bk,t)::l -> let nal = snd (List.split nal) in @@ -119,7 +114,7 @@ let fold_constr_expr_with_binders g f n acc = function | 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 + let acc = Option.fold_left (f (Id.Set.fold g ids n)) acc rtnpo in let acc = List.fold_left (f n) acc (List.map fst al) in List.fold_right (fun (loc,patl,rhs) acc -> let ids = ids_of_pattern_list patl in @@ -220,10 +215,11 @@ let map_constr_expr_with_binders g f e = function | CPrim _ | 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 + let bl = List.map (fun (loc,patl,rhs) -> + let ids = ids_of_pattern_list patl in + (loc,patl,f (Id.Set.fold g ids e) rhs)) bl in let ids = ids_of_cases_tomatch a in - let po = Option.map (f (List.fold_right g ids e)) rtnpo in + let po = Option.map (f (Id.Set.fold g ids e)) rtnpo in CCases (loc, sty, po, List.map (fun (tm,x) -> (f e tm,x)) a,bl) | CLetTuple (loc,nal,(ona,po),b,c) -> let e' = List.fold_right (Loc.down_located (name_fold g)) nal e in diff --git a/interp/topconstr.mli b/interp/topconstr.mli index b25d7082..1e867c19 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* {utj_val = c; utj_type = s } @@ -52,8 +52,8 @@ let assumption_of_judgment env t ty = error_assumption env (make_judge t ty) (************************************************) -(* Incremental typing rules: builds a typing judgement given the *) -(* judgements for the subterms. *) +(* Incremental typing rules: builds a typing judgment given the *) +(* judgments for the subterms. *) (*s Type of sorts *) diff --git a/kernel/fast_typeops.mli b/kernel/fast_typeops.mli index 90d9c55f..05d52b2d 100644 --- a/kernel/fast_typeops.mli +++ b/kernel/fast_typeops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (* type without constructors *) true | _ -> false -let infos_and_sort env ctx t = - let rec aux env ctx t max = +let infos_and_sort env t = + let rec aux env t max = let t = whd_betadeltaiota env t in match kind_of_term t with | Prod (name,c1,c2) -> let varj = infer_type env c1 in let env1 = Environ.push_rel (name,None,varj.utj_val) env in let max = Universe.sup max (univ_of_sort varj.utj_type) in - aux env1 ctx c2 max + aux env1 c2 max | _ when is_constructor_head t -> max | _ -> (* don't fail if not positive, it is tested later *) max - in aux env ctx t Universe.type0m + in aux env t Universe.type0m (* Computing the levels of polymorphic inductive types @@ -148,14 +148,14 @@ let infos_and_sort env ctx t = (* This (re)computes informations relevant to extraction and the sort of an arity or type constructor; we do not to recompute universes constraints *) -let infer_constructor_packet env_ar_par ctx params lc = +let infer_constructor_packet env_ar_par params lc = (* type-check the constructors *) let jlc = List.map (infer_type env_ar_par) lc in let jlc = Array.of_list jlc in (* generalize the constructor over the parameters *) let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in (* compute the max of the sorts of the products of the constructors types *) - let levels = List.map (infos_and_sort env_ar_par ctx) lc in + let levels = List.map (infos_and_sort env_ar_par) lc in let isunit = is_unit levels in let min = if Array.length jlc > 1 then Universe.type0 else Universe.type0m in let level = List.fold_left (fun max l -> Universe.sup max l) min levels in @@ -261,8 +261,7 @@ let typecheck_inductive env mie = List.fold_right2 (fun ind arity_data inds -> let (lc',cstrs_univ) = - infer_constructor_packet env_ar_par ContextSet.empty - params ind.mind_entry_lc in + infer_constructor_packet env_ar_par params ind.mind_entry_lc in let consnames = ind.mind_entry_consnames in let ind' = (arity_data,consnames,lc',cstrs_univ) in ind'::inds) @@ -337,7 +336,7 @@ let typecheck_inductive env mie = type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int - | LocalNotConstructor + | LocalNotConstructor of rel_context * constr list | LocalNonPar of int * int * int exception IllFormedInd of ill_formed_ind @@ -348,7 +347,7 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum -let explain_ind_err id ntyp env nbpar c nargs err = +let explain_ind_err id ntyp env nbpar c err = let (lpar,c') = mind_extract_params nbpar c in match err with | LocalNonPos kt -> @@ -356,9 +355,11 @@ let explain_ind_err id ntyp env nbpar c nargs err = | LocalNotEnoughArgs kt -> raise (InductiveError (NotEnoughArgs (env,c',mkRel (kt+nbpar)))) - | LocalNotConstructor -> + | LocalNotConstructor (paramsctxt,args)-> + let nparams = rel_context_nhyps paramsctxt in raise (InductiveError - (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nbpar,nargs))) + (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nparams, + List.length args - nparams))) | LocalNonPar (n,i,l) -> raise (InductiveError (NonPar (env,c',n,mkRel i, mkRel (l+nbpar)))) @@ -547,7 +548,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname begin match hd with | Rel j when Int.equal j (n + ntypes - i - 1) -> check_correct_par ienv hyps (ntypes - i) largs - | _ -> raise (IllFormedInd LocalNotConstructor) + | _ -> raise (IllFormedInd (LocalNotConstructor(hyps,largs))) end else if not (List.for_all (noccur_between n ntypes) largs) @@ -563,7 +564,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname try check_constructors ienv true nmr rawc with IllFormedInd err -> - explain_ind_err id (ntypes-i) env lparams c nargs err) + explain_ind_err id (ntypes-i) env lparams c err) (Array.of_list lcnames) indlc in let irecargs = Array.map snd irecargs_nmr @@ -652,14 +653,13 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params that typechecking projections requires just a substitution and not matching with a parameter context. *) let indty, paramsletsubst = - let subst, inst = + let _, _, subst, inst = List.fold_right - (fun (na, b, t) (subst, inst) -> + (fun (na, b, t) (i, j, subst, inst) -> match b with - | None -> (mkRel 1 :: List.map (lift 1) subst, - mkRel 1 :: List.map (lift 1) inst) - | Some b -> (substl subst b) :: subst, List.map (lift 1) inst) - paramslet ([], []) + | None -> (i-1, j-1, mkRel i :: subst, mkRel j :: inst) + | Some b -> (i, j-1, substl subst b :: subst, inst)) + paramslet (nparamargs, List.length paramslet, [], []) in let subst = (* For the record parameter: *) mkRel 1 :: List.map (lift 1) subst @@ -689,14 +689,37 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params in let projections (na, b, t) (i, j, kns, pbs, subst, letsubst) = match b with - | Some c -> (i, j+1, kns, pbs, substl subst c :: subst, - substl letsubst c :: subst) + | Some c -> + (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] + to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *) + let c = liftn 1 j c in + (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] + to [params, x:I |- c(params,proj1 x,..,projj x)] *) + let c1 = substl subst c in + (* From [params, x:I |- subst:field1,..,fieldj] + to [params, x:I |- subst:field1,..,fieldj+1] where [subst] + is represented with instance of field1 last *) + let subst = c1 :: subst in + (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] + to [params-wo-let, x:I |- c(params,proj1 x,..,projj x)] *) + let c2 = substl letsubst c in + (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)] + to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *) + let letsubst = c2 :: letsubst in + (i, j+1, kns, pbs, subst, letsubst) | None -> match na with | Name id -> let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in - let projty = substl letsubst (liftn 1 j t) in - let ty = substl subst (liftn 1 j t) in + (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] + to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *) + let t = liftn 1 j t in + (* from [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj)] + to [params-wo-let, x:I |- t(params,proj1 x,..,projj x)] *) + let projty = substl letsubst t in + (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] + to [params, x:I |- t(proj1 x,..,projj x)] *) + let ty = substl subst t in let term = mkProj (Projection.make kn true, mkRel 1) in let fterm = mkProj (Projection.make kn false, mkRel 1) in let compat = compat_body ty (j - 1) in diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 01acdce5..a7bf8fab 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mp @@ -183,8 +183,11 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = begin try let mtb_old = module_type_of_module old in - Univ.ContextSet.add_constraints (Subtyping.check_subtypes env' mtb_mp1 mtb_old) old.mod_constraints - with Failure _ -> error_incorrect_with_constraint lab + let chk_cst = Subtyping.check_subtypes env' mtb_mp1 mtb_old in + Univ.ContextSet.add_constraints chk_cst old.mod_constraints + with Failure _ -> + (* TODO: where can a Failure come from ??? *) + error_incorrect_with_constraint lab end | Algebraic (NoFunctor (MEident(mp'))) -> check_modpath_equiv env' mp1 mp'; @@ -238,104 +241,89 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Not_found -> error_no_such_label lab | Reduction.NotConvertible -> error_incorrect_with_constraint lab -let mk_alg_with alg wd = Option.map (fun a -> MEwith (a,wd)) alg - let check_with env mp (sign,alg,reso,cst) = function |WithDef(idl,c) -> let struc = destr_nofunctor sign in let struc',c',cst' = check_with_def env struc (idl,c) mp reso in - let alg' = mk_alg_with alg (WithDef (idl,(c',Univ.ContextSet.to_context cst'))) in - (NoFunctor struc'),alg',reso, cst+++cst' + let wd' = WithDef (idl,(c',Univ.ContextSet.to_context cst')) in + NoFunctor struc', MEwith (alg,wd'), reso, cst+++cst' |WithMod(idl,mp1) as wd -> let struc = destr_nofunctor sign in let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in - let alg' = mk_alg_with alg wd in - (NoFunctor struc'),alg',reso', cst+++cst' + NoFunctor struc', MEwith (alg,wd), reso', cst+++cst' -let mk_alg_app mpo alg arg = match mpo, alg with - | Some _, Some alg -> Some (MEapply (alg,arg)) - | _ -> None +let translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = + let farg_id, farg_b, fbody_b = destr_functor sign in + let mtb = module_type_of_module (lookup_module mp1 env) in + let cst2 = Subtyping.check_subtypes env mtb farg_b in + let mp_delta = discr_resolver mtb in + let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in + let subst = map_mbid farg_id mp1 mp_delta in + let body = subst_signature subst fbody_b in + let alg' = mkalg alg mp1 in + let reso' = subst_codom_delta_resolver subst reso in + body,alg',reso', Univ.ContextSet.add_constraints cst2 cst1 (** Translation of a module struct entry : - We translate to a module when a [module_path] is given, otherwise to a module type. - The first output is the expanded signature - The second output is the algebraic expression, kept for the extraction. - It is never None when translating to a module, but for module type - it could not be contain [SEBapply] or [SEBfunctor]. *) +let mk_alg_app alg arg = MEapply (alg,arg) + let rec translate_mse env mpo inl = function - |MEident mp1 -> - let sign,reso = match mpo with - |Some mp -> - let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp false in - mb.mod_type, mb.mod_delta - |None -> - let mtb = lookup_modtype mp1 env in - mtb.mod_type, mtb.mod_delta + |MEident mp1 as me -> + let mb = match mpo with + |Some mp -> strengthen_and_subst_mb (lookup_module mp1 env) mp false + |None -> lookup_modtype mp1 env in - sign,Some (MEident mp1),reso,Univ.ContextSet.empty + mb.mod_type, me, mb.mod_delta, Univ.ContextSet.empty |MEapply (fe,mp1) -> - translate_apply env inl (translate_mse env mpo inl fe) mp1 (mk_alg_app mpo) + translate_apply env inl (translate_mse env mpo inl fe) mp1 mk_alg_app |MEwith(me, with_decl) -> assert (mpo == None); (* No 'with' syntax for modules *) let mp = mp_from_mexpr me in check_with env mp (translate_mse env None inl me) with_decl -and translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = - let farg_id, farg_b, fbody_b = destr_functor sign in - let mtb = module_type_of_module (lookup_module mp1 env) in - let cst2 = Subtyping.check_subtypes env mtb farg_b in - let mp_delta = discr_resolver mtb in - let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in - let subst = map_mbid farg_id mp1 mp_delta in - let body = subst_signature subst fbody_b in - let alg' = mkalg alg mp1 in - let reso' = subst_codom_delta_resolver subst reso in - body,alg',reso', Univ.ContextSet.add_constraints cst2 cst1 - -let mk_alg_funct mpo mbid mtb alg = match mpo, alg with - | Some _, Some alg -> Some (MoreFunctor (mbid,mtb,alg)) - | _ -> None - -let mk_mod mp e ty ty' cst reso = +let mk_mod mp e ty cst reso = { mod_mp = mp; mod_expr = e; mod_type = ty; - mod_type_alg = ty'; + mod_type_alg = None; mod_constraints = cst; mod_delta = reso; mod_retroknowledge = [] } -let mk_modtype mp ty cst reso = mk_mod mp Abstract ty None cst reso +let mk_modtype mp ty cst reso = mk_mod mp Abstract ty cst reso let rec translate_mse_funct env mpo inl mse = function |[] -> let sign,alg,reso,cst = translate_mse env mpo inl mse in - sign, Option.map (fun a -> NoFunctor a) alg, reso, cst + sign, NoFunctor alg, reso, cst |(mbid, ty) :: params -> let mp_id = MPbound mbid in let mtb = translate_modtype env mp_id inl ([],ty) in let env' = add_module_type mp_id mtb env in let sign,alg,reso,cst = translate_mse_funct env' mpo inl mse params in - let alg' = mk_alg_funct mpo mbid mtb alg in + let alg' = MoreFunctor (mbid,mtb,alg) in MoreFunctor (mbid, mtb, sign), alg',reso, cst +++ mtb.mod_constraints and translate_modtype env mp inl (params,mte) = let sign,alg,reso,cst = translate_mse_funct env None inl mte params in let mtb = mk_modtype (mp_from_mexpr mte) sign cst reso in let mtb' = subst_modtype_and_resolver mtb mp in - { mtb' with mod_type_alg = alg } + { mtb' with mod_type_alg = Some alg } (** [finalize_module] : - from an already-translated (or interactive) implementation - and a signature entry, produce a final [module_expr] *) + from an already-translated (or interactive) implementation and + an (optional) signature entry, produces a final [module_body] *) let finalize_module env mp (sign,alg,reso,cst) restype = match restype with |None -> let impl = match alg with Some e -> Algebraic e | None -> FullStruct in - mk_mod mp impl sign None cst reso + mk_mod mp impl sign cst reso |Some (params_mte,inl) -> let res_mtb = translate_modtype env mp inl params_mte in let auto_mtb = mk_modtype mp sign Univ.ContextSet.empty reso in @@ -344,33 +332,59 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with { res_mtb with mod_mp = mp; mod_expr = impl; - (** cst from module body typing, cst' from subtyping, - and constraints from module type. *) - mod_constraints = Univ.ContextSet.add_constraints cst' (cst +++ res_mtb.mod_constraints) } + (** cst from module body typing, + cst' from subtyping, + constraints from module type. *) + mod_constraints = + Univ.ContextSet.add_constraints cst' (cst +++ res_mtb.mod_constraints) } let translate_module env mp inl = function |MType (params,ty) -> let mtb = translate_modtype env mp inl (params,ty) in module_body_of_type mp mtb |MExpr (params,mse,oty) -> - let t = translate_mse_funct env (Some mp) inl mse params in + let (sg,alg,reso,cst) = translate_mse_funct env (Some mp) inl mse params in let restype = Option.map (fun ty -> ((params,ty),inl)) oty in - finalize_module env mp t restype + finalize_module env mp (sg,Some alg,reso,cst) restype + +(** We now forbid any Include of functors with restricted signatures. + Otherwise, we could end with the creation of undesired axioms + (see #3746). Note that restricted non-functorized modules are ok, + thanks to strengthening. *) + +let rec unfunct = function + |NoFunctor me -> me + |MoreFunctor(_,_,me) -> unfunct me + +let rec forbid_incl_signed_functor env = function + |MEapply(fe,_) -> forbid_incl_signed_functor env fe + |MEwith _ -> assert false (* No 'with' syntax for modules *) + |MEident mp1 -> + let mb = lookup_module mp1 env in + match mb.mod_type, mb.mod_type_alg, mb.mod_expr with + |MoreFunctor _, Some _, _ -> + (* functor + restricted signature = error *) + error_include_restricted_functor mp1 + |MoreFunctor _, None, Algebraic me -> + (* functor, no signature yet, a definition which may be restricted *) + forbid_incl_signed_functor env (unfunct me) + |_ -> () let rec translate_mse_inclmod env mp inl = function |MEident mp1 -> let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in let sign = clean_bounded_mod_expr mb.mod_type in - sign,None,mb.mod_delta,Univ.ContextSet.empty + sign,(),mb.mod_delta,Univ.ContextSet.empty |MEapply (fe,arg) -> let ftrans = translate_mse_inclmod env mp inl fe in - translate_apply env inl ftrans arg (fun _ _ -> None) + translate_apply env inl ftrans arg (fun _ _ -> ()) |MEwith _ -> assert false (* No 'with' syntax for modules *) let translate_mse_incl is_mod env mp inl me = if is_mod then + let () = forbid_incl_signed_functor env me in translate_mse_inclmod env mp inl me else let mtb = translate_modtype env mp inl ([],me) in let sign = clean_bounded_mod_expr mtb.mod_type in - sign,None,mtb.mod_delta,mtb.mod_constraints + sign,(),mtb.mod_delta,mtb.mod_constraints diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index bc0e2020..5949dad0 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* module_path -> inline -> module_entry -> module_body +(** [translate_modtype] produces a [module_type_body] whose [mod_type_alg] + cannot be [None] (and of course [mod_expr] is [Abstract]). *) + val translate_modtype : env -> module_path -> inline -> module_type_entry -> module_type_body @@ -24,20 +33,21 @@ val translate_modtype : - We translate to a module when a [module_path] is given, otherwise to a module type. - The first output is the expanded signature - - The second output is the algebraic expression, kept for the extraction. - It is never None when translating to a module, but for module type - it could not be contain applications or functors. -*) + - The second output is the algebraic expression, kept mostly for + the extraction. *) type 'alg translation = - module_signature * 'alg option * delta_resolver * Univ.ContextSet.t + module_signature * 'alg * delta_resolver * Univ.ContextSet.t val translate_mse : env -> module_path option -> inline -> module_struct_entry -> module_alg_expr translation +(** From an already-translated (or interactive) implementation and + an (optional) signature entry, produces a final [module_body] *) + val finalize_module : - env -> module_path -> module_expression translation -> + env -> module_path -> (module_expression option) translation -> (module_type_entry * inline) option -> module_body @@ -46,4 +56,4 @@ val finalize_module : val translate_mse_incl : bool -> env -> module_path -> inline -> module_struct_entry -> - module_alg_expr translation + unit translation diff --git a/kernel/modops.ml b/kernel/modops.ml index cbb79633..6fe7e382 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a -val error_application_to_not_path : module_struct_entry -> 'a - val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a @@ -152,3 +151,5 @@ val error_incorrect_with_constraint : Label.t -> 'a val error_generative_module_expected : Label.t -> 'a val error_no_such_label_sub : Label.t->string->'a + +val error_include_restricted_functor : module_path -> 'a diff --git a/kernel/names.ml b/kernel/names.ml index ae2b3b63..f5d954e9 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ModPath.t val constr_modpath : constructor -> ModPath.t diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 98b2d6d2..9d181b47 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* true + | Unix.WEXITED n -> + Pp.(msg_warning (str "command exited with status " ++ int n)); false + | Unix.WSIGNALED n -> + Pp.(msg_warning (str "command killed by signal " ++ int n)); false + | Unix.WSTOPPED n -> + Pp.(msg_warning (str "command stopped by signal " ++ int n)); false in + res, link_filename with Unix.Unix_error (e,_,_) -> Pp.(msg_warning (str (Unix.error_message e))); false, link_filename diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli index 0941dc56..12ad3cf2 100644 --- a/kernel/nativelib.mli +++ b/kernel/nativelib.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* stacklam (n-1) (arg::env) c stacktl - | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack + | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack | _ -> anomaly (Pp.str "Not enough lambda/let's") in stacklam n [] c (Array.to_list v) diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 0df26d62..9a83ca70 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - Environ.add_constant kn cb env + let env = Environ.add_constant kn cb env in + if not cb.const_polymorphic then + Environ.push_context ~strict:true cb.const_universes env + else env | kn, cb, `Opaque(_, ctx), _ -> - let env = Environ.add_constant kn cb env in - Environ.push_context_set - ~strict:(not cb.const_polymorphic) ctx env in + let env = Environ.add_constant kn cb env in + if not cb.const_polymorphic then + let env = Environ.push_context ~strict:true cb.const_universes env in + Environ.push_context_set ~strict:true ctx env + else env in let rec translate_seff sl seff acc env = match sl, seff with | _, [] -> List.rev acc, ce diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 2e6aa161..fcd95576 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* not (Level.is_prop x)) a); + a let to_array a = a @@ -1715,7 +1717,7 @@ struct let subst_fn fn t = let t' = CArray.smartmap fn t in - if t' == t then t else t' + if t' == t then t else of_array t' let levels x = LSet.of_array x @@ -2030,8 +2032,8 @@ let dump_universes output g = let dump_arc u = function | Canonical {univ=u; lt=lt; le=le} -> let u_str = Level.to_string u in - List.iter (fun v -> output Lt (Level.to_string v) u_str) lt; - List.iter (fun v -> output Le (Level.to_string v) u_str) le + List.iter (fun v -> output Lt u_str (Level.to_string v)) lt; + List.iter (fun v -> output Le u_str (Level.to_string v)) le | Equiv v -> output Eq (Level.to_string u) (Level.to_string v) in diff --git a/kernel/univ.mli b/kernel/univ.mli index c926c57b..9788f129 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr -> constr if two names are identical, the one of least indice is kept *) val subst_vars : Id.t list -> constr -> constr -(** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] +(** [substn_vars n [id1;...;idk] t] substitute [VAR idj] by [Rel j+n-1] in [t] if two names are identical, the one of least indice is kept *) val substn_vars : int -> Id.t list -> constr -> constr diff --git a/kernel/vconv.mli b/kernel/vconv.mli index 49e5d23e..7e5397c0 100644 --- a/kernel/vconv.mli +++ b/kernel/vconv.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds val pr_whd : whd -> Pp.std_ppcmds +val pr_stack : stack -> Pp.std_ppcmds (** Constructors *) diff --git a/lib/aux_file.ml b/lib/aux_file.ml index 5dedb0d0..f7bd81f8 100644 --- a/lib/aux_file.ml +++ b/lib/aux_file.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a -> 'a t -> 'a t val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t diff --git a/lib/cMap.mli b/lib/cMap.mli index 23d3801e..2f243da8 100644 --- a/lib/cMap.mli +++ b/lib/cMap.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool + val mem: key -> 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val singleton: key -> 'a -> 'a t + val remove: key -> 'a t -> 'a t + val merge: + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all: (key -> 'a -> bool) -> 'a t -> bool + val exists: (key -> 'a -> bool) -> 'a t -> bool + val filter: (key -> 'a -> bool) -> 'a t -> 'a t + val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + val cardinal: 'a t -> int + val bindings: 'a t -> (key * 'a) list + val min_binding: 'a t -> (key * 'a) + val max_binding: 'a t -> (key * 'a) + val choose: 'a t -> (key * 'a) + val split: key -> 'a t -> 'a t * 'a option * 'a t + val find: key -> 'a t -> 'a + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t +end diff --git a/lib/cString.ml b/lib/cString.ml index e9006860..0c2ed2e7 100644 --- a/lib/cString.ml +++ b/lib/cString.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* @@ -99,7 +101,8 @@ let _ = (** [check_file_else ~dir ~file oth] checks if [file] exists in the installation directory [dir] given relatively to [coqroot]. If this Coq is only locally built, then [file] must be in [coqroot]. - If the check fails, then [oth ()] is evaluated. *) + If the check fails, then [oth ()] is evaluated. + Using file system equality seems well enough for this heuristic *) let check_file_else ~dir ~file oth = let path = if Coq_config.local then coqroot else coqroot / dir in if Sys.file_exists (path / file) then path else oth () diff --git a/lib/envars.mli b/lib/envars.mli index b62b9f28..d95b6f09 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* EltSet.subset p1 p2 @@ -91,6 +91,7 @@ module Make(Ord: OrderedType) = | ((false,p1),(true,n2)) -> EltSet.is_empty (EltSet.inter p1 n2) | ((true,_),(false,_)) -> false + (* assumes the set is infinite *) let equal (b1,s1) (b2,s2) = b1=b2 && EltSet.equal s1 s2 diff --git a/lib/predicate.mli b/lib/predicate.mli index bcc89e72..cee3b0bd 100644 --- a/lib/predicate.mli +++ b/lib/predicate.mli @@ -1,67 +1,84 @@ +(** Infinite sets over a chosen [OrderedType]. -(** Module [Pred]: sets over infinite ordered types with complement. *) - -(** This module implements the set data structure, given a total ordering - function over the set elements. All operations over sets - are purely applicative (no side-effects). - The implementation uses the Set library. *) + All operations over sets are purely applicative (no side-effects). + *) +(** Input signature of the functor [Make]. *) module type OrderedType = sig type t - val compare: t -> t -> int + (** The type of the elements in the set. + + The chosen [t] {b must be infinite}. *) + + val compare : t -> t -> int + (** A total ordering function over the set elements. + This is a two-argument function [f] such that: + - [f e1 e2] is zero if the elements [e1] and [e2] are equal, + - [f e1 e2] is strictly negative if [e1] is smaller than [e2], + - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + *) end - (** The input signature of the functor [Pred.Make]. - [t] is the type of the set elements. - [compare] is a total ordering function over the set elements. - This is a two-argument function [f] such that - [f e1 e2] is zero if the elements [e1] and [e2] are equal, - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - Example: a suitable ordering function is - the generic structural comparison function [compare]. *) module type S = sig type elt - (** The type of the set elements. *) + (** The type of the elements in the set. *) + type t - (** The type of sets. *) + (** The type of sets. *) + val empty: t - (** The empty set. *) + (** The empty set. *) + val full: t - (** The whole type. *) + (** The set of all elements (of type [elm]). *) + val is_empty: t -> bool - (** Test whether a set is empty or not. *) + (** Test whether a set is empty or not. *) + val is_full: t -> bool - (** Test whether a set contains the whole type or not. *) + (** Test whether a set contains the whole type or not. *) + val mem: elt -> t -> bool - (** [mem x s] tests whether [x] belongs to the set [s]. *) + (** [mem x s] tests whether [x] belongs to the set [s]. *) + val singleton: elt -> t - (** [singleton x] returns the one-element set containing only [x]. *) + (** [singleton x] returns the one-element set containing only [x]. *) + val add: elt -> t -> t - (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], then [s] is returned unchanged. *) + val remove: elt -> t -> t (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged. *) + except [x]. If [x] was not in [s], then [s] is returned unchanged. *) + val union: t -> t -> t + (** Set union. *) + val inter: t -> t -> t + (** Set intersection. *) + val diff: t -> t -> t + (** Set difference. *) + val complement: t -> t - (** Union, intersection, difference and set complement. *) + (** Set complement. *) + val equal: t -> t -> bool - (** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. *) + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + val subset: t -> t -> bool (** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. *) + the set [s2]. *) + val elements: t -> bool * elt list (** Gives a finite representation of the predicate: if the boolean is false, then the predicate is given in extension. if it is true, then the complement is given *) end -module Make(Ord: OrderedType): (S with type elt = Ord.t) - (** Functor building an implementation of the set structure - given a totally ordered type. *) +(** The [Make] functor constructs an implementation for any [OrderedType]. *) +module Make (Ord : OrderedType) : (S with type elt = Ord.t) diff --git a/lib/profile.ml b/lib/profile.ml index c55064ca..2350cd43 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* prerr_endline ("kill: "^Printexc.to_string e) end @@ -247,13 +249,15 @@ let is_alive p = p.alive let uid { pid; } = string_of_int pid let unixpid { pid = pid; } = pid -let kill ({ pid = unixpid; oob_req; cin; cout; alive } as p) = +let kill ({ pid = unixpid; oob_req; oob_resp; cin; cout; alive } as p) = p.alive <- false; if not alive then prerr_endline "This process is already dead" else begin try output_death_sentence (uid p) oob_req; close_in_noerr cin; close_out_noerr cout; + close_in_noerr oob_resp; + close_out_noerr oob_req; if Sys.os_type = "Unix" then Unix.kill unixpid 9; with e -> prerr_endline ("kill: "^Printexc.to_string e) end diff --git a/lib/spawn.mli b/lib/spawn.mli index 8022573b..9b86b095 100644 --- a/lib/spawn.mli +++ b/lib/spawn.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* false + try Sys.is_directory dir with Sys_error _ -> false let skipped_dirnames = ref ["CVS"; "_darcs"] @@ -31,28 +30,62 @@ let all_subdirs ~unix_path:root = let l = ref [] in let add f rel = l := (f, rel) :: !l in let rec traverse dir rel = - let dirh = opendir dir in - try - while true do - let f = readdir dirh in - if ok_dirname f then - let file = Filename.concat dir f in - try - begin match (stat file).st_kind with - | S_DIR -> - let newrel = rel @ [f] in - add file newrel; - traverse file newrel - | _ -> () - end - with Unix_error (e,s1,s2) -> () - done - with End_of_file -> - closedir dirh + Array.iter (fun f -> + if ok_dirname f then + let file = Filename.concat dir f in + if Sys.is_directory file then begin + let newrel = rel @ [f] in + add file newrel; + traverse file newrel + end) + (Sys.readdir dir) in if exists_dir root then traverse root []; List.rev !l +(* Caching directory contents for efficient syntactic equality of file + names even on case-preserving but case-insensitive file systems *) + +module StrMod = struct + type t = string + let compare = compare +end + +module StrMap = Map.Make(StrMod) +module StrSet = Set.Make(StrMod) + +let dirmap = ref StrMap.empty + +let make_dir_table dir = + let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in + Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir) + +let exists_in_dir_respecting_case dir bf = + let contents, cached = + try StrMap.find dir !dirmap, true with Not_found -> + let contents = make_dir_table dir in + dirmap := StrMap.add dir contents !dirmap; + contents, false in + StrSet.mem bf contents || + if cached then begin + (* rescan, there is a new file we don't know about *) + let contents = make_dir_table dir in + dirmap := StrMap.add dir contents !dirmap; + StrSet.mem bf contents + end + else + false + +let file_exists_respecting_case path f = + (* This function ensures that a file with expected lowercase/uppercase + is the correct one, even on case-insensitive file systems *) + let rec aux f = + let bf = Filename.basename f in + let df = Filename.dirname f in + (String.equal df "." || aux df) + && exists_in_dir_respecting_case (Filename.concat path df) bf + in Sys.file_exists (Filename.concat path f) && aux f + let rec search paths test = match paths with | [] -> [] @@ -77,7 +110,7 @@ let where_in_path ?(warn=true) path filename = in check_and_warn (search path (fun lpe -> let f = Filename.concat lpe filename in - if Sys.file_exists f then [lpe,f] else [])) + if file_exists_respecting_case lpe filename then [lpe,f] else [])) let where_in_path_rex path rex = search path (fun lpe -> @@ -93,6 +126,8 @@ let where_in_path_rex path rex = let find_file_in_path ?(warn=true) paths filename = if not (Filename.is_implicit filename) then + (* the name is considered to be a physical name and we use the file + system rules (e.g. possible case-insensitivity) to find it *) if Sys.file_exists filename then let root = Filename.dirname filename in root, filename @@ -100,6 +135,9 @@ let find_file_in_path ?(warn=true) paths filename = errorlabstrm "System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename)) else + (* the name is considered to be the transcription as a relative + physical name of a logical name, so we deal with it as a name + to be locate respecting case *) try where_in_path ~warn paths filename with Not_found -> errorlabstrm "System.find_file_in_path" @@ -224,7 +262,7 @@ type time = float * float * float let get_time () = let t = Unix.times () in - (Unix.gettimeofday(), t.tms_utime, t.tms_stime) + (Unix.gettimeofday(), t.Unix.tms_utime, t.Unix.tms_stime) (* Keep only 3 significant digits *) let round f = (floor (f *. 1e3)) *. 1e-3 diff --git a/lib/system.mli b/lib/system.mli index 247d528b..062c8ea8 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool val find_file_in_path : ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string +val file_exists_respecting_case : string -> string -> bool + (** {6 I/O functions } *) (** Generic input and output functions, parameterized by a magic number and a suffix. The intern functions raise the exception [Bad_magic_number] diff --git a/lib/terminal.ml b/lib/terminal.ml index 58851ed2..de21f102 100644 --- a/lib/terminal.ml +++ b/lib/terminal.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* () | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|]) @@ -257,6 +267,7 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e cst_was_seff = false; } in let kn = declare_constant_common id cst in + let () = if_xml (Hook.get f_xml_declare_constant) (internal, kn) in kn let declare_definition ?(internal=UserIndividualRequest) @@ -365,8 +376,9 @@ let declare_projections mind = let kn' = declare_constant id (ProjectionEntry entry, IsDefinition StructureComponent) in - assert(eq_constant kn kn')) kns; true - | Some None | None -> false + assert(eq_constant kn kn')) kns; true,true + | Some None -> true,false + | None -> false,false (* for initial declaration *) let declare_mind mie = @@ -375,9 +387,10 @@ let declare_mind mie = | [] -> anomaly (Pp.str "cannot declare an empty list of inductives") in let (sp,kn as oname) = add_leaf id (inInductive ([],mie)) in let mind = Global.mind_of_delta_kn kn in - let isprim = declare_projections mind in + let isrecord,isprim = declare_projections mind in declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; + if_xml (Hook.get f_xml_declare_inductive) (isrecord,oname); oname, isprim (* Declaration messages *) @@ -431,7 +444,7 @@ let cache_universes (p, l) = Univ.ContextSet.add_universe lev ctx)) (glob, Univ.ContextSet.empty) l in - Global.push_context_set false ctx; + Global.push_context_set p ctx; if p then Lib.add_section_context ctx; Universes.set_global_universe_names glob' diff --git a/library/declare.mli b/library/declare.mli index c6119a58..8dd24d27 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* object_name * bool +(** Hooks for XML output *) +val xml_declare_variable : (object_name -> unit) Hook.t +val xml_declare_constant : (internal_flag * constant -> unit) Hook.t +val xml_declare_inductive : (bool * object_name -> unit) Hook.t + (** Declaration messages *) val definition_message : Id.t -> unit diff --git a/library/declaremods.ml b/library/declaremods.ml index 7f607a51..04348415 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* module_path +(** Hooks for XML output *) +val xml_declare_module : (module_path -> unit) Hook.t +val xml_start_module : (module_path -> unit) Hook.t +val xml_end_module : (module_path -> unit) Hook.t +val xml_declare_module_type : (module_path -> unit) Hook.t +val xml_start_module_type : (module_path -> unit) Hook.t +val xml_end_module_type : (module_path -> unit) Hook.t (** {6 Libraries i.e. modules on disk } *) diff --git a/library/decls.ml b/library/decls.ml index 8d5085f7..0cd4ccb2 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in let univs = - if mib.mind_polymorphic then mib.mind_universes + if mib.mind_polymorphic then Univ.instantiate_univ_context mib.mind_universes else Univ.UContext.empty in Inductive.type_of_inductive env (specif, Univ.UContext.instance univs), univs | ConstructRef cstr -> let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in let univs = - if mib.mind_polymorphic then mib.mind_universes + if mib.mind_polymorphic then Univ.instantiate_univ_context mib.mind_universes else Univ.UContext.empty in let inst = Univ.UContext.instance univs in diff --git a/library/global.mli b/library/global.mli index 03469bea..9db30c8f 100644 --- a/library/global.mli +++ b/library/global.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* string option write_fu (** {6 Special functions supposed to be used only in vernacentries.ml } *) -module OptionMap : Map.S with type key = option_name +module OptionMap : CSig.MapS with type key = option_name val get_string_table : option_name -> diff --git a/library/heads.ml b/library/heads.ml index 73d2aa05..8124d347 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* add_discharged_leaf id o)) newdecls; diff --git a/library/lib.mli b/library/lib.mli index bb883175..29fc7cd2 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit val init : unit -> unit +(** XML output hooks *) +val xml_open_section : (Names.Id.t -> unit) Hook.t +val xml_close_section : (Names.Id.t -> unit) Hook.t + (** {6 Section management for discharge } *) type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types diff --git a/library/libnames.ml b/library/libnames.ml index cdaec6a3..a2f22b2e 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* full_path val string_of_path : full_path -> string val pr_path : full_path -> std_ppcmds -module Spmap : Map.S with type key = full_path +module Spmap : CSig.MapS with type key = full_path val restrict_path : int -> full_path -> full_path diff --git a/library/libobject.ml b/library/libobject.ml index 85c830ea..706e3991 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* obj = (* Require libraries, import them if [export <> None], mark them for export if [export = Some true] *) +let (f_xml_require, xml_require) = Hook.make ~default:ignore () + let require_library_from_dirpath modrefl export = let needed, contents = List.fold_left rec_intern_library ([], DPMap.empty) modrefl in let needed = List.rev_map (fun dir -> DPMap.find dir contents) needed in @@ -568,6 +570,7 @@ let require_library_from_dirpath modrefl export = end else add_anonymous_leaf (in_require (needed,modrefl,export)); + if !Flags.xml_export then List.iter (Hook.get f_xml_require) modrefl; add_frozen_state () (* the function called by Vernacentries.vernac_import *) diff --git a/library/library.mli b/library/library.mli index d5e610dd..25c9604c 100644 --- a/library/library.mli +++ b/library/library.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* string (** - Overwrite the filename of all libraries (used when restoring a state) *) val overwrite_library_filenames : string -> unit +(** {6 Hook for the xml exportation of libraries } *) +val xml_require : (DirPath.t -> unit) Hook.t + (** {6 Locate a library in the load paths } *) exception LibUnmappedDir exception LibNotFound diff --git a/library/loadpath.ml b/library/loadpath.ml index 622d390a..78f8dd25 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* if d == Univ.Le then enforce_leq inst (Universe.make r) cstrs - else + else try let lev = Option.get (Universe.level inst) in Constraint.add (lev, d, r) cstrs with Option.IsNone -> failwith "") @@ -854,7 +854,7 @@ let normalize_context_set ctx us algs = Constraint.fold (fun (l,d,r as cstr) (smallles, noneqs) -> if d == Le then if Univ.Level.is_small l then - if is_set_minimization () then + if is_set_minimization () && LSet.mem r ctx then (Constraint.add cstr smallles, noneqs) else (smallles, noneqs) else if Level.is_small r then @@ -904,22 +904,28 @@ let normalize_context_set ctx us algs = let noneqs = Constraint.union noneqs smallles in let partition = UF.partition uf in let flex x = LMap.mem x us in - let ctx, subst, eqs = List.fold_left (fun (ctx, subst, cstrs) s -> + let ctx, subst, us, eqs = List.fold_left (fun (ctx, subst, us, cstrs) s -> let canon, (global, rigid, flexible) = choose_canonical ctx flex algs s in (* Add equalities for globals which can't be merged anymore. *) let cstrs = LSet.fold (fun g cst -> Constraint.add (canon, Univ.Eq, g) cst) global cstrs in + (* Also add equalities for rigid variables *) + let cstrs = LSet.fold (fun g cst -> + Constraint.add (canon, Univ.Eq, g) cst) rigid + cstrs + in let subst = LSet.fold (fun f -> LMap.add f canon) rigid subst in - let subst = LSet.fold (fun f -> LMap.add f canon) flexible subst in - (LSet.diff (LSet.diff ctx rigid) flexible, subst, cstrs)) - (ctx, LMap.empty, Constraint.empty) partition + let subst = LSet.fold (fun f -> LMap.add f canon) flexible subst in + let canonu = Some (Universe.make canon) in + let us = LSet.fold (fun f -> LMap.add f canonu) flexible us in + (LSet.diff ctx flexible, subst, us, cstrs)) + (ctx, LMap.empty, us, Constraint.empty) partition in (* Noneqs is now in canonical form w.r.t. equality constraints, and contains only inequality constraints. *) let noneqs = subst_univs_level_constraints subst noneqs in - let us = LMap.fold (fun u v acc -> LMap.add u (Some (Universe.make v)) acc) subst us in (* Compute the left and right set of flexible variables, constraints mentionning other variables remain in noneqs. *) let noneqs, ucstrsl, ucstrsr = diff --git a/library/universes.mli b/library/universes.mli index 45672ef4..edb06dfc 100644 --- a/library/universes.mli +++ b/library/universes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* CGeneralization (!@loc, Explicit, None, c) - | "$("; tac = Tactic.tactic; ")$" -> + | "ltac:"; "("; tac = Tactic.tactic_expr; ")" -> let arg = Genarg.in_gen (Genarg.rawwit Constrarg.wit_tactic) tac in CHole (!@loc, None, IntroAnonymous, Some arg) ] ] diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index a4dba506..959b0e89 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* arg_of_expr a - | IDENT "ltac"; ":"; n = natural -> TacGeneric (genarg_of_int n) + [ [ "ltac:"; a = tactic_expr LEVEL "0" -> arg_of_expr a + | "ltac:"; n = natural -> TacGeneric (genarg_of_int n) | a = tactic_top_or_arg -> a | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 84da9c42..5297c163 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* err ()) | _ -> err ()) +(* Hack to recognize "(x)" *) +let test_lpar_id_rpar = + Gram.Entry.of_parser "lpar_id_coloneq" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> + (match get_tok (stream_nth 2 strm) with + | KEYWORD ")" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + (* idem for (x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = Gram.Entry.of_parser "test_lpar_idnum_coloneq" @@ -224,8 +238,9 @@ GEXTEND Gram ; induction_arg: [ [ n = natural -> (None,ElimOnAnonHyp n) + | test_lpar_id_rpar; c = constr_with_bindings -> + (Some false,induction_arg_of_constr c) | c = constr_with_bindings -> (None,induction_arg_of_constr c) - | "!"; c = constr_with_bindings -> (Some false,induction_arg_of_constr c) ] ] ; constr_with_bindings_arg: @@ -296,11 +311,18 @@ GEXTEND Gram | "**" -> !@loc, IntroForthcoming false ]] ; simple_intropattern: + [ [ pat = simple_intropattern_closed; + l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> + let loc0,pat = pat in + let f c pat = + let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in + IntroAction (IntroApplyOn (c,(loc,pat))) in + !@loc, List.fold_right f l pat ] ] + ; + simple_intropattern_closed: [ [ pat = or_and_intropattern -> !@loc, IntroAction (IntroOrAndPattern pat) | pat = equality_intropattern -> !@loc, IntroAction pat | "_" -> !@loc, IntroAction IntroWildcard - | pat = simple_intropattern; "/"; c = constr -> - !@loc, IntroAction (IntroApplyOn (c,pat)) | pat = naming_intropattern -> !@loc, IntroNaming pat ] ] ; simple_binding: @@ -399,7 +421,7 @@ GEXTEND Gram | -> [] ] ] ; in_hyp_as: - [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (None,id,ipat) + [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) | -> None ] ] ; orient: diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 1f9f57f6..839f768b 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ] -> string in_comments bp (store len c) s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string +(* Hook for exporting comment into xml theory files *) +let (f_xml_output_comment, xml_output_comment) = Hook.make ~default:ignore () + (* Utilities for comments in beautify *) let comment_begin = ref None let comm_loc bp = match !comment_begin with @@ -340,6 +343,9 @@ let null_comment s = let comment_stop ep = let current_s = Buffer.contents current in + if !Flags.xml_export && Buffer.length current > 0 && + (!between_com || not(null_comment current_s)) then + Hook.get f_xml_output_comment current_s; (if Flags.do_beautify() && Buffer.length current > 0 && (!between_com || not(null_comment current_s)) then let bp = match !comment_begin with diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 2b9bd37d..24b0ec84 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* com_state val restore_com_state: com_state -> unit +val xml_output_comment : (string -> unit) Hook.t + val terminal : string -> Tok.t (** The lexer of Coq: *) diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 2e47e07a..32dbeaa4 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* CString.equal s1 s2 | KEYWORD s1, KEYWORD s2 -> CString.equal s1 s2 | METAIDENT s1, METAIDENT s2 -> CString.equal s1 s2 | PATTERNIDENT s1, PATTERNIDENT s2 -> CString.equal s1 s2 diff --git a/parsing/tok.mli b/parsing/tok.mli index feee1983..df006601 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* forest (*type pa_constructor -module PacMap:Map.S with type key=pa_constructor +module PacMap:CSig.MapS with type key=pa_constructor type term = Symb of Term.constr diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 42c03234..c188bf3b 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Proofview.tclZERO e in Proofview.tclORELSE diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index aa31c6f0..5dbc340c 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit + val add_kn : kernel_name -> unit val add_decl_deps : ml_decl -> unit val add_spec_deps : ml_spec -> unit (* Test functions: is a particular object a needed dependency for the current extraction ? *) val needed_ind : mutual_inductive -> bool - val needed_con : constant -> bool + val needed_cst : constant -> bool val needed_mp : module_path -> bool val needed_mp_all : module_path -> bool end module Visit : VISIT = struct type must_visit = - { mutable ind : KNset.t; mutable con : KNset.t; - mutable mp : MPset.t; mutable mp_all : MPset.t } + { mutable kn : KNset.t; + mutable mp : MPset.t; + mutable mp_all : MPset.t } (* the imperative internal visit lists *) - let v = { ind = KNset.empty ; con = KNset.empty ; - mp = MPset.empty; mp_all = MPset.empty } + let v = { kn = KNset.empty; mp = MPset.empty; mp_all = MPset.empty } (* the accessor functions *) let reset () = - v.ind <- KNset.empty; - v.con <- KNset.empty; + v.kn <- KNset.empty; v.mp <- MPset.empty; v.mp_all <- MPset.empty - let needed_ind i = KNset.mem (user_mind i) v.ind - let needed_con c = KNset.mem (user_con c) v.con + let needed_ind i = KNset.mem (user_mind i) v.kn + let needed_cst c = KNset.mem (user_con c) v.kn let needed_mp mp = MPset.mem mp v.mp || MPset.mem mp v.mp_all let needed_mp_all mp = MPset.mem mp v.mp_all let add_mp mp = check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp let add_mp_all mp = - check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp; + check_loaded_modfile mp; + v.mp <- MPset.union (prefixes_mp mp) v.mp; v.mp_all <- MPset.add mp v.mp_all - let add_ind i = - let kn = user_mind i in - v.ind <- KNset.add kn v.ind; add_mp (modpath kn) - let add_con c = - let kn = user_con c in - v.con <- KNset.add kn v.con; add_mp (modpath kn) + let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (modpath kn) let add_ref = function - | ConstRef c -> add_con c - | IndRef (ind,_) | ConstructRef ((ind,_),_) -> add_ind ind + | ConstRef c -> add_kn (user_con c) + | IndRef (ind,_) | ConstructRef ((ind,_),_) -> add_kn (user_mind ind) | VarRef _ -> assert false let add_decl_deps = decl_iter_references add_ref add_ref add_ref let add_spec_deps = spec_iter_references add_ref add_ref add_ref end let add_field_label mp = function - | (lab, SFBconst _) -> Visit.add_ref (ConstRef (Constant.make2 mp lab)) - | (lab, SFBmind _) -> Visit.add_ref (IndRef (MutInd.make2 mp lab, 0)) + | (lab, (SFBconst _|SFBmind _)) -> Visit.add_kn (KerName.make2 mp lab) | (lab, (SFBmodule _|SFBmodtype _)) -> Visit.add_mp_all (MPdot (mp,lab)) let rec add_labels mp = function @@ -182,8 +177,7 @@ let factor_fix env l cb msb = let expand_mexpr env mp me = let inl = Some (Flags.get_inline_level()) in - let sign,_,_,_ = Mod_typing.translate_mse env (Some mp) inl me in - sign + Mod_typing.translate_mse env (Some mp) inl me (** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. To check with Elie. *) @@ -193,45 +187,52 @@ let rec mp_of_mexpr = function | MEwith (seb,_) -> mp_of_mexpr seb | _ -> assert false +let no_delta = Mod_subst.empty_delta_resolver + let env_for_mtb_with_def env mp me idl = let struc = Modops.destr_nofunctor me in let l = Label.of_id (List.hd idl) in let spot = function (l',SFBconst _) -> Label.equal l l' | _ -> false in let before = fst (List.split_when spot struc) in - Modops.add_structure mp before empty_delta_resolver env + Modops.add_structure mp before no_delta env + +let make_cst resolver mp l = + Mod_subst.constant_of_delta_kn resolver (KerName.make2 mp l) + +let make_mind resolver mp l = + Mod_subst.mind_of_delta_kn resolver (KerName.make2 mp l) (* From a [structure_body] (i.e. a list of [structure_field_body]) to specifications. *) -let rec extract_structure_spec env mp = function +let rec extract_structure_spec env mp reso = function | [] -> [] | (l,SFBconst cb) :: msig -> - let kn = Constant.make2 mp l in - let s = extract_constant_spec env kn cb in - let specs = extract_structure_spec env mp msig in + let c = make_cst reso mp l in + let s = extract_constant_spec env c cb in + let specs = extract_structure_spec env mp reso msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmind _) :: msig -> - let mind = MutInd.make2 mp l in + let mind = make_mind reso mp l in let s = Sind (mind, extract_inductive env mind) in - let specs = extract_structure_spec env mp msig in + let specs = extract_structure_spec env mp reso msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmodule mb) :: msig -> - let specs = extract_structure_spec env mp msig in + let specs = extract_structure_spec env mp reso msig in let spec = extract_mbody_spec env mb.mod_mp mb in (l,Smodule spec) :: specs | (l,SFBmodtype mtb) :: msig -> - let specs = extract_structure_spec env mp msig in + let specs = extract_structure_spec env mp reso msig in let spec = extract_mbody_spec env mtb.mod_mp mtb in (l,Smodtype spec) :: specs (* From [module_expression] to specifications *) -(* Invariant: the [me] given to [extract_mexpr_spec] should either come - from a [mod_type] or [type_expr] field, or their [_alg] counterparts. - This way, any encountered [MEident] should be a true module type. -*) +(* Invariant: the [me_alg] given to [extract_mexpr_spec] and + [extract_mexpression_spec] should come from a [mod_type_alg] field. + This way, any encountered [MEident] should be a true module type. *) and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with | MEident mp -> Visit.add_mp_all mp; MTident mp @@ -244,7 +245,9 @@ and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with | MEwith(me',WithMod(idl,mp))-> Visit.add_mp_all mp; MTwith(extract_mexpr_spec env mp1 (me_struct,me'), ML_With_module(idl,mp)) - | MEapply _ -> extract_msignature_spec env mp1 me_struct + | MEapply _ -> + (* No higher-order module type in OCaml : we use the expanded version *) + extract_msignature_spec env mp1 no_delta (*TODO*) me_struct and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with | MoreFunctor (mbid, mtb, me_alg') -> @@ -258,19 +261,19 @@ and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with extract_mexpression_spec env' mp1 (me_struct',me_alg')) | NoFunctor m -> extract_mexpr_spec env mp1 (me_struct,m) -and extract_msignature_spec env mp1 = function +and extract_msignature_spec env mp1 reso = function | NoFunctor struc -> - let env' = Modops.add_structure mp1 struc empty_delta_resolver env in - MTsig (mp1, extract_structure_spec env' mp1 struc) + let env' = Modops.add_structure mp1 struc reso env in + MTsig (mp1, extract_structure_spec env' mp1 reso struc) | MoreFunctor (mbid, mtb, me) -> let mp = MPbound mbid in let env' = Modops.add_module_type mp mtb env in MTfunsig (mbid, extract_mbody_spec env mp mtb, - extract_msignature_spec env' mp1 me) + extract_msignature_spec env' mp1 reso me) and extract_mbody_spec env mp mb = match mb.mod_type_alg with | Some ty -> extract_mexpression_spec env mp (mb.mod_type,ty) - | None -> extract_msignature_spec env mp mb.mod_type + | None -> extract_msignature_spec env mp mb.mod_delta mb.mod_type (* From a [structure_body] (i.e. a list of [structure_field_body]) to implementations. @@ -279,31 +282,31 @@ and extract_mbody_spec env mp mb = match mb.mod_type_alg with important: last to first ensures correct dependencies. *) -let rec extract_structure env mp ~all = function +let rec extract_structure env mp reso ~all = function | [] -> [] | (l,SFBconst cb) :: struc -> (try let vl,recd,struc = factor_fix env l cb struc in - let vc = Array.map (Constant.make2 mp) vl in - let ms = extract_structure env mp ~all struc in - let b = Array.exists Visit.needed_con vc in + let vc = Array.map (make_cst reso mp) vl in + let ms = extract_structure env mp reso ~all struc in + let b = Array.exists Visit.needed_cst vc in if all || b then let d = extract_fixpoint env vc recd in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms with Impossible -> - let ms = extract_structure env mp ~all struc in - let c = Constant.make2 mp l in - let b = Visit.needed_con c in + let ms = extract_structure env mp reso ~all struc in + let c = make_cst reso mp l in + let b = Visit.needed_cst c in if all || b then let d = extract_constant env c cb in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms) | (l,SFBmind mib) :: struc -> - let ms = extract_structure env mp ~all struc in - let mind = MutInd.make2 mp l in + let ms = extract_structure env mp reso ~all struc in + let mind = make_mind reso mp l in let b = Visit.needed_ind mind in if all || b then let d = Dind (mind, extract_inductive env mind) in @@ -311,14 +314,14 @@ let rec extract_structure env mp ~all = function else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms | (l,SFBmodule mb) :: struc -> - let ms = extract_structure env mp ~all struc in + let ms = extract_structure env mp reso ~all struc in let mp = MPdot (mp,l) in let all' = all || Visit.needed_mp_all mp in if all' || Visit.needed_mp mp then (l,SEmodule (extract_module env mp ~all:all' mb)) :: ms else ms | (l,SFBmodtype mtb) :: struc -> - let ms = extract_structure env mp ~all struc in + let ms = extract_structure env mp reso ~all struc in let mp = MPdot (mp,l) in if all || Visit.needed_mp mp then (l,SEmodtype (extract_mbody_spec env mp mtb)) :: ms @@ -332,7 +335,8 @@ and extract_mexpr env mp = function (* In Haskell/Scheme, we expand everything. For now, we also extract everything, dead code will be removed later (see [Modutil.optimize_struct]. *) - extract_msignature env mp ~all:true (expand_mexpr env mp me) + let sign,_,delta,_ = expand_mexpr env mp me in + extract_msignature env mp delta ~all:true sign | MEident mp -> if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; Visit.add_mp_all mp; Miniml.MEident mp @@ -350,17 +354,17 @@ and extract_mexpression env mp = function extract_mbody_spec env mp1 mtb, extract_mexpression env' mp me) -and extract_msignature env mp ~all = function +and extract_msignature env mp reso ~all = function | NoFunctor struc -> - let env' = Modops.add_structure mp struc empty_delta_resolver env in - Miniml.MEstruct (mp,extract_structure env' mp ~all struc) + let env' = Modops.add_structure mp struc reso env in + Miniml.MEstruct (mp,extract_structure env' mp reso ~all struc) | MoreFunctor (mbid, mtb, me) -> let mp1 = MPbound mbid in let env' = Modops.add_module_type mp1 mtb env in Miniml.MEfunctor (mbid, extract_mbody_spec env mp1 mtb, - extract_msignature env' mp ~all me) + extract_msignature env' mp reso ~all me) and extract_module env mp ~all mb = (* A module has an empty [mod_expr] when : @@ -376,8 +380,8 @@ and extract_module env mp ~all mb = (* This module has a signature, otherwise it would be FullStruct. We extract just the elements required by this signature. *) let () = add_labels mp mb.mod_type in - extract_msignature env mp ~all:false sign - | FullStruct -> extract_msignature env mp ~all mb.mod_type + extract_msignature env mp mb.mod_delta ~all:false sign + | FullStruct -> extract_msignature env mp mb.mod_delta ~all mb.mod_type in (* Slight optimization: for modules without explicit signatures ([FullStruct] case), we build the type out of the extracted @@ -399,7 +403,7 @@ let mono_environment refs mpl = let l = List.rev (environment_until None) in List.rev_map (fun (mp,struc) -> - mp, extract_structure env mp ~all:(Visit.needed_mp_all mp) struc) + mp, extract_structure env mp no_delta ~all:(Visit.needed_mp_all mp) struc) l (**************************************) @@ -455,7 +459,7 @@ let print_one_decl struc mp decl = push_visible mp []; let ans = d.pp_decl decl in pop_visible (); - ans + v 0 ans (*s Extraction of a ml struct to a file. *) @@ -495,8 +499,8 @@ 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; + mldummy = struct_ast_search Mlutil.isMLdummy struc; + tdummy = struct_type_search Mlutil.isTdummy struc; tunknown = struct_type_search ((==) Tunknown) struc; magic = if lang () != Haskell then false @@ -538,7 +542,7 @@ let print_structure_to_file (fn,si,mo) dry struc = (if dry then None else si); (* Print the buffer content via Coq standard formatter (ok with coqide). *) if not (Int.equal (Buffer.length buf) 0) then begin - Pp.msg_info (str (Buffer.contents buf)); + Pp.msg_notice (str (Buffer.contents buf)); Buffer.reset buf end @@ -632,7 +636,7 @@ let simple_extraction r = in let ans = flag ++ print_one_decl struc (modpath_of_r r) d in reset (); - Pp.msg_info ans + Pp.msg_notice ans | _ -> assert false @@ -650,7 +654,7 @@ let extraction_library is_rec m = let l = List.rev (environment_until (Some dir_m)) in let select l (mp,struc) = if Visit.needed_mp mp - then (mp, extract_structure env mp true struc) :: l + then (mp, extract_structure env mp no_delta true struc) :: l else l in let struc = List.fold_left select [] l in diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index e5fe76f5..90f4f911 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* raise (NotDefault Ktype) - | Logic,_ -> raise (NotDefault Kother) + | Logic,_ -> raise (NotDefault Kprop) | _ -> () let is_info_scheme env t = match flag_of_type env t with @@ -103,7 +103,7 @@ let is_info_scheme env t = match flag_of_type env t with let rec type_sign env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> - (if is_info_scheme env t then Keep else Kill Kother) + (if is_info_scheme env t then Keep else Kill Kprop) :: (type_sign (push_rel_assum (n,t) env) d) | _ -> [] @@ -137,7 +137,7 @@ let rec type_sign_vl env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in - if not (is_info_scheme env t) then Kill Kother::s, vl + if not (is_info_scheme env t) then Kill Kprop::s, vl else Keep::s, (make_typvar n vl) :: vl | _ -> [],[] @@ -154,25 +154,12 @@ let sign_with_implicits r s nb_params = let implicits = implicits_of_global r in let rec add_impl i = function | [] -> [] - | sign::s -> - let sign' = - if sign == Keep && Int.List.mem i implicits - then Kill Kother else sign - in sign' :: add_impl (succ i) s + | Keep::s when Int.Set.mem i implicits -> + Kill (Kimplicit (r,i)) :: add_impl (i+1) s + | sign::s -> sign :: add_impl (i+1) s in add_impl (1+nb_params) s -(* Enriching a exception message *) - -let rec handle_exn r n fn_name = function - | MLexn s -> - (try Scanf.sscanf s "UNBOUND %d%!" - (fun i -> - assert ((0 < i) && (i <= n)); - MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i))) - with Scanf.Scan_failure _ | End_of_file -> MLexn s) - | a -> ast_map (handle_exn r n fn_name) a - (*S Management of type variable contexts. *) (* A De Bruijn variable context (db) is a context for translating Coq [Rel] @@ -214,36 +201,6 @@ let parse_ind_args si args relmax = | _ -> parse (i+1) (j+1) s) in parse 1 1 si -let oib_equal o1 o2 = - Id.equal o1.mind_typename o2.mind_typename && - List.equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt && - begin - match o1.mind_arity, o2.mind_arity with - | RegularArity {mind_user_arity=c1; mind_sort=s1}, RegularArity {mind_user_arity=c2; mind_sort=s2} -> - eq_constr c1 c2 && Sorts.equal s1 s2 - | TemplateArity p1, TemplateArity p2 -> - let eq o1 o2 = Option.equal Univ.Level.equal o1 o2 in - List.equal eq p1.template_param_levels p2.template_param_levels && - Univ.Universe.equal p1.template_level p2.template_level - | _, _ -> false - end && - Array.equal Id.equal o1.mind_consnames o2.mind_consnames - -let eq_record x y = - Option.equal (Option.equal (fun (_, x, y) (_, x', y') -> Array.for_all2 eq_constant x x')) x y - -let mib_equal m1 m2 = - Array.equal oib_equal m1.mind_packets m1.mind_packets && - eq_record m1.mind_record m2.mind_record && - (m1.mind_finite : Decl_kinds.recursivity_kind) == m2.mind_finite && - Int.equal m1.mind_ntypes m2.mind_ntypes && - List.equal eq_named_declaration m1.mind_hyps m2.mind_hyps && - Int.equal m1.mind_nparams m2.mind_nparams && - Int.equal m1.mind_nparams_rec m2.mind_nparams_rec && - List.equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt && - (* Univ.UContext.eq *) m1.mind_universes == m2.mind_universes (** FIXME *) - (* m1.mind_universes = m2.mind_universes *) - (*S Extraction of a type. *) (* [extract_type env db c args] is used to produce an ML type from the @@ -285,10 +242,10 @@ let rec extract_type env db j c args = (match expand env mld with | Tdummy d -> Tdummy d | _ -> - let reason = if lvl == TypeScheme then Ktype else Kother in + let reason = if lvl == TypeScheme then Ktype else Kprop in Tarr (Tdummy reason, mld))) | Sort _ -> Tdummy Ktype (* The two logical cases. *) - | _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kother + | _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kprop | Rel n -> (match lookup_rel n env with | (_,Some t,_) -> extract_type env db j (lift n t) args @@ -373,14 +330,9 @@ and extract_type_scheme env db c p = and extract_ind env kn = (* kn is supposed to be in long form *) let mib = Environ.lookup_mind kn env in - try - (* For a same kn, we can get various bodies due to module substitutions. - We hence check that the mib has not changed from recording - time to retrieving time. Ideally we should also check the env. *) - let (mib0,ml_ind) = lookup_ind kn in - if not (mib_equal mib mib0) then raise Not_found; - ml_ind - with Not_found -> + match lookup_ind kn mib with + | Some ml_ind -> ml_ind + | None -> (* First, if this inductive is aliased via a Module, we process the original inductive if possible. When at toplevel of the monolithic case, we cannot do much @@ -458,7 +410,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) if p.ip_logical then raise (I Standard); if not (Int.equal (Array.length p.ip_types) 1) then raise (I Standard); let typ = p.ip_types.(0) in - let l = List.filter (fun t -> not (isDummy (expand env t))) typ in + let l = List.filter (fun t -> not (isTdummy (expand env t))) typ in if not (keep_singleton ()) && Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l)) then raise (I Singleton); @@ -479,7 +431,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let mp = MutInd.modpath kn in let rec select_fields l typs = match l,typs with | [],[] -> [] - | _::l, typ::typs when isDummy (expand env typ) -> + | _::l, typ::typs when isTdummy (expand env typ) -> select_fields l typs | Anonymous::l, typ::typs -> None :: (select_fields l typs) @@ -536,28 +488,25 @@ and extract_type_cons env db dbmap c i = (*s Recording the ML type abbreviation of a Coq type scheme constant. *) and mlt_env env r = match r with + | IndRef _ | ConstructRef _ | VarRef _ -> None | ConstRef kn -> - (try - if not (visible_con kn) then raise Not_found; - match lookup_term kn with - | Dtype (_,vl,mlt) -> Some mlt + let cb = Environ.lookup_constant kn env in + match cb.const_body with + | Undef _ | OpaqueDef _ -> None + | Def l_body -> + match lookup_typedef kn cb with + | Some _ as o -> o + | None -> + let typ = Typeops.type_of_constant_type env cb.const_type + (* FIXME not sure if we should instantiate univs here *) in + match flag_of_type env typ with + | Info,TypeScheme -> + let body = Mod_subst.force_constr l_body in + let s = type_sign env typ in + let db = db_from_sign s in + let t = extract_type_scheme env db body (List.length s) + in add_typedef kn cb t; Some t | _ -> None - with Not_found -> - let cb = Environ.lookup_constant kn env in - let typ = Typeops.type_of_constant_type env cb.const_type - (* FIXME not sure if we should instantiate univs here *) in - match cb.const_body with - | Undef _ | OpaqueDef _ -> None - | Def l_body -> - (match flag_of_type env typ with - | Info,TypeScheme -> - let body = Mod_subst.force_constr l_body in - let s,vl = type_sign_vl env typ in - let db = db_from_sign s in - let t = extract_type_scheme env db body (List.length s) - in add_term kn (Dtype (r, vl, t)); Some t - | _ -> None)) - | _ -> None and expand env = type_expand (mlt_env env) and type2signature env = type_to_signature (mlt_env env) @@ -568,16 +517,18 @@ let type_expunge_from_sign env = type_expunge_from_sign (mlt_env env) (*s Extraction of the type of a constant. *) let record_constant_type env kn opt_typ = - try - if not (visible_con kn) then raise Not_found; - lookup_type kn - with Not_found -> - let typ = match opt_typ with - | None -> Typeops.type_of_constant_type env (lookup_constant kn env).const_type - | Some typ -> typ - in let mlt = extract_type env [] 1 typ [] - in let schema = (type_maxvar mlt, mlt) - in add_type kn schema; schema + let cb = lookup_constant kn env in + match lookup_cst_type kn cb with + | Some schema -> schema + | None -> + let typ = match opt_typ with + | None -> Typeops.type_of_constant_type env cb.const_type + | Some typ -> typ + in + let mlt = extract_type env [] 1 typ [] in + let schema = (type_maxvar mlt, mlt) in + let () = add_cst_type kn cb schema in + schema (*S Extraction of a term. *) @@ -655,7 +606,7 @@ and extract_maybe_term env mle mlt c = try check_default env (type_of env c); extract_term env mle mlt c [] with NotDefault d -> - put_magic (mlt, Tdummy d) MLdummy + put_magic (mlt, Tdummy d) (MLdummy d) (*s Generic way to deal with an application. *) @@ -723,18 +674,18 @@ and extract_cst_app env mle mlt kn u args = else mla with e when Errors.noncritical e -> mla in - (* For strict languages, purely logical signatures with at least - one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left + (* For strict languages, purely logical signatures lead to a dummy lam + (except when [Kill Ktype] everywhere). So a [MLdummy] is left accordingly. *) let optdummy = match sign_kind s_full with - | UnsafeLogicalSig when lang () != Haskell -> [MLdummy] + | UnsafeLogicalSig when lang () != Haskell -> [MLdummy Kprop] | _ -> [] in (* Different situations depending of the number of arguments: *) if la >= ls then (* Enough args, cleanup already done in [mla], we only add the - additionnal dummy if needed. *) + additional dummy if needed. *) put_magic_if (magic2 && not magic1) (mlapp head (optdummy @ mla)) else (* Partially applied function with some logical arg missing. @@ -748,7 +699,7 @@ and extract_cst_app env mle mlt kn u args = (*s Extraction of an inductive constructor applied to arguments. *) (* \begin{itemize} - \item In ML, contructor arguments are uncurryfied. + \item In ML, constructor arguments are uncurryfied. \item We managed to suppress logical parts inside inductive definitions, but they must appears outside (for partial applications for instance) \item We also suppressed all Coq parameters to the inductives, since @@ -826,8 +777,8 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = (* Logical singleton case: *) (* [match c with C i j k -> t] becomes [t'] *) assert (Int.equal br_size 1); - let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in - let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in + let s = iterate (fun l -> Kill Kprop :: l) ni.(0) [] in + let mlt = iterate (fun t -> Tarr (Tdummy Kprop, t)) ni.(0) mlt in let e = extract_maybe_term env mle mlt br.(0) in snd (case_expunge s e) end @@ -851,8 +802,7 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in (* We suppress dummy arguments according to signature. *) let ids,e = case_expunge s e in - let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in - (List.rev ids, Pusual r, e') + (List.rev ids, Pusual r, e) in if mi.ind_kind == Singleton then begin @@ -960,8 +910,6 @@ let extract_std_constant env kn body typ = let e = extract_term env mle t' c [] in (* Expunging term and type from dummy lambdas. *) let trm = term_expunge s (ids,e) in - let trm = handle_exn (ConstRef kn) n (fun i -> fst (List.nth rels (i-1))) trm - in trm, type_expunge_from_sign env s t (* Extracts the type of an axiom, honors the Extraction Implicit declaration. *) @@ -979,8 +927,8 @@ let extract_axiom env kn typ = let extract_fixpoint env vkn (fi,ti,ci) = let n = Array.length vkn in - let types = Array.make n (Tdummy Kother) - and terms = Array.make n MLdummy in + let types = Array.make n (Tdummy Kprop) + and terms = Array.make n (MLdummy Kprop) in let kns = Array.to_list vkn in current_fixpoints := kns; (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *) @@ -1022,7 +970,7 @@ let extract_constant env kn cb = in match flag_of_type env typ with | (Logic,TypeScheme) -> warn_log (); Dtype (r, [], Tdummy Ktype) - | (Logic,Default) -> warn_log (); Dterm (r, MLdummy, Tdummy Kother) + | (Logic,Default) -> warn_log (); Dterm (r, MLdummy Kprop, Tdummy Kprop) | (Info,TypeScheme) -> (match cb.const_body with | Undef _ -> warn_info (); mk_typ_ax () @@ -1047,7 +995,7 @@ let extract_constant_spec env kn cb = let typ = Typeops.type_of_constant_type env cb.const_type in match flag_of_type env typ with | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) - | (Logic, Default) -> Sval (r, Tdummy Kother) + | (Logic, Default) -> Sval (r, Tdummy Kprop) | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in (match cb.const_body with @@ -1075,8 +1023,8 @@ let extract_constr env c = reset_meta_count (); let typ = type_of env c in match flag_of_type env typ with - | (_,TypeScheme) -> MLdummy, Tdummy Ktype - | (Logic,_) -> MLdummy, Tdummy Kother + | (_,TypeScheme) -> MLdummy Ktype, Tdummy Ktype + | (Logic,_) -> MLdummy Kprop, Tdummy Kprop | (Info,Default) -> let mlt = extract_type env [] 1 typ [] in extract_term env Mlenv.empty mlt c [], mlt @@ -1090,7 +1038,7 @@ let extract_inductive env kn = | [] -> [] | t::l -> let l' = filter (succ i) l in - if isDummy (expand env t) || Int.List.mem i implicits then l' + if isTdummy (expand env t) || Int.Set.mem i implicits then l' else t::l' in filter (1+ind.ind_nparams) l in @@ -1102,11 +1050,11 @@ let extract_inductive env kn = (*s Is a [ml_decl] logical ? *) let logical_decl = function - | Dterm (_,MLdummy,Tdummy _) -> true + | Dterm (_,MLdummy _,Tdummy _) -> true | Dtype (_,[],Tdummy _) -> true | Dfix (_,av,tv) -> - (Array.for_all ((==) MLdummy) av) && - (Array.for_all isDummy tv) + (Array.for_all isMLdummy av) && + (Array.for_all isTdummy tv) | Dind (_,i) -> Array.for_all (fun ip -> ip.ip_logical) i.ind_packets | _ -> false diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli index 6bd2541b..cdda777a 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mt () - | Some com -> pp_bracket_comment com ++ fnl () ++ fnl ()) + | Some com -> pp_bracket_comment com ++ fnl2 ()) ++ str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++ str "import qualified Prelude" ++ fnl () ++ - prlist pp_import used_modules ++ fnl () ++ - (if List.is_empty used_modules then mt () else fnl ()) ++ + prlist pp_import used_modules ++ fnl () + ++ (if not (usf.magic || usf.tunknown) then mt () - else str "\ -\n#ifdef __GLASGOW_HASKELL__\ -\nimport qualified GHC.Base\ -\nimport qualified GHC.Prim\ -\n#else\ -\n-- HUGS\ -\nimport qualified IOExts\ -\n#endif" ++ fnl2 ()) + else + str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ + str "import qualified GHC.Base" ++ fnl () ++ + str "import qualified GHC.Prim" ++ fnl () ++ + str "#else" ++ fnl () ++ + str "-- HUGS" ++ fnl () ++ + str "import qualified IOExts" ++ fnl () ++ + str "#endif" ++ fnl2 ()) ++ (if not usf.magic then mt () - else str "\ -\n#ifdef __GLASGOW_HASKELL__\ -\nunsafeCoerce :: a -> b\ -\nunsafeCoerce = GHC.Base.unsafeCoerce#\ -\n#else\ -\n-- HUGS\ -\nunsafeCoerce :: a -> b\ -\nunsafeCoerce = IOExts.unsafeCoerce\ -\n#endif" ++ fnl2 ()) + else + str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ + str "unsafeCoerce :: a -> b" ++ fnl () ++ + str "unsafeCoerce = GHC.Base.unsafeCoerce#" ++ fnl () ++ + str "#else" ++ fnl () ++ + str "-- HUGS" ++ fnl () ++ + str "unsafeCoerce :: a -> b" ++ fnl () ++ + str "unsafeCoerce = IOExts.unsafeCoerce" ++ fnl () ++ + str "#endif" ++ fnl2 ()) ++ (if not usf.tunknown then mt () - else str "\ -\n#ifdef __GLASGOW_HASKELL__\ -\ntype Any = GHC.Prim.Any\ -\n#else\ -\n-- HUGS\ -\ntype Any = ()\ -\n#endif" ++ fnl2 ()) + else + str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ + str "type Any = GHC.Prim.Any" ++ fnl () ++ + str "#else" ++ fnl () ++ + str "-- HUGS" ++ fnl () ++ + str "type Any = ()" ++ fnl () ++ + str "#endif" ++ fnl2 ()) ++ (if not usf.mldummy then mt () - else str "__ :: any" ++ fnl () ++ - str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) + else + str "__ :: any" ++ fnl () ++ + str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) let pp_abst = function | [] -> (mt ()) @@ -120,7 +123,7 @@ let rec pp_type par vl t = (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) | Tdummy _ -> str "()" | Tunknown -> str "Any" - | Taxiom -> str "() -- AXIOM TO BE REALIZED\n" + | Taxiom -> str "() -- AXIOM TO BE REALIZED" ++ fnl () in hov 0 (pp_rec par t) @@ -140,7 +143,11 @@ let rec pp_expr par env args = and apply2 st = pp_apply2 st par args in function | MLrel n -> - let id = get_db_name n env in apply (pr_id id) + let id = get_db_name n env in + (* Try to survive to the occurrence of a Dummy rel. + TODO: we should get rid of this hack (cf. #592) *) + let id = if Id.equal id dummy_name then Id.of_string "__" else id in + apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f @@ -200,8 +207,11 @@ let rec pp_expr par env args = | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) pp_par par (str "Prelude.error" ++ spc () ++ qs s) - | MLdummy -> - str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLdummy k -> + (* An [MLdummy] may be applied, but I don't really care. *) + (match msg_of_implicit k with + | "" -> str "__" + | s -> str "__" ++ spc () ++ pp_bracket_comment (str s)) | MLmagic a -> pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") @@ -320,7 +330,7 @@ let pp_decl = function prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s with Not_found -> prlist (fun id -> pr_id id ++ str " ") l ++ - if t == Taxiom then str "= () -- AXIOM TO BE REALIZED\n" + if t == Taxiom then str "= () -- AXIOM TO BE REALIZED" ++ fnl () else str "=" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 () @@ -331,7 +341,8 @@ let pp_decl = function prvecti (fun i r -> let void = is_inline_custom r || - (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) + (not (is_custom r) && + match defs.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then mt () else diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli index 99559bce..6f493206 100644 --- a/plugins/extraction/haskell.mli +++ b/plugins/extraction/haskell.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* json_dict [("what", json_str "expr:dummy")] + | MLdummy _ -> json_dict [("what", json_str "expr:dummy")] | MLmagic a -> json_dict [ ("what", json_str "expr:coerce"); ("value", json_expr env a) diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index b7dee6cb..db336152 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* true | _ -> false -let isDummy = function Tdummy _ -> true | _ -> false +let isTdummy = function Tdummy _ -> true | _ -> false + +let isMLdummy = function MLdummy _ -> true | _ -> false let sign_of_id = function - | Dummy -> Kill Kother + | Dummy -> Kill Kprop | _ -> Keep (* Classification of signatures *) @@ -310,45 +312,44 @@ let sign_of_id = function type sign_kind = | EmptySig | NonLogicalSig (* at least a [Keep] *) - | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *) | SafeLogicalSig (* only [Kill Ktype] *) + | UnsafeLogicalSig (* No [Keep], not all [Kill Ktype] *) let rec sign_kind = function | [] -> EmptySig | Keep :: _ -> NonLogicalSig | Kill k :: s -> - match sign_kind s with - | NonLogicalSig -> NonLogicalSig - | UnsafeLogicalSig -> UnsafeLogicalSig - | SafeLogicalSig | EmptySig -> - if k == Kother then UnsafeLogicalSig else SafeLogicalSig + match k, sign_kind s with + | _, NonLogicalSig -> NonLogicalSig + | Ktype, (SafeLogicalSig | EmptySig) -> SafeLogicalSig + | _, _ -> UnsafeLogicalSig (* Removing the final [Keep] in a signature *) let rec sign_no_final_keeps = function | [] -> [] | k :: s -> - let s' = k :: sign_no_final_keeps s in - match s' with [Keep] -> [] | _ -> s' + match k, sign_no_final_keeps s with + | Keep, [] -> [] + | k, l -> k::l (*s Removing [Tdummy] from the top level of a ML type. *) let type_expunge_from_sign env s t = - let rec expunge s t = - if List.is_empty s then t else match t with - | Tmeta {contents = Some t} -> expunge s t - | Tarr (a,b) -> - let t = expunge (List.tl s) b in - if List.hd s == Keep then Tarr (a, t) else t - | Tglob (r,l) -> - (match env r with - | Some mlt -> expunge s (type_subst_list l mlt) - | None -> assert false) - | _ -> assert false + let rec expunge s t = match s, t with + | [], _ -> t + | Keep :: s, Tarr(a,b) -> Tarr (a, expunge s b) + | Kill _ :: s, Tarr(a,b) -> expunge s b + | _, Tmeta {contents = Some t} -> expunge s t + | _, Tglob (r,l) -> + (match env r with + | Some mlt -> expunge s (type_subst_list l mlt) + | None -> assert false) + | _ -> assert false in let t = expunge (sign_no_final_keeps s) t in if lang () != Haskell && sign_kind s == UnsafeLogicalSig then - Tarr (Tdummy Kother, t) + Tarr (Tdummy Kprop, t) else t let type_expunge env t = @@ -385,7 +386,7 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with | MLfix (i1, id1, t1), MLfix (i2, id2, t2) -> Int.equal i1 i2 && Array.equal Id.equal id1 id2 && Array.equal eq_ml_ast t1 t2 | MLexn e1, MLexn e2 -> String.equal e1 e2 -| MLdummy, MLdummy -> true +| MLdummy k1, MLdummy k2 -> k1 == k2 | MLaxiom, MLaxiom -> true | MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2 | _ -> false @@ -420,7 +421,7 @@ let ast_iter_rel f = | MLapp (a,l) -> iter n a; List.iter (iter n) l | MLcons (_,_,l) | MLtuple l -> List.iter (iter n) l | MLmagic a -> iter n a - | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () in iter 0 (*s Map over asts. *) @@ -439,7 +440,7 @@ let ast_map f = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map f l) | MLtuple l -> MLtuple (List.map f l) | MLmagic a -> MLmagic (f a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a (*s Map over asts, with binding depth as parameter. *) @@ -457,7 +458,7 @@ let ast_map_lift f n = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map (f n) l) | MLtuple l -> MLtuple (List.map (f n) l) | MLmagic a -> MLmagic (f n a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a (*s Iter over asts. *) @@ -471,7 +472,7 @@ let ast_iter f = function | MLapp (a,l) -> f a; List.iter f l | MLcons (_,_,l) | MLtuple l -> List.iter f l | MLmagic a -> f a - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () (*S Operations concerning De Bruijn indices. *) @@ -507,9 +508,73 @@ let nb_occur_match = | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l | MLcons (_,_,l) | MLtuple l -> List.fold_left (fun r a -> r+(nb k a)) 0 l | MLmagic a -> nb k a - | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0 + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> 0 in nb 1 +(* Replace unused variables by _ *) + +let dump_unused_vars a = + let rec ren env a = match a with + | MLrel i -> + let () = (List.nth env (i-1)) := true in a + + | MLlam (id,b) -> + let occ_id = ref false in + let b' = ren (occ_id::env) b in + if !occ_id then if b' == b then a else MLlam(id,b') + else MLlam(Dummy,b') + + | MLletin (id,b,c) -> + let occ_id = ref false in + let b' = ren env b in + let c' = ren (occ_id::env) c in + if !occ_id then + if b' == b && c' == c then a else MLletin(id,b',c') + else + (* 'let' without occurrence: shouldn't happen after simpl *) + MLletin(Dummy,b',c') + + | MLcase (t,e,br) -> + let e' = ren env e in + let br' = Array.smartmap (ren_branch env) br in + if e' == e && br' == br then a else MLcase (t,e',br') + + | MLfix (i,ids,v) -> + let env' = List.init (Array.length ids) (fun _ -> ref false) @ env in + let v' = Array.smartmap (ren env') v in + if v' == v then a else MLfix (i,ids,v') + + | MLapp (b,l) -> + let b' = ren env b and l' = List.smartmap (ren env) l in + if b' == b && l' == l then a else MLapp (b',l') + + | MLcons(t,r,l) -> + let l' = List.smartmap (ren env) l in + if l' == l then a else MLcons (t,r,l') + + | MLtuple l -> + let l' = List.smartmap (ren env) l in + if l' == l then a else MLtuple l' + + | MLmagic b -> + let b' = ren env b in + if b' == b then a else MLmagic b' + + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> a + + and ren_branch env ((ids,p,b) as tr) = + let occs = List.map (fun _ -> ref false) ids in + let b' = ren (List.rev_append occs env) b in + let ids' = + List.map2 + (fun id occ -> if !occ then id else Dummy) + ids occs + in + if b' == b && List.equal eq_ml_ident ids ids' then tr + else (ids',p,b') + in + ren [] a + (*s Lifting on terms. [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *) @@ -559,7 +624,7 @@ let gen_subst v d t = if i' < 1 then a else if i' <= Array.length v then match v.(i'-1) with - | None -> MLexn ("UNBOUND " ^ string_of_int i') + | None -> assert false | Some u -> ast_lift n u else MLrel (i+d) | a -> ast_map_lift subst n a @@ -813,8 +878,8 @@ let census_add, census_max, census_clean = try h := add k i !h with Not_found -> h := (k, Int.Set.singleton i) :: !h in - let maxf k = - let len = ref 0 and lst = ref Int.Set.empty and elm = ref k in + let maxf () = + let len = ref 0 and lst = ref Int.Set.empty and elm = ref MLaxiom in List.iter (fun (e, s) -> let n = Int.Set.cardinal s in @@ -843,7 +908,7 @@ let factor_branches o typ br = if o.opt_case_cst then (try census_add (branch_as_cst br.(i)) i with Impossible -> ()); done; - let br_factor, br_set = census_max MLdummy in + let br_factor, br_set = census_max () in census_clean (); let n = Int.Set.cardinal br_set in if Int.equal n 0 then None @@ -926,7 +991,7 @@ let iota_gen br hd = in iota 0 hd let is_atomic = function - | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ -> true | _ -> false let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false @@ -948,9 +1013,20 @@ let expand_linear_let o id e = (* Some beta-iota reductions + simplifications. *) +let rec unmagic = function MLmagic e -> unmagic e | e -> e +let is_magic = function MLmagic _ -> true | _ -> false +let magic_hd a = match a with + | MLmagic _ :: _ -> a + | e :: a -> MLmagic e :: a + | [] -> assert false + let rec simpl o = function | MLapp (f, []) -> simpl o f - | MLapp (f, a) -> simpl_app o (List.map (simpl o) a) (simpl o f) + | MLapp (MLapp(f,a),a') -> simpl o (MLapp(f,a@a')) + | MLapp (f, a) -> + (* When the head of the application is magic, no need for magic on args *) + let a = if is_magic f then List.map unmagic a else a in + simpl_app o (List.map (simpl o) a) (simpl o f) | MLcase (typ,e,br) -> let br = Array.map (fun (l,p,t) -> (l,p,simpl o t)) br in simpl_case o typ br (simpl o e) @@ -970,12 +1046,18 @@ let rec simpl o = function if ast_occurs_itvl 1 n c.(i) then MLfix (i, ids, Array.map (simpl o) c) else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *) + | MLmagic(MLmagic _ as e) -> simpl o e + | MLmagic(MLapp (f,l)) -> simpl o (MLapp (MLmagic f, l)) + | MLmagic(MLletin(id,c,e)) -> simpl o (MLletin(id,c,MLmagic e)) + | MLmagic(MLcase(typ,e,br)) -> + let br' = Array.map (fun (ids,p,c) -> (ids,p,MLmagic c)) br in + simpl o (MLcase(typ,e,br')) + | MLmagic(MLexn _ as e) -> e | a -> ast_map (simpl o) a (* invariant : list [a] of arguments is non-empty *) and simpl_app o a = function - | MLapp (f',a') -> simpl_app o (a'@a) f' | MLlam (Dummy,t) -> simpl o (MLapp (ast_pop t, List.tl a)) | MLlam (id,t) -> (* Beta redex *) @@ -986,6 +1068,11 @@ and simpl_app o a = function | _ -> let a' = List.map (ast_lift 1) (List.tl a) in simpl o (MLletin (id, List.hd a, MLapp (t, a')))) + | MLmagic (MLlam (id,t)) -> + (* When we've at least one argument, we permute the magic + and the lambda, to simplify things a bit (see #2795). + Alas, the 1st argument must also be magic then. *) + simpl_app o (magic_hd a) (MLlam (id,MLmagic t)) | MLletin (id,e1,e2) when o.opt_let_app -> (* Application of a letin: we push arguments inside *) MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) @@ -998,7 +1085,7 @@ and simpl_app o a = function let a' = List.map (ast_lift k) a in (l, p, simpl o (MLapp (t,a')))) br in simpl o (MLcase (typ,e,br')) - | (MLdummy | MLexn _) as e -> e + | (MLdummy _ | MLexn _) as e -> e (* We just discard arguments in those cases. *) | f -> MLapp (f,a) @@ -1049,20 +1136,26 @@ let rec select_via_bl l args = match l,args with (*s [kill_some_lams] removes some head lambdas according to the signature [bl]. This list is build on the identifier list model: outermost lambda is on the right. - [Rels] corresponding to removed lambdas are supposed not to occur, and + [Rels] corresponding to removed lambdas are not supposed to occur + (except maybe in the case of Kimplicit), and the other [Rels] are made correct via a [gen_subst]. Output is not directly a [ml_ast], compose with [named_lams] if needed. *) +let is_impl_kill = function Kill (Kimplicit _) -> true | _ -> false + let kill_some_lams bl (ids,c) = let n = List.length bl in let n' = List.fold_left (fun n b -> if b == Keep then (n+1) else n) 0 bl in if Int.equal n n' then ids,c - else if Int.equal n' 0 then [],ast_lift (-n) c + else if Int.equal n' 0 && not (List.exists is_impl_kill bl) + then [],ast_lift (-n) c else begin let v = Array.make n None in let rec parse_ids i j = function | [] -> () | Keep :: l -> v.(i) <- Some (MLrel j); parse_ids (i+1) (j+1) l + | Kill (Kimplicit _ as k) :: l -> + v.(i) <- Some (MLdummy k); parse_ids (i+1) j l | Kill _ :: l -> parse_ids (i+1) j l in parse_ids 0 1 bl; select_via_bl bl ids, gen_subst v (n'-n) c @@ -1070,11 +1163,19 @@ let kill_some_lams bl (ids,c) = (*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or - if there is no lambda left at all. *) + if there is no lambda left at all. In addition, it now accepts a signature + that may mention some implicits. *) -let kill_dummy_lams c = +let rec merge_implicits ids s = match ids, s with + | [],_ -> [] + | _,[] -> List.map sign_of_id ids + | Dummy::ids, _::s -> Kill Kprop :: merge_implicits ids s + | _::ids, (Kill (Kimplicit _) as k)::s -> k :: merge_implicits ids s + | _::ids, _::s -> Keep :: merge_implicits ids s + +let kill_dummy_lams sign c = let ids,c = collect_lams c in - let bl = List.map sign_of_id ids in + let bl = merge_implicits ids (List.rev sign) in if not (List.memq Keep bl) then raise Impossible; let rec fst_kill n = function | [] -> raise Impossible @@ -1086,7 +1187,7 @@ let kill_dummy_lams c = let _, bl = List.chop skip bl in let c = named_lams ids_skip c in let ids',c = kill_some_lams bl (ids,c) in - ids, named_lams ids' c + (ids,bl), named_lams ids' c (*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] and a signature [s] and builds a eta-long version. *) @@ -1100,12 +1201,12 @@ let eta_expansion_sign s (ids,c) = let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels in ids, MLapp (ast_lift (i-1) c, a) | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l - | Kill _ :: l -> abs (Dummy :: ids) (MLdummy :: rels) (i+1) l + | Kill k :: l -> abs (Dummy :: ids) (MLdummy k :: rels) (i+1) l in abs ids [] 1 s (*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas - corresponding to [Del] in [s]. *) + corresponding to [Kill _] in [s]. *) let case_expunge s e = let m = List.length s in @@ -1123,17 +1224,18 @@ let term_expunge s (ids,c) = if List.is_empty s then c else let ids,c = kill_some_lams (List.rev s) (ids,c) in - if List.is_empty ids && lang () != Haskell && List.mem (Kill Kother) s then - MLlam (Dummy, ast_lift 1 c) + if List.is_empty ids && lang () != Haskell && + sign_kind s == UnsafeLogicalSig + then MLlam (Dummy, ast_lift 1 c) else named_lams ids c -(*s [kill_dummy_args ids r t] looks for occurrences of [MLrel r] in [t] and - purge the args of [MLrel r] corresponding to a [dummy_name]. +(*s [kill_dummy_args (ids,bl) r t] looks for occurrences of [MLrel r] in [t] + and purge the args of [MLrel r] corresponding to a [Kill] in [bl]. It makes eta-expansion if needed. *) -let kill_dummy_args ids r t = +let kill_dummy_args (ids,bl) r t = let m = List.length ids in - let bl = List.rev_map sign_of_id ids in + let sign = List.rev bl in let rec found n = function | MLrel r' when Int.equal r' (r + n) -> true | MLmagic e -> found n e @@ -1144,41 +1246,46 @@ let kill_dummy_args ids r t = let k = max 0 (m - (List.length a)) in let a = List.map (killrec n) a in let a = List.map (ast_lift k) a in - let a = select_via_bl bl (a @ (eta_args k)) in + let a = select_via_bl sign (a @ (eta_args k)) in named_lams (List.firstn k ids) (MLapp (ast_lift k e, a)) | e when found n e -> - let a = select_via_bl bl (eta_args m) in + let a = select_via_bl sign (eta_args m) in named_lams ids (MLapp (ast_lift m e, a)) | e -> ast_map_lift killrec n e in killrec 0 t (*s The main function for local [dummy] elimination. *) +let sign_of_args a = + List.map (function MLdummy k -> Kill k | _ -> Keep) a + let rec kill_dummy = function | MLfix(i,fi,c) -> (try - let ids,c = kill_dummy_fix i c in - ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids 1 (MLrel 1)) + let k,c = kill_dummy_fix i c [] in + ast_subst (MLfix (i,fi,c)) (kill_dummy_args k 1 (MLrel 1)) with Impossible -> MLfix (i,fi,Array.map kill_dummy c)) | MLapp (MLfix (i,fi,c),a) -> let a = List.map kill_dummy a in + (* Heuristics: if some arguments are implicit args, we try to + eliminate the corresponding arguments of the fixpoint *) (try - let ids,c = kill_dummy_fix i c in + let k,c = kill_dummy_fix i c (sign_of_args a) in let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in - let fake' = kill_dummy_args ids 1 fake in + let fake' = kill_dummy_args k 1 fake in ast_subst (MLfix (i,fi,c)) fake' with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a)) | MLletin(id, MLfix (i,fi,c),e) -> (try - let ids,c = kill_dummy_fix i c in - let e = kill_dummy (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_fix i c [] in + let e = kill_dummy (kill_dummy_args k 1 e) in MLletin(id, MLfix(i,fi,c),e) with Impossible -> MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) | MLletin(id,c,e) -> (try - let ids,c = kill_dummy_lams (kill_dummy_hd c) in - let e = kill_dummy (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_lams [] (kill_dummy_hd c) in + let e = kill_dummy (kill_dummy_args k 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy e)) @@ -1190,21 +1297,21 @@ and kill_dummy_hd = function | MLlam(id,e) -> MLlam(id, kill_dummy_hd e) | MLletin(id,c,e) -> (try - let ids,c = kill_dummy_lams (kill_dummy_hd c) in - let e = kill_dummy_hd (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_lams [] (kill_dummy_hd c) in + let e = kill_dummy_hd (kill_dummy_args k 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e)) | a -> a -and kill_dummy_fix i c = +and kill_dummy_fix i c s = let n = Array.length c in - let ids,ci = kill_dummy_lams (kill_dummy_hd c.(i)) in + let k,ci = kill_dummy_lams s (kill_dummy_hd c.(i)) in let c = Array.copy c in c.(i) <- ci; for j = 0 to (n-1) do - c.(j) <- kill_dummy (kill_dummy_args ids (n-i) c.(j)) + c.(j) <- kill_dummy (kill_dummy_args k (n-i) c.(j)) done; - ids,c + k,c (*s Putting things together. *) @@ -1267,7 +1374,7 @@ let rec ml_size = function | MLfix(_,_,f) -> ml_size_array f | MLletin (_,_,t) -> ml_size t | MLmagic t -> ml_size t - | MLglob _ | MLrel _ | MLexn _ | MLdummy | MLaxiom -> 0 + | MLglob _ | MLrel _ | MLexn _ | MLdummy _ | MLaxiom -> 0 and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index 0a71d2c8..c6675524 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ml_type -> ml_type val type_expunge_from_sign : abbrev_map -> signature -> ml_type -> ml_type val eq_ml_type : ml_type -> ml_type -> bool -val isDummy : ml_type -> bool +val isTdummy : ml_type -> bool +val isMLdummy : ml_ast -> bool val isKill : sign -> bool val case_expunge : signature -> ml_ast -> ml_ident list * ml_ast @@ -110,6 +111,8 @@ val ast_subst : ml_ast -> ml_ast -> ml_ast val ast_glob_subst : ml_ast Refmap'.t -> ml_ast -> ml_ast +val dump_unused_vars : ml_ast -> ml_ast + val normalize : ml_ast -> ml_ast val optimize_fix : ml_ast -> ml_ast val inline : global_reference -> ml_ast -> bool @@ -125,8 +128,8 @@ exception Impossible type sign_kind = | EmptySig | NonLogicalSig (* at least a [Keep] *) - | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *) | SafeLogicalSig (* only [Kill Ktype] *) + | UnsafeLogicalSig (* No [Keep], not all [Kill Ktype] *) val sign_kind : signature -> sign_kind diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 8158ac64..b5e8b480 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* patt_iter_references do_cons p) v | MLrel _ | MLlam _ | MLapp _ | MLletin _ | MLtuple _ | MLfix _ | MLexn _ - | MLdummy | MLaxiom | MLmagic _ -> () + | MLdummy _ | MLaxiom | MLmagic _ -> () in iter a let ind_iter_references do_term do_cons do_type kn ind = @@ -269,7 +269,7 @@ let rec optim_se top to_appear s = function let a = normalize (ast_glob_subst !s a) in let i = inline r a in if i then s := Refmap'.add r a !s; - let d = match optimize_fix a with + let d = match dump_unused_vars (optimize_fix a) with | MLfix (0, _, [|c|]) -> Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) | a -> Dterm (r, a, t) @@ -283,7 +283,8 @@ let rec optim_se top to_appear s = function if inline rv.(i) fake_body then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s done; - (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) + let av' = Array.map dump_unused_vars av in + (l,SEdecl (Dfix (rv, av', tv))) :: (optim_se top to_appear s lse) | (l,SEmodule m) :: lse -> let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr} in (l,SEmodule m) :: (optim_se top to_appear s lse) @@ -387,16 +388,15 @@ let is_prefix pre s = in is_prefix_aux 0 -let check_implicits = function - | MLexn s -> - if String.length s > 8 && (s.[0] == 'U' || s.[0] == 'I') then - begin - if is_prefix "UNBOUND" s then assert false; - if is_prefix "IMPLICIT" s then - error_non_implicit (String.sub s 9 (String.length s - 9)); - end; - false - | _ -> false +exception RemainingImplicit of kill_reason + +let check_for_remaining_implicits struc = + let check = function + | MLdummy (Kimplicit _ as k) -> raise (RemainingImplicit k) + | _ -> false + in + try ignore (struct_ast_search check struc) + with RemainingImplicit k -> err_or_warn_remaining_implicit k let optimize_struct to_appear struc = let subst = ref (Refmap'.empty : ml_ast Refmap'.t) in @@ -404,12 +404,16 @@ let optimize_struct to_appear struc = List.map (fun (mp,lse) -> (mp, optim_se true (fst to_appear) subst lse)) struc in - ignore (struct_ast_search check_implicits opt_struc); - if library () then - List.filter (fun (_,lse) -> not (List.is_empty lse)) opt_struc - else begin - reset_needed (); - List.iter add_needed (fst to_appear); - List.iter add_needed_mp (snd to_appear); - depcheck_struct opt_struc - end + let mini_struc = + if library () then + List.filter (fun (_,lse) -> not (List.is_empty lse)) opt_struc + else + begin + reset_needed (); + List.iter add_needed (fst to_appear); + List.iter add_needed_mp (snd to_appear); + depcheck_struct opt_struc + end + in + let () = check_for_remaining_implicits mini_struc in + mini_struc diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli index ca32f029..dc870824 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mt () - | Some com -> pp_comment com ++ fnl () ++ fnl () + | Some com -> pp_comment com ++ fnl2 () + +let then_nl pp = if Pp.is_empty pp then mt () else pp ++ fnl () + +let pp_tdummy usf = + if usf.tdummy || usf.tunknown then str "type __ = Obj.t" ++ fnl () else mt () + +let pp_mldummy usf = + if usf.mldummy then + str "let __ = let rec f _ = Obj.repr f in Obj.repr f" ++ fnl () + else mt () let preamble _ comment used_modules usf = pp_header_comment comment ++ - prlist pp_open used_modules ++ - (if List.is_empty used_modules then mt () else fnl ()) ++ - (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++ - (if usf.mldummy then - str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n" - else mt ()) ++ - (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ()) + then_nl (prlist pp_open used_modules) ++ + then_nl (pp_tdummy usf ++ pp_mldummy usf) let sig_preamble _ comment used_modules usf = - pp_header_comment comment ++ fnl () ++ fnl () ++ - prlist pp_open used_modules ++ - (if List.is_empty used_modules then mt () else fnl ()) ++ - (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt()) + pp_header_comment comment ++ + then_nl (prlist pp_open used_modules) ++ + then_nl (pp_tdummy usf) (*s The pretty-printer for Ocaml syntax*) @@ -171,7 +178,11 @@ let rec pp_expr par env args = and apply2 st = pp_apply2 st par args in function | MLrel n -> - let id = get_db_name n env in apply (pr_id id) + let id = get_db_name n env in + (* Try to survive to the occurrence of a Dummy rel. + TODO: we should get rid of this hack (cf. #592) *) + let id = if Id.equal id dummy_name then Id.of_string "__" else id in + apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f @@ -199,8 +210,11 @@ let rec pp_expr par env args = | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)")) - | MLdummy -> - str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLdummy k -> + (* An [MLdummy] may be applied, but I don't really care. *) + (match msg_of_implicit k with + | "" -> str "__" + | s -> str "__" ++ spc () ++ str ("(* "^s^" *)")) | MLmagic a -> pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args) | MLaxiom -> @@ -352,7 +366,7 @@ and pp_function env t = | MLcase(Tglob(r,_),MLrel 1,pv) when not (is_coinductive r) && List.is_empty (get_record_fields r) && not (is_custom_match pv) -> - if not (ast_occurs 1 (MLcase(Tunknown,MLdummy,pv))) then + if not (ast_occurs 1 (MLcase(Tunknown,MLaxiom,pv))) then pr_binding (List.rev (List.tl bl)) ++ str " = function" ++ fnl () ++ v 0 (pp_pat env' pv) @@ -378,9 +392,14 @@ and pp_fix par env i (ids,bl) args = fnl () ++ hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) +(* Ad-hoc double-newline in v boxes, with enough negative whitespace + to avoid indenting the intermediate blank line *) + +let cut2 () = brk (0,-100000) ++ brk (0,0) + let pp_val e typ = hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++ - str " **)") ++ fnl2 () + str " **)") ++ cut2 () (*s Pretty-printing of [Dfix] *) @@ -389,11 +408,11 @@ let pp_Dfix (rv,c,t) = (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv in let rec pp init i = - if i >= Array.length rv then - (if init then failwith "empty phrase" else mt ()) + if i >= Array.length rv then mt () else let void = is_inline_custom rv.(i) || - (not (is_custom rv.(i)) && match c.(i) with MLexn "UNUSED" -> true | _ -> false) + (not (is_custom rv.(i)) && + match c.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then pp init (i+1) else @@ -401,7 +420,7 @@ let pp_Dfix (rv,c,t) = if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i)) else pp_function (empty_env ()) c.(i) in - (if init then mt () else fnl2 ()) ++ + (if init then mt () else cut2 ()) ++ pp_val names.(i) t.(i) ++ str (if init then "let rec " else "and ") ++ names.(i) ++ def ++ pp false (i+1) @@ -466,8 +485,8 @@ let pp_coind pl name = let pp_ind co kn ind = let prefix = if co then "__" else "" in - let some = ref false in - let init= ref (str "type ") in + let initkwd = str "type " in + let nextkwd = fnl () ++ str "and " in let names = Array.mapi (fun i p -> if p.ip_logical then mt () else pp_global Type (IndRef (kn,i))) @@ -480,29 +499,20 @@ let pp_ind co kn ind = p.ip_types) ind.ind_packets in - let rec pp i = + let rec pp i kwd = if i >= Array.length ind.ind_packets then mt () else let ip = (kn,i) 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 - some := true; - if p.ip_logical then pp_logical_ind p ++ pp (i+1) - else - let s = !init in - begin - init := (fnl () ++ str "and "); - s ++ - (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ - pp_one_ind - prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ - pp (i+1) - end - end + if is_custom (IndRef ip) then pp (i+1) kwd + else if p.ip_logical then pp_logical_ind p ++ pp (i+1) kwd + else + kwd ++ (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ + pp_one_ind prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ + pp (i+1) nextkwd in - let st = pp 0 in if !some then st else failwith "empty phrase" + pp 0 initkwd (*s Pretty-printing of a declaration. *) @@ -515,8 +525,8 @@ let pp_mind kn i = | Standard -> pp_ind false kn i let pp_decl = function - | Dtype (r,_,_) when is_inline_custom r -> failwith "empty phrase" - | Dterm (r,_,_) when is_inline_custom r -> failwith "empty phrase" + | Dtype (r,_,_) when is_inline_custom r -> mt () + | Dterm (r,_,_) when is_inline_custom r -> mt () | Dind (kn,i) -> pp_mind kn i | Dtype (r, l, t) -> let name = pp_global Type r in @@ -524,13 +534,13 @@ let pp_decl = function let ids, def = try let ids,s = find_type_custom r in - pp_string_parameters ids, str "=" ++ spc () ++ str s + pp_string_parameters ids, str " =" ++ spc () ++ str s with Not_found -> pp_parameters l, - if t == Taxiom then str "(* AXIOM TO BE REALIZED *)" - else str "=" ++ spc () ++ pp_type false l t + if t == Taxiom then str " (* AXIOM TO BE REALIZED *)" + else str " =" ++ spc () ++ pp_type false l t in - hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) + hov 2 (str "type " ++ ids ++ name ++ def) | Dterm (r, a, t) -> let def = if is_custom r then str (" = " ^ find_custom r) @@ -564,8 +574,8 @@ let pp_alias_decl ren = function rv let pp_spec = function - | Sval (r,_) when is_inline_custom r -> failwith "empty phrase" - | Stype (r,_,_) when is_inline_custom r -> failwith "empty phrase" + | Sval (r,_) when is_inline_custom r -> mt () + | Stype (r,_,_) when is_inline_custom r -> mt () | Sind (kn,i) -> pp_mind kn i | Sval (r,t) -> let def = pp_type false [] t in @@ -577,15 +587,15 @@ let pp_spec = function let ids, def = try let ids, s = find_type_custom r in - pp_string_parameters ids, str "= " ++ str s + pp_string_parameters ids, str " =" ++ spc () ++ str s with Not_found -> let ids = pp_parameters l in match ot with | None -> ids, mt () - | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" - | Some t -> ids, str "=" ++ spc () ++ pp_type false l t + | Some Taxiom -> ids, str " (* AXIOM TO BE REALIZED *)" + | Some t -> ids, str " =" ++ spc () ++ pp_type false l t in - hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) + hov 2 (str "type " ++ ids ++ name ++ def) let pp_alias_spec ren = function | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } @@ -602,7 +612,7 @@ let rec pp_specif = function | (l,Spec s) -> (try let ren = Common.check_duplicate (top_visible_mp ()) l in - hov 1 (str ("module "^ren^" : sig ") ++ fnl () ++ pp_spec s) ++ + hov 1 (str ("module "^ren^" : sig") ++ fnl () ++ pp_spec s) ++ fnl () ++ str "end" ++ fnl () ++ pp_alias_spec ren s with Not_found -> pp_spec s) @@ -610,15 +620,15 @@ let rec pp_specif = function let def = pp_module_type [] mt in let def' = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module " ++ name ++ str " : " ++ fnl () ++ def) ++ + hov 1 (str "module " ++ name ++ str " :" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ hov 1 (str ("module "^ren^" : ") ++ fnl () ++ def') + fnl () ++ hov 1 (str ("module "^ren^" :") ++ fnl () ++ def') with Not_found -> Pp.mt ()) | (l,Smodtype mt) -> let def = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ + hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module type "^ren^" = ") ++ name @@ -635,14 +645,15 @@ and pp_module_type params = function | MTsig (mp, sign) -> push_visible mp params; let try_pp_specif l x = - try pp_specif x :: l with Failure "empty phrase" -> l + let px = pp_specif x in + if Pp.is_empty px then l else px::l in (* We cannot use fold_right here due to side effects in pp_specif *) let l = List.fold_left try_pp_specif [] sign in let l = List.rev l in pop_visible (); - str "sig " ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ + str "sig" ++ fnl () ++ + v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl () ++ str "end" | MTwith(mt,ML_With_type(idl,vl,typ)) -> let ids = pp_parameters (rename_tvars keywords vl) in @@ -672,7 +683,7 @@ let rec pp_structure_elem = function | (l,SEdecl d) -> (try let ren = Common.check_duplicate (top_visible_mp ()) l in - hov 1 (str ("module "^ren^" = struct ") ++ fnl () ++ pp_decl d) ++ + hov 1 (str ("module "^ren^" = struct") ++ fnl () ++ pp_decl d) ++ fnl () ++ str "end" ++ fnl () ++ pp_alias_decl ren d with Not_found -> pp_decl d) @@ -686,8 +697,8 @@ let rec pp_structure_elem = function let def = pp_module_expr [] m.ml_mod_expr in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 - (str "module " ++ name ++ typ ++ str " = " ++ - (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++ + (str "module " ++ name ++ typ ++ str " =" ++ + (if is_short m.ml_mod_expr then spc () else fnl ()) ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module "^ren^" = ") ++ name @@ -695,7 +706,7 @@ let rec pp_structure_elem = function | (l,SEmodtype m) -> let def = pp_module_type [] m in let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ + hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module type "^ren^" = ") ++ name @@ -713,36 +724,42 @@ and pp_module_expr params = function | MEstruct (mp, sel) -> push_visible mp params; let try_pp_structure_elem l x = - try pp_structure_elem x :: l with Failure "empty phrase" -> l + let px = pp_structure_elem x in + if Pp.is_empty px then l else px::l in (* We cannot use fold_right here due to side effects in pp_structure_elem *) let l = List.fold_left try_pp_structure_elem [] sel in let l = List.rev l in pop_visible (); - str "struct " ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ + str "struct" ++ fnl () ++ + v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl () ++ str "end" +let rec prlist_sep_nonempty sep f = function + | [] -> mt () + | [h] -> f h + | h::t -> + let e = f h in + let r = prlist_sep_nonempty sep f t in + if Pp.is_empty e then r + else e ++ sep () ++ r + let do_struct f s = - let pp s = try f s ++ fnl2 () with Failure "empty phrase" -> mt () - in let ppl (mp,sel) = push_visible mp []; - let p = prlist_strict pp sel in + let p = prlist_sep_nonempty cut2 f 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 + let p = prlist_sep_nonempty cut2 ppl s in (if not (modular ()) then repeat (List.length s) pop_visible ()); - p + v 0 p ++ fnl () 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 ocaml_descr = { keywords = keywords; file_suffix = ".ml"; @@ -754,5 +771,3 @@ let ocaml_descr = { pp_sig = pp_signature; pp_decl = pp_decl; } - - diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli index 4e796792..f579a54b 100644 --- a/plugins/extraction/ocaml.mli +++ b/plugins/extraction/ocaml.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (* An [MLexn] may be applied, but I don't really care. *) paren (str "error" ++ spc () ++ qs s) - | MLdummy -> + | MLdummy _ -> str "__" (* An [MLdummy] may be applied, but I don't really care. *) | MLmagic a -> pp_expr env args a @@ -183,7 +183,8 @@ let pp_decl = function prvecti (fun i r -> let void = is_inline_custom r || - (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) + (not (is_custom r) && + match defs.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then mt () else diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli index f0e36e09..5e1ec0d5 100644 --- a/plugins/extraction/scheme.mli +++ b/plugins/extraction/scheme.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 1 in len mp -let visible_con kn = at_toplevel (base_mp (con_modpath kn)) - let rec prefixes_mp mp = match mp with | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') | _ -> MPset.singleton mp @@ -105,17 +103,30 @@ let labels_of_ref r = (* Theses tables are not registered within coq save/undo mechanism since we reset their contents at each run of Extraction *) -(*s Constants tables. *) +(* We use [constant_body] (resp. [mutual_inductive_body]) as checksum + to ensure that the table contents aren't outdated. *) -let terms = ref (Cmap_env.empty : ml_decl Cmap_env.t) -let init_terms () = terms := Cmap_env.empty -let add_term kn d = terms := Cmap_env.add kn d !terms -let lookup_term kn = Cmap_env.find kn !terms +(*s Constants tables. *) -let types = ref (Cmap_env.empty : ml_schema Cmap_env.t) -let init_types () = types := Cmap_env.empty -let add_type kn s = types := Cmap_env.add kn s !types -let lookup_type kn = Cmap_env.find kn !types +let typedefs = ref (Cmap_env.empty : (constant_body * ml_type) Cmap_env.t) +let init_typedefs () = typedefs := Cmap_env.empty +let add_typedef kn cb t = + typedefs := Cmap_env.add kn (cb,t) !typedefs +let lookup_typedef kn cb = + try + let (cb0,t) = Cmap_env.find kn !typedefs in + if cb0 == cb then Some t else None + with Not_found -> None + +let cst_types = + ref (Cmap_env.empty : (constant_body * ml_schema) Cmap_env.t) +let init_cst_types () = cst_types := Cmap_env.empty +let add_cst_type kn cb s = cst_types := Cmap_env.add kn (cb,s) !cst_types +let lookup_cst_type kn cb = + try + let (cb0,s) = Cmap_env.find kn !cst_types in + if cb0 == cb then Some s else None + with Not_found -> None (*s Inductives table. *) @@ -124,7 +135,14 @@ let inductives = let init_inductives () = inductives := Mindmap_env.empty let add_ind kn mib ml_ind = inductives := Mindmap_env.add kn (mib,ml_ind) !inductives -let lookup_ind kn = Mindmap_env.find kn !inductives +let lookup_ind kn mib = + try + let (mib0,ml_ind) = Mindmap_env.find kn !inductives in + if mib == mib0 then Some ml_ind + else None + with Not_found -> None + +let unsafe_lookup_ind kn = snd (Mindmap_env.find kn !inductives) let inductive_kinds = ref (Mindmap_env.empty : inductive_kind Mindmap_env.t) @@ -244,10 +262,10 @@ let safe_basename_of_global r = | ConstRef kn -> Label.to_id (con_label kn) | IndRef (kn,0) -> Label.to_id (mind_label kn) | IndRef (kn,i) -> - (try (snd (lookup_ind kn)).ind_packets.(i).ip_typename + (try (unsafe_lookup_ind kn).ind_packets.(i).ip_typename with Not_found -> last_chance r) | ConstructRef ((kn,i),j) -> - (try (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1) + (try (unsafe_lookup_ind kn).ind_packets.(i).ip_consnames.(j-1) with Not_found -> last_chance r) | VarRef _ -> assert false @@ -401,16 +419,34 @@ let error_MPfile_as_mod mp b = "Monolithic Extraction cannot deal with this situation.\n"^ "Please "^s2^"use (Recursive) Extraction Library instead.\n")) -let msg_non_implicit r n id = - let name = match id with - | Anonymous -> "" - | Name id -> "(" ^ Id.to_string id ^ ") " - in - "The " ^ (String.ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r) - -let error_non_implicit msg = - err (str (msg ^ " still occurs after extraction.") ++ - fnl () ++ str "Please check the Extraction Implicit declarations.") +let argnames_of_global r = + let typ = Global.type_of_global_unsafe r in + let rels,_ = + decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in + List.rev_map fst rels + +let msg_of_implicit = function + | Kimplicit (r,i) -> + let name = match List.nth (argnames_of_global r) (i-1) with + | Anonymous -> "" + | Name id -> "(" ^ Id.to_string id ^ ") " + in + (String.ordinal i)^" argument "^name^"of "^(string_of_global r) + | Ktype | Kprop -> "" + +let error_remaining_implicit k = + let s = msg_of_implicit k in + err (str ("An implicit occurs after extraction : "^s^".") ++ fnl () ++ + str "Please check your Extraction Implicit declarations." ++ fnl() ++ + str "You might also try Unset Extraction SafeImplicits to force" ++ + fnl() ++ str "the extraction of unsafe code and review it manually.") + +let warning_remaining_implicit k = + let s = msg_of_implicit k in + msg_warning + (str ("At least an implicit occurs after extraction : "^s^".") ++ fnl () ++ + str "Extraction SafeImplicits is unset, extracting nonetheless," ++ fnl () + ++ str "but this code is potentially unsafe, please review it manually.") let check_loaded_modfile mp = match base_mp mp with | MPfile dp -> @@ -635,32 +671,39 @@ let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) (*s Extraction Implicit *) +let safe_implicit = my_bool_option "SafeImplicits" true + +let err_or_warn_remaining_implicit k = + if safe_implicit () then + error_remaining_implicit k + else + warning_remaining_implicit k + type int_or_id = ArgInt of int | ArgId of Id.t let implicits_table = Summary.ref Refmap'.empty ~name:"ExtrImplicit" let implicits_of_global r = - try Refmap'.find r !implicits_table with Not_found -> [] + try Refmap'.find r !implicits_table with Not_found -> Int.Set.empty let add_implicits r l = - let typ = Global.type_of_global_unsafe r in - let rels,_ = - decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in - let names = List.rev_map fst rels in + let names = argnames_of_global r in let n = List.length names in - let check = function + let add_arg s = function | ArgInt i -> - if 1 <= i && i <= n then i + if 1 <= i && i <= n then Int.Set.add i s else err (int i ++ str " is not a valid argument number for " ++ safe_pr_global r) | ArgId id -> - (try List.index Name.equal (Name id) names - with Not_found -> - err (str "No argument " ++ pr_id id ++ str " for " ++ - safe_pr_global r)) + try + let i = List.index Name.equal (Name id) names in + Int.Set.add i s + with Not_found -> + err (str "No argument " ++ pr_id id ++ str " for " ++ + safe_pr_global r) in - let l' = List.map check l in - implicits_table := Refmap'.add r l' !implicits_table + let ints = List.fold_left add_arg Int.Set.empty l in + implicits_table := Refmap'.add r ints !implicits_table (* Registration of operations for rollback. *) @@ -851,6 +894,6 @@ let extract_inductive r s l optstr = (*s Tables synchronization. *) let reset_tables () = - init_terms (); init_types (); init_inductives (); + init_typedefs (); init_cst_types (); init_inductives (); init_inductive_kinds (); init_recursors (); init_projs (); init_axioms (); init_opaques (); reset_modfile () diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 648f2321..2b163610 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Id.t @@ -38,8 +38,8 @@ val error_MPfile_as_mod : module_path -> bool -> 'a val check_inside_module : unit -> unit val check_inside_section : unit -> unit val check_loaded_modfile : module_path -> unit -val msg_non_implicit : global_reference -> int -> Name.t -> string -val error_non_implicit : string -> 'a +val msg_of_implicit : kill_reason -> string +val err_or_warn_remaining_implicit : kill_reason -> unit val info_file : string -> unit @@ -55,7 +55,6 @@ val string_of_modfile : module_path -> string val file_of_modfile : module_path -> string val is_toplevel : module_path -> bool val at_toplevel : module_path -> bool -val visible_con : constant -> bool val mp_length : module_path -> int val prefixes_mp : module_path -> MPset.t val common_prefix_from_list : @@ -65,14 +64,22 @@ val labels_of_ref : global_reference -> module_path * Label.t list (*s Some table-related operations *) -val add_term : constant -> ml_decl -> unit -val lookup_term : constant -> ml_decl +(* For avoiding repeated extraction of the same constant or inductive, + we use cache functions below. Indexing by constant name isn't enough, + due to modules we could have a same constant name but different + content. So we check that the [constant_body] hasn't changed from + recording time to retrieving time. Same for inductive : we store + [mutual_inductive_body] as checksum. In both case, we should ideally + also check the env *) -val add_type : constant -> ml_schema -> unit -val lookup_type : constant -> ml_schema +val add_typedef : constant -> constant_body -> ml_type -> unit +val lookup_typedef : constant -> constant_body -> ml_type option + +val add_cst_type : constant -> constant_body -> ml_schema -> unit +val lookup_cst_type : constant -> constant_body -> ml_schema option val add_ind : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit -val lookup_ind : mutual_inductive -> mutual_inductive_body * ml_ind +val lookup_ind : mutual_inductive -> mutual_inductive_body -> ml_ind option val add_inductive_kind : mutual_inductive -> inductive_kind -> unit val is_coinductive : global_reference -> bool @@ -166,7 +173,7 @@ val to_keep : global_reference -> bool (*s Table for implicits arguments *) -val implicits_of_global : global_reference -> int list +val implicits_of_global : global_reference -> Int.Set.t (*s Table for user-given custom ML extractions. *) diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 62a8605a..ae2d059f 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (* name of the function, the fonctionnal and the fixpoint equation *) + constant*constant*constant -> (* name of the function, the functional and the fixpoint equation *) constr option ref -> (* a pointer to the obligation proofs lemma *) bool -> (* is that function uses measure *) int -> (* the number of recursive argument *) diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index bc082f07..3fa2644c 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let arg_res = build_entry_lc env funname avoid case_arg in + let arg_res = build_entry_lc env funname ctxt_argsl.to_avoid case_arg in combine_results combine_args arg_res ctxt_argsl ) el diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index d9794014..a800c186 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* logical_kind -> constr list -> global_reference -> glob -(* Debuging mechanism *) +(* Debugging mechanism *) let debug_queue = Stack.create () let rec print_debug_queue b e = @@ -291,9 +291,9 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = -(* Travelling term. +(* Traveling term. Both definitions of [f_terminate] and [f_equation] use the same generic - travelling mechanism. + traveling mechanism. *) (* [check_not_nested forbidden e] checks that [e] does not contains any variable @@ -327,7 +327,7 @@ let check_not_nested forbidden e = with UserError(_,p) -> errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) -(* ['a info] contains the local information for travelling *) +(* ['a info] contains the local information for traveling *) type 'a infos = { nb_arg : int; (* function number of arguments *) concl_tac : tactic; (* final tactic to finish proofs *) @@ -337,7 +337,7 @@ type 'a infos = f_id : Id.t; (* function name *) f_constr : constr; (* function term *) f_terminate : constr; (* termination proof term *) - func : global_reference; (* functionnal reference *) + func : global_reference; (* functional reference *) info : 'a; is_main_branch : bool; (* on the main branch or on a matched expression *) is_final : bool; (* final first order term or not *) @@ -357,7 +357,7 @@ type ('a,'b) journey_info_tac = 'b infos -> (* argument of the tactic *) tactic -(* journey_info : specifies the actions to do on the different term constructors during the travelling of the term +(* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) type journey_info = { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac; diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v index dd4d596f..a19e9df9 100644 --- a/plugins/micromega/Env.v +++ b/plugins/micromega/Env.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - PApp (pi3 (pattern_of_constr (Global.env()) Evd.empty f), Array.map aux args) + PApp (pattern_of_constr (Global.env()) Evd.empty f, Array.map aux args) | Cast (c,_,_) -> aux c - | _ -> pi3 (pattern_of_constr (Global.env())(*FIXME*) Evd.empty c) + | _ -> pattern_of_constr (Global.env())(*FIXME*) Evd.empty c in aux bodyi diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 95407c5f..560e6a89 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -46,7 +46,7 @@ let occ_step_eq s1 s2 = match s1, s2 with d'une liste de pas à partir de la racine de l'hypothèse *) type occurrence = {o_hyp : Names.Id.t; o_path : occ_path} -(* \subsection{refiable formulas} *) +(* \subsection{reifiable formulas} *) type oformula = (* integer *) | Oint of Bigint.bigint @@ -55,7 +55,7 @@ type oformula = | Omult of oformula * oformula | Ominus of oformula * oformula | Oopp of oformula - (* an atome in the environment *) + (* an atom in the environment *) | Oatom of int (* weird expression that cannot be translated *) | Oufo of oformula @@ -75,7 +75,7 @@ type oproposition = | Pimp of int * oproposition * oproposition | Pprop of Term.constr -(* Les équations ou proposiitions atomiques utiles du calcul *) +(* Les équations ou propositions atomiques utiles du calcul *) and oequation = { e_comp: comparaison; (* comparaison *) e_left: oformula; (* formule brute gauche *) @@ -1266,7 +1266,7 @@ let resolution env full_reified_goal systems_list = | (O_right :: l) -> app coq_p_right [| loop l |] in let correct_index = let i = List.index0 Names.Id.equal e.e_origin.o_hyp l_hyps in - (* PL: it seems that additionnally introduced hyps are in the way during + (* PL: it seems that additionally introduced hyps are in the way during normalization, hence this index shifting... *) if Int.equal i 0 then 0 else Pervasives.(+) i (List.length to_introduce) in diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 267cd472..7394cebd 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* x = y. Proof. exact (fun x y => proj1 (N.eqb_eq x y)). Qed. -(**Same as above : definition of two,extensionaly equal, generic morphisms *) +(**Same as above : definition of two, extensionally equal, generic morphisms *) (**from N to any semi-ring*) Section NMORPHISM. Variable R : Type. @@ -671,7 +671,7 @@ End GEN_DIV. end. (* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above - are only optimisations that directly returns the reifid constant + are only optimisations that directly returns the reified constant instead of resorting to the constant propagation of the simplification algorithm. *) Ltac inv_gen_phi rO rI cO cI t := diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v index a10eeecc..6c1a79e4 100644 --- a/plugins/setoid_ring/NArithRing.v +++ b/plugins/setoid_ring/NArithRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* . diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 3cfc0dc8..ca1d0b7f 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* true | Some l -> not (Evd.is_flexible_level evd l) -let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = +let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t = let evdref = ref evd in let modified = ref false in let rec refresh status dir t = @@ -98,7 +98,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = if isArity t then (match pbty with | None -> t - | Some dir -> refresh univ_rigid dir t) + | Some dir -> refresh status dir t) else (refresh_term_evars false true t; t) in if !modified then !evdref, t' else !evdref, t @@ -609,7 +609,8 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let id = next_name_away na avoid in let evd,t_in_sign = let s = Retyping.get_sort_of env evd t_in_env in - let evd,ty_t_in_sign = refresh_universes ~inferred:true (Some false) env evd (mkSort s) in + let evd,ty_t_in_sign = refresh_universes + ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env in let evd,b_in_sign = match b with @@ -627,7 +628,8 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = in let evd,ev2ty_in_sign = let s = Retyping.get_sort_of env evd ty_in_env in - let evd,ty_t_in_sign = refresh_universes ~inferred:true (Some false) env evd (mkSort s) in + let evd,ty_t_in_sign = refresh_universes + ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src ty_in_env ty_t_in_sign sign2 filter2 inst2_in_env in let evd,ev2_in_sign = @@ -1284,10 +1286,16 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = | l -> evd let occur_evar_upto_types sigma n c = + let seen = ref Evar.Set.empty in let rec occur_rec c = match kind_of_term c with | Evar (sp,_) when Evar.equal sp n -> raise Occur - | Evar e -> Option.iter occur_rec (existential_opt_value sigma e); - occur_rec (existential_type sigma e) + | Evar (sp,args as e) -> + if Evar.Set.mem sp !seen then + Array.iter occur_rec args + else ( + seen := Evar.Set.add sp !seen; + Option.iter occur_rec (existential_opt_value sigma e); + occur_rec (existential_type sigma e)) | _ -> iter_constr occur_rec c in try occur_rec c; false with Occur -> true diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 21d97609..918ba12f 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ?choose:bool -> env -> evar_map -> bool option -> existential -> constr -> evar_map -val refresh_universes : ?inferred:bool -> ?onlyalg:bool (* Only algebraic universes *) -> +val refresh_universes : ?status:Evd.rigid -> + ?onlyalg:bool (* Only algebraic universes *) -> bool option (* direction: true for levels lower than the existing levels *) -> env -> evar_map -> types -> evar_map * types diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index b27803bd..e23e5a53 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* None + | Some e' -> if Evar.equal e e' then None else d.principal_future_goal + in + let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in + { d with undf_evars; defn_evars; principal_future_goal; future_goals } let find d e = try EvMap.find e d.undf_evars @@ -1550,9 +1555,12 @@ let meta_with_name evd id = let clear_metas evd = {evd with metas = Metamap.empty} -let meta_merge evd1 evd2 = +let meta_merge ?(with_univs = true) evd1 evd2 = let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in - let universes = union_evar_universe_context evd2.universes evd1.universes in + let universes = + if with_univs then union_evar_universe_context evd2.universes evd1.universes + else evd2.universes + in {evd2 with universes; metas; } type metabinding = metavariable * constr * instance_status diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 5c508419..0b4f1853 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr * instance_status -> evar_map -> eva val clear_metas : evar_map -> evar_map (** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *) -val meta_merge : evar_map -> evar_map -> evar_map +val meta_merge : ?with_univs:bool -> evar_map -> evar_map -> evar_map val undefined_metas : evar_map -> metavariable list val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 95a6ba79..6733b7fc 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* anomaly (Pp.str "Not a rigid reference") let pattern_of_constr env sigma t = - let ctx = ref [] in - let keep = ref Evar.Set.empty in - let remove = ref Evar.Set.empty in let rec pattern_of_constr env t = match kind_of_term t with | Rel n -> PRel n @@ -143,14 +140,9 @@ let pattern_of_constr env sigma t = | App (f,a) -> (match match kind_of_term f with - | Evar (evk,args as ev) -> + | Evar (evk,args) -> (match snd (Evd.evar_source evk sigma) with - Evar_kinds.MatchingVar (true,id) -> - let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in - ctx := (id,None,ty)::!ctx; - keep := Evar.Set.union (evars_of_term ty) !keep; - remove := Evar.Set.add evk !remove; - Some id + Evar_kinds.MatchingVar (true,id) -> Some id | _ -> None) | _ -> None with @@ -162,13 +154,11 @@ let pattern_of_constr env sigma t = | Proj (p, c) -> pattern_of_constr env (Retyping.expand_projection env sigma p c []) | Evar (evk,ctxt as ev) -> - remove := Evar.Set.add evk !remove; (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in - ctx := (id,None,ty)::!ctx; - let () = ignore (pattern_of_constr env ty) in - assert (not b); PMeta (Some id) + let () = ignore (pattern_of_constr env ty) in + assert (not b); PMeta (Some id) | Evar_kinds.GoalEvar -> PEvar (evk,Array.map (pattern_of_constr env) ctxt) | _ -> @@ -189,12 +179,7 @@ let pattern_of_constr env sigma t = Array.to_list (Array.mapi branch_of_constr br)) | Fix f -> PFix f | CoFix f -> PCoFix f in - let p = pattern_of_constr env t in - let remove = Evar.Set.diff !remove !keep in - let sigma = Evar.Set.fold (fun ev acc -> Evd.remove acc ev) remove sigma in - (* side-effect *) - (* Warning: the order of dependencies in ctx is not ensured *) - (sigma,!ctx,p) + pattern_of_constr env t (* To process patterns, we need a translation without typing at all. *) @@ -234,7 +219,7 @@ let instantiate_pattern env sigma lvar c = ctx in let c = substl inst c in - pi3 (pattern_of_constr env sigma c) + pattern_of_constr env sigma c with Not_found (* List.index failed *) -> let vars = List.map_filter (function Name id -> Some id | _ -> None) vars in @@ -259,7 +244,7 @@ let rec subst_pattern subst pat = | PRef ref -> let ref',t = subst_global subst ref in if ref' == ref then pat else - pi3 (pattern_of_constr (Global.env()) Evd.empty t) + pattern_of_constr (Global.env()) Evd.empty t | PVar _ | PEvar _ | PRel _ -> pat diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 9e72280f..5f877814 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* global_reference a pattern; currently, no destructor (Cases, Fix, Cofix) and no existential variable are allowed in [c] *) -val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> - Evd.evar_map * named_context * constr_pattern +val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> constr_pattern (** [pattern_of_glob_constr l c] translates a term [c] with metavariables into a pattern; variables bound in [l] are replaced by the pattern to which they diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 030b4a11..cf5b08c5 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Typeclasses.no_goals_or_obligations evk evi && filter_pending evk) - else (fun evk evi -> Typeclasses.no_goals evk evi && filter_pending evk)) + then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && not (filter_frozen evk)) + else (fun evk evi -> Typeclasses.no_goals evk evi && not (filter_frozen evk))) ~split:true ~fail:fail_evar env !evdref; if Flags.is_program_mode () then (* Try optionally solving the obligations *) evdref := Typeclasses.resolve_typeclasses - ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && filter_pending evk) ~split:true ~fail:false env !evdref + ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && not (filter_frozen evk)) ~split:true ~fail:false env !evdref let apply_inference_hook hook evdref pending = evdref := Evar.Set.fold (fun evk sigma -> @@ -219,9 +223,9 @@ let apply_heuristics env evdref fail_evar = with e when Errors.noncritical e -> let e = Errors.push e in if fail_evar then iraise e -let check_typeclasses_instances_are_solved env current_sigma pending = +let check_typeclasses_instances_are_solved env current_sigma frozen = (* Naive way, call resolution again with failure flag *) - apply_typeclasses env (ref current_sigma) pending true + apply_typeclasses env (ref current_sigma) frozen true let check_extra_evars_are_solved env current_sigma pending = Evar.Set.iter @@ -233,26 +237,28 @@ let check_extra_evars_are_solved env current_sigma pending = | _ -> error_unsolvable_implicit loc env current_sigma evk None) pending -let check_evars_are_solved env current_sigma pending = - check_typeclasses_instances_are_solved env current_sigma pending; +let check_evars_are_solved env current_sigma frozen pending = + check_typeclasses_instances_are_solved env current_sigma frozen; check_problems_are_solved env current_sigma; check_extra_evars_are_solved env current_sigma pending (* Try typeclasses, hooks, unification heuristics ... *) let solve_remaining_evars flags env current_sigma pending = + let frozen = frozen_holes pending in let pending = pending_holes pending in let evdref = ref current_sigma in - if flags.use_typeclasses then apply_typeclasses env evdref pending false; + if flags.use_typeclasses then apply_typeclasses env evdref frozen false; if Option.has_some flags.use_hook then apply_inference_hook (Option.get flags.use_hook env) evdref pending; if flags.use_unif_heuristics then apply_heuristics env evdref false; - if flags.fail_evar then check_evars_are_solved env !evdref pending; + if flags.fail_evar then check_evars_are_solved env !evdref frozen pending; !evdref let check_evars_are_solved env current_sigma pending = + let frozen = frozen_holes pending in let pending = pending_holes pending in - check_evars_are_solved env current_sigma pending + check_evars_are_solved env current_sigma frozen pending let process_inference_flags flags env initial_sigma (sigma,c) = let sigma = solve_remaining_evars flags env sigma (initial_sigma, sigma) in @@ -394,18 +400,22 @@ let pretype_global loc rigid env evd gr us = match us with | None -> evd, None | Some l -> - let _, ctx = Universes.unsafe_constr_of_global gr in - let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in - let len = Array.length arr in - if len != List.length l then - user_err_loc (loc, "pretype", - str "Universe instance should have length " ++ int len) - else - let evd, l' = List.fold_left (fun (evd, univs) l -> + let _, ctx = Universes.unsafe_constr_of_global gr in + let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in + let len = Array.length arr in + if len != List.length l then + user_err_loc (loc, "pretype", + str "Universe instance should have length " ++ int len) + else + let evd, l' = List.fold_left (fun (evd, univs) l -> let evd, l = interp_universe_level_name evd l in (evd, l :: univs)) (evd, []) l - in - evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) + in + if List.exists (fun l -> Univ.Level.is_prop l) l' then + user_err_loc (loc, "pretype", + str "Universe instances cannot contain Prop, polymorphic" ++ + str " universe instances must be greater or equal to Set."); + evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) in Evd.fresh_global ~rigid ?names:instance env evd gr @@ -440,13 +450,15 @@ let pretype_sort evdref = function let new_type_evar env evdref loc = let e, s = - evd_comb0 (fun evd -> Evarutil.new_type_evar env evd univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref + evd_comb0 (fun evd -> Evarutil.new_type_evar env evd + univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref in e let get_projection env cst = let cb = lookup_constant cst env in match cb.Declarations.const_proj with - | Some {Declarations.proj_ind = mind; proj_npars = n; proj_arg = m; proj_type = ty} -> + | Some {Declarations.proj_ind = mind; proj_npars = n; + proj_arg = m; proj_type = ty} -> (cst,mind,n,m,ty) | None -> raise Not_found @@ -739,7 +751,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ pretype (mk_tycon tj.utj_val) env evdref lvar c | _ -> pretype empty_tycon env evdref lvar c1 in - let t = j.uj_type in + let t = evd_comb1 (Evarsolve.refresh_universes + ~onlyalg:true ~status:Evd.univ_flexible (Some false) env) + evdref j.uj_type in (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 5f0e19cf..ac899a78 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Reduction.CONV | Reduction.CONV -> Reduction.CONV +let report_anomaly _ = + let e = UserError ("", Pp.str "Conversion test raised an anomaly") in + let e = Errors.push e in + iraise e + let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in let _ = f ~evars reds env (Evd.universes sigma) x y in true with Reduction.NotConvertible -> false - | e when is_anomaly e -> error "Conversion test raised an anomaly" + | e when is_anomaly e -> report_anomaly e let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma @@ -1275,7 +1280,7 @@ let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true with Reduction.NotConvertible -> false | Univ.UniverseInconsistency _ -> false - | e when is_anomaly e -> error "Conversion test raised an anomaly" + | e when is_anomaly e -> report_anomaly e let sigma_compare_sorts env pb s0 s1 sigma = match pb with @@ -1316,7 +1321,7 @@ let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) with | Reduction.NotConvertible -> sigma, false | Univ.UniverseInconsistency _ when catch_incon -> sigma, false - | e when is_anomaly e -> error "Conversion test raised an anomaly" + | e when is_anomaly e -> report_anomaly e let infer_conv = infer_conv_gen (fun pb ~l2r sigma -> Reduction.generic_conv pb ~l2r (safe_evar_value sigma)) @@ -1646,7 +1651,7 @@ let betazetaevar_applist sigma n c l = if Int.equal n 0 then applist (substl env t, stack) else match kind_of_term t, stack with | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl - | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack + | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack | Evar ev, _ -> (match safe_evar_value sigma ev with | Some body -> stacklam n env body stack diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index d5a84484..aea0a9ae 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* aux (a::subst) sign' args' | (_,Some c,_)::sign', args' -> - aux (substl (List.rev subst) c :: subst) sign' args' + aux (substl subst c :: subst) sign' args' | [], [] -> List.rev subst | _ -> anomaly (Pp.str "Instance and signature do not match") in aux [] (List.rev sign) l diff --git a/pretyping/termops.mli b/pretyping/termops.mli index 4581e231..ca98f8d7 100644 --- a/pretyping/termops.mli +++ b/pretyping/termops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* keyed_unification:=a); } +let is_keyed_unification () = !keyed_unification + let debug_unification = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; @@ -904,8 +906,18 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb match subst_defined_metas_evars subst cN with | None -> (* some undefined Metas in cN *) None | Some n1 -> - (* No subterm restriction there, too much incompatibilities *) - let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in + (* No subterm restriction there, too much incompatibilities *) + let sigma = + if opt.with_types then + try (* Ensure we call conversion on terms of the same type *) + let tyM = get_type_of curenv ~lax:true sigma m1 in + let tyN = get_type_of curenv ~lax:true sigma n1 in + check_compatibility curenv CUMUL flags substn tyM tyN + with RetypeError _ -> + (* Renounce, maybe metas/evars prevents typing *) sigma + else sigma + in + let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in if b then Some (sigma, metasubst, evarsubst) else if is_ground_term sigma m1 && is_ground_term sigma n1 then @@ -1637,8 +1649,13 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let cl = strip_outer_cast cl in (try if closed0 cl && not (isEvar cl) && keyed_unify env evd kop cl then - (try w_typed_unify env evd CONV flags op cl,cl - with ex when Pretype_errors.unsatisfiable_exception ex -> + (try + if !keyed_unification then + let f1, l1 = decompose_app_vect op in + let f2, l2 = decompose_app_vect cl in + w_typed_unify_array env evd flags f1 l1 f2 l2,cl + else w_typed_unify env evd CONV flags op cl,cl + with ex when Pretype_errors.unsatisfiable_exception ex -> bestexn := Some ex; error "Unsat") else error "Bound 1" with ex when precatchable_exception ex -> diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 119b1a75..d5d5caf9 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unify_flags val elim_flags : unit -> unify_flags val elim_no_delta_flags : unit -> unify_flags +val is_keyed_unification : unit -> bool + (** The "unique" unification fonction *) val w_unify : env -> evar_map -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_map diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index c4c85a62..7d86fad9 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* return ( hv 0 ( - keyword "let" ++ spc () ++ - hov 0 (str "(" ++ + hov 2 (keyword "let" ++ spc () ++ + hov 1 (str "(" ++ prlist_with_sep sep_v pr_lname nal ++ str ")" ++ - pr_simple_return_type (pr mt) na po ++ str " :=" ++ - pr spc ltop c ++ spc () - ++ keyword "in") ++ + pr_simple_return_type (pr mt) na po ++ str " :=") ++ + pr spc ltop c + ++ keyword " in") ++ pr spc ltop b), lletin ) diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 6e8d3b04..0241633c 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mt () - | Some (clear,id,ipat) -> - pr_in (spc () ++ pr_clear_flag clear pr_id id) ++ pr_as_ipat prc ipat + | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat let pr_clauses default_is_concl pr_id = function | { onhyps=Some []; concl_occs=occs } diff --git a/printing/pptactic.mli b/printing/pptactic.mli index fa91aefc..31346561 100644 --- a/printing/pptactic.mli +++ b/printing/pptactic.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* clausenv * Univ.universe_level_subst val connect_clenv : Goal.goal sigma -> clausenv -> clausenv val clenv_fchain : - ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv + ?with_univs:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv (** {6 Unification with clenvs } *) diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index aaa49f11..8e922599 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* match init_tac with @@ -54,6 +55,9 @@ let set_used_variables l = let get_used_variables () = Proof_global.get_used_variables () +let get_universe_binders () = + Proof_global.get_universe_binders () + exception NoSuchGoal let _ = Errors.register_handler begin function | NoSuchGoal -> Errors.error "No such goal." @@ -139,7 +143,7 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let status = by tac in let _,(const,univs,_) = cook_proof () in delete_current_proof (); - const, status, univs + const, status, fst univs with reraise -> let reraise = Errors.push reraise in delete_current_proof (); diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index fc521ea4..cd899201 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit type lemma_possible_guards = Proof_global.lemma_possible_guards +type universe_binders = Id.t Loc.located list + val start_proof : - Id.t -> goal_kind -> Evd.evar_map -> named_context_val -> constr -> + Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> named_context_val -> constr -> ?init_tac:unit Proofview.tactic -> Proof_global.proof_terminator -> unit @@ -121,6 +123,9 @@ val set_used_variables : Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option +(** {6 Universe binders } *) +val get_universe_binders : unit -> universe_binders option + (** {6 ... } *) (** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th subgoal of the current focused proof or raises a [UserError] if no diff --git a/proofs/proof.ml b/proofs/proof.ml index c7aa5bad..0489305a 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* fst (Evd.universe_context ~names (Evd.from_ctx universes))) + universe_binders + in + { id = pid; entries = entries; persistence = strength; + universes = (universes, binders) }, fun pr_ending -> Ephemeron.get terminator pr_ending type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context @@ -612,7 +623,10 @@ module Bullet = struct (!current_behavior).name end; optwrite = begin fun n -> - current_behavior := Hashtbl.find behaviors n + current_behavior := + try Hashtbl.find behaviors n + with Not_found -> + Errors.error ("Unknown bullet behavior: \"" ^ n ^ "\".") end } diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index a2254508..7fbd183e 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit (i.e. an proof ending command) and registers the appropriate values. *) type lemma_possible_guards = int list list -type proof_universes = Evd.evar_universe_context +type proof_universes = Evd.evar_universe_context * Universes.universe_binders option +type universe_binders = Names.Id.t Loc.located list type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: proof_universes; - (* constraints : Univ.constraints; *) - (** guards : lemma_possible_guards; *) } type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * proof_universes + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * + proof_universes | Proved of Vernacexpr.opacity_flag * (Vernacexpr.lident * Decl_kinds.theorem_kind option) option * proof_object @@ -80,14 +80,15 @@ type closed_proof = proof_object * proof_terminator closing commands and the xml plugin); [terminator] is used at the end of the proof to close the proof. *) val start_proof : - Evd.evar_map -> Names.Id.t -> Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> + Evd.evar_map -> Names.Id.t -> ?pl:universe_binders -> + Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> proof_terminator -> unit (** Like [start_proof] except that there may be dependencies between initial goals. *) val start_dependent_proof : - Names.Id.t -> Decl_kinds.goal_kind -> Proofview.telescope -> - proof_terminator -> unit + Names.Id.t -> ?pl:universe_binders -> Decl_kinds.goal_kind -> + Proofview.telescope -> proof_terminator -> unit (** Update the proofs global environment after a side-effecting command (e.g. a sublemma definition) has been run inside it. Assumes @@ -140,6 +141,8 @@ val set_used_variables : Names.Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option +val get_universe_binders : unit -> universe_binders option + (**********************************************************) (* *) (* Proof modes *) diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml index 47b2b255..dd2c7b25 100644 --- a/proofs/proof_type.ml +++ b/proofs/proof_type.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* i+1) solution 0 in let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in @@ -45,7 +45,7 @@ let compact el { comb; solution } = let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); - new_el, { comb; solution = new_solution } + new_el, { pv with solution = new_solution; } (** {6 Starting and querying a proof view} *) @@ -62,13 +62,13 @@ let dependent_init = let src = (Loc.ghost,Evar_kinds.GoalEvar) in (* Main routine *) let rec aux = function - | TNil sigma -> [], { solution = sigma; comb = []; } + | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } | TCons (env, sigma, typ, t) -> let (sigma, econstr ) = Evarutil.new_evar env sigma ~src ~store typ in let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in let (gl, _) = Term.destEvar econstr in let entry = (econstr, typ) :: ret in - entry, { solution = sol; comb = gl :: comb; } + entry, { solution = sol; comb = gl :: comb; shelf = [] } in fun t -> let entry, v = aux t in @@ -232,6 +232,9 @@ let apply env t sp = match ans with | Nil (e, info) -> iraise (TacticFailure e, info) | Cons ((r, (state, _), status, info), _) -> + let (status, gaveup) = status in + let status = (status, state.shelf, gaveup) in + let state = { state with shelf = [] } in r, state, status, Trace.to_tree info @@ -578,7 +581,7 @@ let shelve = Comb.get >>= fun initial -> Comb.set [] >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> - Shelf.put initial + Shelf.modify (fun gls -> gls @ initial) (** [contained_in_info e evi] checks whether the evar [e] appears in @@ -617,7 +620,7 @@ let shelve_unifiable = let (u,n) = partition_unifiable initial.solution initial.comb in Comb.set n >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> - Shelf.put u + Shelf.modify (fun gls -> gls @ u) (** [guard_no_unifiable] fails with error [UnresolvedBindings] if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) @@ -639,6 +642,20 @@ let unshelve l p = let l = undefined p.solution l in { p with comb = p.comb@l } +let with_shelf tac = + let open Proof in + Pv.get >>= fun pv -> + let { shelf; solution } = pv in + Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> + tac >>= fun ans -> + Pv.get >>= fun npv -> + let { shelf = gls; solution = sigma } = npv in + let gls' = Evd.future_goals sigma in + let fgoals = Evd.future_goals solution in + let pgoal = Evd.principal_future_goal solution in + let sigma = Evd.restore_future_goals sigma fgoals pgoal in + Pv.set { npv with shelf; solution = sigma } >> + tclUNIT (CList.rev_append gls' gls, ans) (** [goodmod p m] computes the representative of [p] modulo [m] in the interval [[0,m-1]].*) @@ -867,7 +884,7 @@ module Unsafe = struct let tclSETGOALS = Comb.set let tclEVARSADVANCE evd = - Pv.modify (fun ps -> { solution = evd; comb = undefined evd ps.comb }) + Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) let tclEVARUNIVCONTEXT ctx = Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) @@ -1010,10 +1027,34 @@ end module Refine = struct + let extract_prefix env info = + let ctx1 = List.rev (Environ.named_context env) in + let ctx2 = List.rev (Evd.evar_context info) in + let rec share l1 l2 accu = match l1, l2 with + | d1 :: l1, d2 :: l2 -> + if d1 == d2 then share l1 l2 (d1 :: accu) + else (accu, d2 :: l2) + | _ -> (accu, l2) + in + share ctx1 ctx2 [] + let typecheck_evar ev env sigma = let info = Evd.find sigma ev in + (** Typecheck the hypotheses. *) + let type_hyp (sigma, env) (na, body, t as decl) = + let evdref = ref sigma in + let _ = Typing.sort_of env evdref t in + let () = match body with + | None -> () + | Some body -> Typing.check env evdref body t + in + (!evdref, Environ.push_named decl env) + in + let (common, changed) = extract_prefix env info in + let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in + let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in + (** Typecheck the conclusion *) let evdref = ref sigma in - let env = Environ.reset_with_named_context (Evd.evar_hyps info) env in let _ = Typing.sort_of env evdref (Evd.evar_concl info) in !evdref @@ -1061,7 +1102,7 @@ struct let sigma = CList.fold_left Unsafe.mark_as_goal_evm sigma comb in let open Proof in InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >> - Pv.set { solution = sigma; comb; } + Pv.modify (fun ps -> { ps with solution = sigma; comb; }) end (** Useful definitions *) @@ -1140,7 +1181,7 @@ module V82 = struct let sgs = CList.flatten goalss in let sgs = undefined evd sgs in InfoL.leaf (Info.Tactic (fun () -> Pp.str"")) >> - Pv.set { solution = evd; comb = sgs; } + Pv.set { ps with solution = evd; comb = sgs; } with e when catchable_exception e -> let (e, info) = Errors.push e in tclZERO ~info e @@ -1152,7 +1193,7 @@ module V82 = struct Pv.modify begin fun ps -> let map g s = GoalV82.nf_evar s g in let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in - { solution = evd; comb = goals; } + { ps with solution = evd; comb = goals; } end let has_unresolved_evar pv = @@ -1197,7 +1238,7 @@ module V82 = struct let of_tactic t gls = try - let init = { solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in + let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in let (_,final,_,_) = apply (GoalV82.env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = final.comb } with Logic_monad.TacticFailure e as src -> diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 927df33a..2157459f 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* proofview -> proofview +(** [with_shelf tac] executes [tac] and returns its result together with the set + of goals shelved by [tac]. The current shelf is unchanged. *) +val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic + (** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] is negative, then it puts the [n] last goals first.*) val cycle : int -> unit tactic diff --git a/proofs/proofview_monad.ml b/proofs/proofview_monad.ml index 6e68cd2e..e9bc7761 100644 --- a/proofs/proofview_monad.ml +++ b/proofs/proofview_monad.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* shelf) Pv.get + let set c = Pv.modify (fun pv -> { pv with shelf = c }) + let modify f = Pv.modify (fun pv -> { pv with shelf = f pv.shelf }) end module Giveup : Writer with type t = Evar.t list = struct (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) type t = Evar.t list - let put gs = Logical.put (true,[],gs) + let put gs = Logical.put (true, gs) end (** Lens and utilies pertaining to the info trace *) diff --git a/proofs/proofview_monad.mli b/proofs/proofview_monad.mli index d2a2e55f..7a6ea10f 100644 --- a/proofs/proofview_monad.mli +++ b/proofs/proofview_monad.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* w -> w @@ -123,7 +127,7 @@ module Status : Writer with type t := bool (** Lens to the list of goals which have been shelved during the execution of the tactic. *) -module Shelf : Writer with type t = Evar.t list +module Shelf : State with type t = Evar.t list (** Lens to the list of goals which were given up during the execution of the tactic. *) diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index be92f2b0..ea21917a 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* set_slave_opt tl - | ("-async-proofs" |"-toploop" |"-vi2vo" |"-compile" - |"-load-vernac-source" |"-compile-verbose" + | ("-async-proofs" |"-toploop" |"-vi2vo" + |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv" + |"-compile" |"-compile-verbose" |"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl -> set_slave_opt tl | x::tl -> x :: set_slave_opt tl in diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli index a3fe4b8c..f140f8ed 100644 --- a/stm/asyncTaskQueue.mli +++ b/stm/asyncTaskQueue.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* exn) hook l r with e when Errors.noncritical e -> let e = Errors.push e in @@ -219,11 +220,11 @@ let compute_proof_name locality = function locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) then user_err_loc (loc,"",pr_id id ++ str " already exists."); - id + id, pl | None -> - next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()) + next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()), None -let save_remaining_recthms (locality,p,kind) norm ctx body opaq i (id,(t_i,(_,imps))) = +let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,(_,imps))) = let t_i = norm t_i in match body with | None -> @@ -276,28 +277,28 @@ let save_hook = ref ignore let set_save_hook f = save_hook := f let save_named ?export_seff proof = - let id,const,cstrs,do_guard,persistence,hook = proof in - save ?export_seff id const cstrs do_guard persistence hook + let id,const,(cstrs,pl),do_guard,persistence,hook = proof in + save ?export_seff id const cstrs pl do_guard persistence hook let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then error "This command can only be used for unnamed theorem." - let save_anonymous ?export_seff proof save_ident = - let id,const,cstrs,do_guard,persistence,hook = proof in + let id,const,(cstrs,pl),do_guard,persistence,hook = proof in check_anonymity id save_ident; - save ?export_seff save_ident const cstrs do_guard persistence hook + save ?export_seff save_ident const cstrs pl do_guard persistence hook let save_anonymous_with_strength ?export_seff proof kind save_ident = - let id,const,cstrs,do_guard,_,hook = proof in + let id,const,(cstrs,pl),do_guard,_,hook = proof in check_anonymity id save_ident; (* we consider that non opaque behaves as local for discharge *) - save ?export_seff save_ident const cstrs do_guard (Global, const.const_entry_polymorphic, Proof kind) hook + save ?export_seff save_ident const cstrs pl do_guard + (Global, const.const_entry_polymorphic, Proof kind) hook (* Admitted *) -let admit (id,k,e) hook () = +let admit (id,k,e) pl hook () = let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in let () = match k with | Global, _, _ -> () @@ -306,6 +307,7 @@ let admit (id,k,e) hook () = str "declared as an axiom.") in let () = assumption_message id in + Option.iter (Universes.register_universe_binders (ConstRef kn)) pl; call_hook (fun exn -> exn) hook Global (ConstRef kn) (* Starting a goal *) @@ -315,11 +317,10 @@ let set_start_hook = (:=) start_hook let get_proof proof do_guard hook opacity = - let (id,(const,cstrs,persistence)) = + let (id,(const,univs,persistence)) = Pfedit.cook_this_proof proof in - (** FIXME *) - id,{const with const_entry_opaque = opacity},cstrs,do_guard,persistence,hook + id,{const with const_entry_opaque = opacity},univs,do_guard,persistence,hook let check_exist = List.iter (fun (loc,id) -> @@ -329,16 +330,16 @@ let check_exist = let universe_proof_terminator compute_guard hook = let open Proof_global in function - | Admitted (id,k,pe,ctx) -> - admit (id,k,pe) (hook (Some ctx)) (); + | Admitted (id,k,pe,(ctx,pl)) -> + admit (id,k,pe) pl (hook (Some ctx)) (); Pp.feedback Feedback.AddedAxiom | Proved (opaque,idopt,proof) -> let is_opaque, export_seff, exports = match opaque with | Vernacexpr.Transparent -> false, true, [] | Vernacexpr.Opaque None -> true, false, [] | Vernacexpr.Opaque (Some l) -> true, true, l in - let proof = get_proof proof compute_guard - (hook (Some proof.Proof_global.universes)) is_opaque in + let proof = get_proof proof compute_guard + (hook (Some (fst proof.Proof_global.universes))) is_opaque in begin match idopt with | None -> save_named ~export_seff proof | Some ((_,id),None) -> save_anonymous ~export_seff proof id @@ -350,7 +351,7 @@ let universe_proof_terminator compute_guard hook = let standard_proof_terminator compute_guard hook = universe_proof_terminator compute_guard (fun _ -> hook) -let start_proof id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = +let start_proof id ?pl kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = let terminator = standard_proof_terminator compute_guard hook in let sign = match sign with @@ -358,9 +359,9 @@ let start_proof id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = | None -> initialize_named_context_for_proof () in !start_hook c; - Pfedit.start_proof id kind sigma sign c ?init_tac terminator + Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator -let start_proof_univs id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = +let start_proof_univs id ?pl kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = let terminator = universe_proof_terminator compute_guard hook in let sign = match sign with @@ -368,11 +369,11 @@ let start_proof_univs id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = | None -> initialize_named_context_for_proof () in !start_hook c; - Pfedit.start_proof id kind sigma sign c ?init_tac terminator + Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun (id,(t,_)) -> (id,t)) thms with + match List.map (fun ((id,_),(t,_)) -> (id,t)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -380,7 +381,7 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with + in match List.map2 (fun ((id,_),(t,_)) n -> (id,n,t)) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false @@ -409,7 +410,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in match thms with | [] -> anomaly (Pp.str "No proof to start") - | (id,(t,(_,imps)))::other_thms -> + | ((id,pl),(t,(_,imps)))::other_thms -> let hook ctx strength ref = let ctx = match ctx with | None -> Evd.empty_evar_universe_context @@ -428,7 +429,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook (fun exn -> exn) hook strength ref) thms_data in - start_proof_univs id kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard + start_proof_univs id ?pl kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard let start_proof_com kind thms hook = let env0 = Global.env () in @@ -472,14 +473,13 @@ let save_proof ?proof = function if const_entry_type = None then error "Admitted requires an explicit statement"; let typ = Option.get const_entry_type in - let ctx = Evd.evar_context_universe_context universes in + let ctx = Evd.evar_context_universe_context (fst universes) in Admitted(id, k, (const_entry_secctx, pi2 k, (typ, ctx), None), universes) | None -> let id, k, typ = Pfedit.current_proof_statement () in (* This will warn if the proof is complete *) let pproofs, universes = Proof_global.return_proof ~allow_partial:true () in - let ctx = Evd.evar_context_universe_context universes in let sec_vars = match Pfedit.get_used_variables(), pproofs with | Some _ as x, _ -> x @@ -489,7 +489,10 @@ let save_proof ?proof = function let ids_def = Environ.global_vars_set env pproof in Some (Environ.keep_hyps env (Idset.union ids_typ ids_def)) | _ -> None in - Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None),universes) + let names = Pfedit.get_universe_binders () in + let binders, ctx = Evd.universe_context ?names (Evd.from_ctx universes) in + Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None), + (universes, Some binders)) in Proof_global.get_terminator() pe | Vernacexpr.Proved (is_opaque,idopt) -> diff --git a/stm/lemmas.mli b/stm/lemmas.mli index 6556aa22..16e54e31 100644 --- a/stm/lemmas.mli +++ b/stm/lemmas.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Globnames.global_reference -> 'a) -> 'a declaration_hook @@ -24,20 +23,24 @@ val call_hook : (** A hook start_proof calls on the type of the definition being started *) val set_start_hook : (types -> unit) -> unit -val start_proof : Id.t -> goal_kind -> Evd.evar_map -> ?sign:Environ.named_context_val -> types -> +val start_proof : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> + ?sign:Environ.named_context_val -> types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> unit declaration_hook -> unit -val start_proof_univs : Id.t -> goal_kind -> Evd.evar_map -> ?sign:Environ.named_context_val -> types -> +val start_proof_univs : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> + ?sign:Environ.named_context_val -> types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> - (Proof_global.proof_universes option -> unit declaration_hook) -> unit + (Evd.evar_universe_context option -> unit declaration_hook) -> unit val start_proof_com : goal_kind -> Vernacexpr.proof_expr list -> unit declaration_hook -> unit val start_proof_with_initialization : - goal_kind -> Evd.evar_map -> (bool * lemma_possible_guards * unit Proofview.tactic list option) option -> - (Id.t * (types * (Name.t list * Impargs.manual_explicitation list))) list + goal_kind -> Evd.evar_map -> + (bool * lemma_possible_guards * unit Proofview.tactic list option) option -> + ((Id.t * universe_binders option) * + (types * (Name.t list * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit val standard_proof_terminator : diff --git a/stm/proofworkertop.ml b/stm/proofworkertop.ml index 0e40c345..23538a46 100644 --- a/stm/proofworkertop.ml +++ b/stm/proofworkertop.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ()) () +let tactic_being_run, tactic_being_run_hook = Hook.make + ~default:(fun _ -> ()) () + include Hook (* enables: Hooks.(call foo args) *) @@ -1471,6 +1474,18 @@ end = struct (* {{{ *) try Reach.known_state ~cache:`No id; let t, uc = Future.purify (fun () -> + let _,_,_,_,sigma0 = Proof.proof (Proof_global.give_me_the_proof ()) in + let g = Evd.find sigma0 r_goal in + if not ( + Evarutil.is_ground_term sigma0 Evd.(evar_concl g) && + List.for_all (fun (_,bo,ty) -> + Evarutil.is_ground_term sigma0 ty && + Option.cata (Evarutil.is_ground_term sigma0) true bo) + Evd.(evar_context g)) + then + Errors.errorlabstrm "Stm" (strbrk("the par: goal selector supports ground "^ + "goals only")) + else begin vernac_interp r_state_fb r_ast; let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with @@ -1479,9 +1494,10 @@ end = struct (* {{{ *) let t = Evarutil.nf_evar sigma t in if Evarutil.is_ground_term sigma t then t, Evd.evar_universe_context sigma - else Errors.errorlabstrm "Stm" (str"The solution is not ground")) - () in - RespBuiltSubProof (t,uc) + else Errors.errorlabstrm "Stm" (str"The solution is not ground") + end) () + in + RespBuiltSubProof (t,uc) with e when Errors.noncritical e -> RespError (Errors.print e) let name_of_task { t_name } = t_name @@ -1787,16 +1803,21 @@ let known_state ?(redefine_qed=false) ~cache id = ), cache, true | `Cmd { cast = x; cqueue = `TacQueue cancel } -> (fun () -> reach ~cache:`Shallow view.next; + Hooks.(call tactic_being_run true); Partac.vernac_interp - cancel !Flags.async_proofs_n_tacworkers view.next id x + cancel !Flags.async_proofs_n_tacworkers view.next id x; + Hooks.(call tactic_being_run false) ), cache, true | `Cmd { cast = x; cqueue = `QueryQueue cancel } when Flags.async_proofs_is_master () -> (fun () -> reach view.next; Query.vernac_interp cancel view.next id x ), cache, false - | `Cmd { cast = x; ceff = eff } -> (fun () -> - reach view.next; vernac_interp id x; + | `Cmd { cast = x; ceff = eff; ctac } -> (fun () -> + reach view.next; + if ctac then Hooks.(call tactic_being_run true); + vernac_interp id x; + if ctac then Hooks.(call tactic_being_run false); if eff then update_global_env ()), cache, true | `Fork ((x,_,_,_), None) -> (fun () -> reach view.next; vernac_interp id x; @@ -2577,4 +2598,5 @@ let interp_hook = Hooks.interp_hook let with_fail_hook = Hooks.with_fail_hook let unreachable_state_hook = Hooks.unreachable_state_hook let get_fix_exn () = !State.fix_exn_ref +let tactic_being_run_hook = Hooks.tactic_being_run_hook (* vim:set foldmethod=marker: *) diff --git a/stm/stm.mli b/stm/stm.mli index 0c05c93d..ad89eb71 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -107,6 +107,9 @@ val execution_error_hook : (Stateid.t -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t val unreachable_state_hook : (Stateid.t -> Exninfo.iexn -> unit) Hook.t (* ready means that master has it at hand *) val state_ready_hook : (Stateid.t -> unit) Hook.t +(* called with true before and with false after a tactic explicitly + * in the document is run *) +val tactic_being_run_hook : (bool -> unit) Hook.t (* Messages from the workers to the master *) val forward_feedback_hook : (Feedback.feedback -> unit) Hook.t diff --git a/stm/tQueue.ml b/stm/tQueue.ml index 2dad962b..ee121c46 100644 --- a/stm/tQueue.ml +++ b/stm/tQueue.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [] | "-schedule-vio-checking" :: rest -> filter_argv true rest - | s :: rest when s.[0] = '-' && b -> filter_argv false (s :: rest) + | s :: rest when String.length s > 0 && s.[0] = '-' && b -> filter_argv false (s :: rest) | _ :: rest when b -> filter_argv b rest | s :: rest -> s :: filter_argv b rest in let pack = function diff --git a/stm/vio_checking.mli b/stm/vio_checking.mli index e2da5026..c0b6d9e6 100644 --- a/stm/vio_checking.mli +++ b/stm/vio_checking.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ Proofview.V82.tactic (Tactics.vm_cast_no_check c) ] END +TACTIC EXTEND native_cast_no_check + [ "native_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.native_cast_no_check c) ] +END + TACTIC EXTEND casetype [ "casetype" constr(c) ] -> [ Tactics.case_type c ] END diff --git a/tactics/dnet.ml b/tactics/dnet.ml index 93334db7..c501e306 100644 --- a/tactics/dnet.ml +++ b/tactics/dnet.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + let b = match Hints.repr_hint t with + | Unfold_nth _ -> 1 + | _ -> b + in (b, let tac = function | Res_pf (term,cl) -> unify_resolve poly st (term,cl) @@ -245,8 +249,8 @@ module SearchProblem = struct let d = s'.depth - s.depth in let d' = Int.compare s.priority s'.priority in let nbgoals s = List.length (sig_it s.tacres) in - if not (Int.equal d' 0) then d' - else if not (Int.equal d 0) then d + if not (Int.equal d 0) then d + else if not (Int.equal d' 0) then d' else Int.compare (nbgoals s) (nbgoals s') let branching s = diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 7073e8a2..1bb15d6c 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - (* May fail if equality is not defined *) - build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Safe_typing.empty_private_constants) + (* May fail if equality is not defined *) + build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, + Safe_typing.empty_private_constants) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index 3fe33073..aa8a6d4b 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_conv_closed_unif_flags c in + let flags = if Unification.is_keyed_unification () + then rewrite_keyed_unif_flags else rewrite_conv_closed_unif_flags in + let flags = make_flags frzevars (Proofview.Goal.sigma gl) flags c in general_elim_clause with_evars flags cls c e end @@ -914,7 +952,7 @@ let apply_on_clause (f,t) clause = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in - clenv_fchain argmv f_clause clause + clenv_fchain ~with_univs:false argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort = let e = next_ident_away eq_baseid (ids_of_context env) in diff --git a/tactics/equality.mli b/tactics/equality.mli index 840ede7d..f84dafb3 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in @@ -356,11 +357,19 @@ let refine_tac {Glob_term.closure=closure;term=term} = Pretyping.ltac_idents = closure.Glob_term.idents; } in let update evd = Pretyping.understand_ltac flags env evd lvar tycon term in - Tactics.New.refine ~unsafe:false update + let refine = Proofview.Refine.refine ~unsafe:false update in + if simple then refine + else refine <*> + Tactics.New.reduce_after_refine <*> + Proofview.shelve_unifiable end TACTIC EXTEND refine - [ "refine" uconstr(c) ] -> [ refine_tac c ] +| [ "refine" uconstr(c) ] -> [ refine_tac false c ] +END + +TACTIC EXTEND simple_refine +| [ "simple" "refine" uconstr(c) ] -> [ refine_tac true c ] END (**********************************************************************) @@ -864,6 +873,16 @@ TACTIC EXTEND shelve_unifiable [ Proofview.shelve_unifiable ] END +(* Unshelves the goal shelved by the tactic. *) +TACTIC EXTEND unshelve +| [ "unshelve" tactic1(t) ] -> + [ + Proofview.with_shelf (Tacinterp.eval_tactic t) >>= fun (gls, ()) -> + Proofview.Unsafe.tclGETGOALS >>= fun ogls -> + Proofview.Unsafe.tclSETGOALS (gls @ ogls) + ] +END + (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve [ "Unshelve" ] diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli index 72c2679c..e0e9f377 100644 --- a/tactics/extratactics.mli +++ b/tactics/extratactics.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* failwith "make_apply_entry" in @@ -794,7 +794,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; poly = poly; - pat = Some (pi3 (Patternops.pattern_of_constr env ce.evd (clenv_type ce))); + pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); name = name; code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) diff --git a/tactics/hints.mli b/tactics/hints.mli index 3a0521f6..08ea71bb 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Id.equal n id) ctx in let nc = match before with | [] -> assert false - | (id, b, _) :: rem -> insert_dependent env (id, b, newt) [] after @ rem + | (id, b, _) :: rem -> insert_dependent env (id, None, newt) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Proofview.Refine.refine ~unsafe:false begin fun sigma -> @@ -1521,12 +1521,13 @@ let assert_replacing id newt tac = let newfail n s = Proofview.tclZERO (Refiner.FailError (n, lazy s)) -let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = +let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") - | Some None -> Proofview.tclUNIT () + | Some None -> if progress then newfail 0 (str"Failed to progress") + else Proofview.tclUNIT () | Some (Some res) -> let (undef, prf, newt) = res in let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in @@ -1593,21 +1594,25 @@ let tactic_init_setoid () = try init_setoid (); tclIDTAC with e when Errors.noncritical e -> tclFAIL 0 (str"Setoid library not loaded") -(** Setoid rewriting when called with "rewrite_strat" *) -let cl_rewrite_clause_strat strat clause = +let cl_rewrite_clause_strat progress strat clause = tclTHEN (tactic_init_setoid ()) - (fun gl -> - try Proofview.V82.of_tactic (cl_rewrite_clause_newtac strat clause) gl - with RewriteFailure e -> - errorlabstrm "" (str"setoid rewrite failed: " ++ e) - | Refiner.FailError (n, pp) -> - tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl) + ((if progress then tclWEAK_PROGRESS else fun x -> x) + (fun gl -> + try Proofview.V82.of_tactic (cl_rewrite_clause_newtac ~progress strat clause) gl + with RewriteFailure e -> + errorlabstrm "" (str"setoid rewrite failed: " ++ e) + | Refiner.FailError (n, pp) -> + tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl)) (** Setoid rewriting when called with "setoid_rewrite" *) let cl_rewrite_clause l left2right occs clause gl = let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in - cl_rewrite_clause_strat strat clause gl + cl_rewrite_clause_strat true strat clause gl +(** Setoid rewriting when called with "rewrite_strat" *) +let cl_rewrite_clause_strat strat clause = + cl_rewrite_clause_strat false strat clause + let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> let c sigma = let (sigma, c) = Pretyping.understand_tcc env sigma c in @@ -2013,7 +2018,8 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = tclWEAK_PROGRESS (tclTHEN (Refiner.tclEVARS evd) - (Proofview.V82.of_tactic (cl_rewrite_clause_newtac ~abs:(Some abs) ~origsigma strat cl))) gl + (Proofview.V82.of_tactic + (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) gl with RewriteFailure e -> tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl @@ -2077,8 +2083,10 @@ let poly_proof getp gett env evm car rel = let setoid_reflexivity = setoid_proof "reflexive" (fun env evm car rel -> - tac_open (poly_proof PropGlobal.get_reflexive_proof TypeGlobal.get_reflexive_proof - env evm car rel) (fun c -> Proofview.V82.of_tactic (apply c))) + tac_open (poly_proof PropGlobal.get_reflexive_proof + TypeGlobal.get_reflexive_proof + env evm car rel) + (fun c -> tclCOMPLETE (Proofview.V82.of_tactic (apply c)))) (reflexivity_red true) let setoid_symmetry = diff --git a/tactics/rewrite.mli b/tactics/rewrite.mli index 40a18ac4..b4d47d62 100644 --- a/tactics/rewrite.mli +++ b/tactics/rewrite.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r -let intern_in_hyp_as ist lf (clear,id,ipat) = - (clear,intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) +let intern_in_hyp_as ist lf (id,ipat) = + (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) let intern_hyp_list ist = List.map (intern_hyp ist) diff --git a/tactics/tacintern.mli b/tactics/tacintern.mli index a6e28d56..7901cfeb 100644 --- a/tactics/tacintern.mli +++ b/tactics/tacintern.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let c = coerce_to_closed_constr env x in - Inr (pi3 (pattern_of_constr env sigma c)) in + Inr (pattern_of_constr env sigma c) in (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) with Not_found -> error_global_not_found_loc loc (qualid_of_ident id)) | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) - | Inr c -> Inr (pi3 (interp_typed_pattern ist env sigma c)) in + | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p let interp_constr_with_occurrences_and_name_as_list = @@ -866,7 +866,7 @@ and interp_intro_pattern_action ist env sigma = function let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in sigma, IntroInjection l | IntroApplyOn (c,ipat) -> - let c = fun env sigma -> interp_constr ist env sigma c in + let c = fun env sigma -> interp_open_constr ist env sigma c in let sigma,ipat = interp_intro_pattern ist env sigma ipat in sigma, IntroApplyOn (c,ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x @@ -902,9 +902,9 @@ let interp_intro_pattern_option ist env sigma = function let sigma, ipat = interp_intro_pattern ist env sigma ipat in sigma, Some ipat -let interp_in_hyp_as ist env sigma (clear,id,ipat) = +let interp_in_hyp_as ist env sigma (id,ipat) = let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in - sigma,(clear,interp_hyp ist env sigma id,ipat) + sigma,(interp_hyp ist env sigma id,ipat) let interp_quantified_hypothesis ist = function | AnonHyp n -> AnonHyp n @@ -989,7 +989,7 @@ let interp_induction_arg ist gl arg = try sigma, (constr_of_id env id', NoBindings) with Not_found -> user_err_loc (loc, "interp_induction_arg", - pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis.")) + pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.")) in try (** FIXME: should be moved to taccoerce *) @@ -1043,7 +1043,7 @@ let use_types = false let eval_pattern lfun ist env sigma ((glob,_),pat as c) = let bound_names = bound_glob_vars glob in if use_types then - (bound_names,pi3 (interp_typed_pattern ist env sigma c)) + (bound_names,interp_typed_pattern ist env sigma c) else (bound_names,instantiate_pattern env sigma lfun pat) @@ -1835,8 +1835,8 @@ and interp_atomic ist tac : unit Proofview.tactic = let sigma,tac = match cl with | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l | Some cl -> - let sigma,(clear,id,cl) = interp_in_hyp_as ist env sigma cl in - sigma, Tactics.apply_delayed_in a ev clear id l cl in + let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in + sigma, Tactics.apply_delayed_in a ev id l cl in Tacticals.New.tclWITHHOLES ev tac sigma end end @@ -2154,7 +2154,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in Proofview.V82.tactic begin fun gl -> - let (sigma,sign,op) = interp_typed_pattern ist env sigma op in + let op = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in let c_interp patvars sigma = let lfun' = Id.Map.fold (fun id c lfun -> @@ -2167,7 +2167,7 @@ and interp_atomic ist tac : unit Proofview.tactic = errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") in (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl)) - { gl with sigma = sigma } + gl end end end diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 7605c915..ac7e2149 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mkVar id) (named_context env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar id) b in - let sigma, ev = new_evar_instance nctx sigma nb ~store ninst in + let sigma, ev = new_evar_instance nctx sigma nb ~principal:true ~store ninst in sigma, mkNamedLambda_or_LetIn (id, c, t) ev end @@ -277,7 +277,8 @@ let apply_clear_request clear_flag dft c = error "keep/clear modifiers apply only to hypothesis names." in let clear = match clear_flag with | None -> dft && isVar c - | Some clear -> check_isvar c; clear in + | Some true -> check_isvar c; true + | Some false -> false in if clear then Proofview.V82.tactic (thin [destVar c]) else Tacticals.New.tclIDTAC @@ -633,24 +634,27 @@ let check_types env sigma mayneedglobalcheck deep newc origc = let t1 = Retyping.get_type_of env sigma newc in if deep then begin let t2 = Retyping.get_type_of env sigma origc in - let sigma, t2 = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t2 in - if not (snd (infer_conv ~pb:Reduction.CUMUL env sigma t1 t2)) then + let sigma, t2 = Evarsolve.refresh_universes + ~onlyalg:true (Some false) env sigma t2 in + let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in + if not b then if isSort (whd_betadeltaiota env sigma t1) && isSort (whd_betadeltaiota env sigma t2) - then - mayneedglobalcheck := true + then (mayneedglobalcheck := true; sigma) else errorlabstrm "convert-check-hyp" (str "Types are incompatible.") + else sigma end else if not (isSort (whd_betadeltaiota env sigma t1)) then errorlabstrm "convert-check-hyp" (str "Not a type.") + else sigma (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = let sigma, t' = t sigma in - check_types env sigma mayneedglobalcheck deep t' c; + let sigma = check_types env sigma mayneedglobalcheck deep t' c in let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in if not b then errorlabstrm "convert-check-hyp" (str "Not convertible."); sigma, t' @@ -1319,7 +1323,9 @@ let simplest_elim c = default_elim false None (c,NoBindings) *) let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = - try clenv_fchain ~flags mv elimclause hypclause + (** The evarmap of elimclause is assumed to be an extension of hypclause, so + we do not need to merge the universes coming from hypclause. *) + try clenv_fchain ~with_univs:false ~flags mv elimclause hypclause with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> (* Set the hypothesis name in the message *) raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) @@ -1603,7 +1609,7 @@ let progress_with_clause flags innerclause clause = let ordered_metas = List.rev (clenv_independent clause) in if List.is_empty ordered_metas then error "Statement without assumptions."; let f mv = - try Some (find_matching_clause (clenv_fchain mv ~flags clause) innerclause) + try Some (find_matching_clause (clenv_fchain ~with_univs:false mv ~flags clause) innerclause) with Failure _ -> None in try List.find_map f ordered_metas @@ -1728,6 +1734,10 @@ let vm_cast_no_check c gl = let concl = pf_concl gl in refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl +let native_cast_no_check c gl = + let concl = pf_concl gl in + refine_no_check (Term.mkCast(c,Term.NATIVEcast,concl)) gl + let exact_proof c gl = let c,ctx = Constrintern.interp_casted_constr (pf_env gl) (project gl) c (pf_concl gl) @@ -1834,7 +1844,7 @@ let clear_body ids = in check_hyps <*> check_concl <*> Proofview.Refine.refine ~unsafe:true begin fun sigma -> - Evarutil.new_evar env sigma concl + Evarutil.new_evar env sigma ~principal:true concl end end @@ -2214,19 +2224,9 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with Proofview.tclUNIT () (* apply_in_once do a replacement *) else Proofview.V82.tactic (clear [id]) in - Proofview.Goal.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let env = Proofview.Goal.env gl in - let sigma,c = f env sigma in - Tacticals.New.tclWITHHOLES false - (Tacticals.New.tclTHENFIRST - (* Skip the side conditions of the apply *) - (apply_in_once false true true true naming id - (None,(sigma,(c,NoBindings))) - (fun id -> Tacticals.New.tclTHEN doclear (tac_ipat id))) - (tac thin None [])) - sigma - end + let f env sigma = let (sigma,c) = f env sigma in (sigma,(c,NoBindings)) in + apply_in_delayed_once false true true true naming id (None,(loc,f)) + (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros_loc loc dft destopt = function | IntroNaming ipat -> @@ -2285,7 +2285,7 @@ let assert_as first hd ipat t = (* apply in as *) let general_apply_in sidecond_first with_delta with_destruct with_evars - with_clear id lemmas ipat = + id lemmas ipat = let tac (naming,lemma) tac id = apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id lemma tac in @@ -2310,12 +2310,12 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars Tacticals.New.tclTHENFIRST (tclMAPFIRST tac lemmas_target) (ipat_tac id) *) -let apply_in simple with_evars clear_flag id lemmas ipat = +let apply_in simple with_evars id lemmas ipat = let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, fun _ sigma -> sigma, l)) lemmas in - general_apply_in false simple simple with_evars clear_flag id lemmas ipat + general_apply_in false simple simple with_evars id lemmas ipat -let apply_delayed_in simple with_evars clear_flag id lemmas ipat = - general_apply_in false simple simple with_evars clear_flag id lemmas ipat +let apply_delayed_in simple with_evars id lemmas ipat = + general_apply_in false simple simple with_evars id lemmas ipat (*****************************) (* Tactics abstracting terms *) @@ -2345,7 +2345,12 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let t = match ty with Some t -> t | _ -> typ_of env sigma c in + let (sigma, t) = match ty with + | Some t -> (sigma, t) + | None -> + let t = typ_of env sigma c in + Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t + in let eq_tac gl = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with @@ -2599,7 +2604,7 @@ let new_generalize_gen_let lconstr = in Proofview.Unsafe.tclEVARS sigma <*> Proofview.Refine.refine begin fun sigma -> - let (sigma, ev) = Evarutil.new_evar env sigma newcl in + let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true newcl in (sigma, (applist (ev, args))) end end @@ -2825,6 +2830,14 @@ let induct_discharge dests avoid' tac (avoid,ra) names = s'embêter à regarder si un letin_tac ne fait pas des substitutions aussi sur l'argument voisin *) +let expand_projections env sigma c = + let rec aux env c = + match kind_of_term c with + | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] + | _ -> map_constr_with_full_binders push_rel aux env c + in aux env c + + (* Marche pas... faut prendre en compte l'occurrence précise... *) let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = @@ -2833,11 +2846,14 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in let typ0 = reduce_to_quantified_ref indref tmptyp0 in - let prods, indtyp = decompose_prod typ0 in + let prods, indtyp = decompose_prod_assum typ0 in let hd,argl = decompose_app indtyp in + let env' = push_rel_context prods env in + let sigma = Proofview.Goal.sigma gl in let params = List.firstn nparams argl in + let params' = List.map (expand_projections env' sigma) params in (* le gl est important pour ne pas préévaluer *) - let rec atomize_one i args avoid = + let rec atomize_one i args args' avoid = if Int.equal i nparams then let t = applist (hd, params@args) in Tacticals.New.tclTHEN @@ -2846,22 +2862,23 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = else let c = List.nth argl (i-1) in match kind_of_term c with - | Var id when not (List.exists (occur_var env id) args) && - not (List.exists (occur_var env id) params) -> + | Var id when not (List.exists (occur_var env id) args') && + not (List.exists (occur_var env id) params') -> (* Based on the knowledge given by the user, all constraints on the variable are generalizable in the current environment so that it is clearable after destruction *) - atomize_one (i-1) (c::args) (id::avoid) + atomize_one (i-1) (c::args) (c::args') (id::avoid) | _ -> - if List.exists (dependent c) params || - List.exists (dependent c) args + let c' = expand_projections env' sigma c in + if List.exists (dependent c) params' || + List.exists (dependent c) args' then (* This is a case where the argument is constrained in a way which would require some kind of inversion; we follow the (old) discipline of not generalizing over this term, since we don't try to invert the constraint anyway. *) - atomize_one (i-1) (c::args) avoid + atomize_one (i-1) (c::args) (c'::args') avoid else (* We reason blindly on the term and do as if it were generalizable, ignoring the constraints coming from @@ -2874,9 +2891,9 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) - (atomize_one (i-1) (mkVar x::args) (x::avoid)) + (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (x::avoid)) in - atomize_one (List.length argl) [] [] + atomize_one (List.length argl) [] [] [] end (* [cook_sign] builds the lists [beforetoclear] (preceding the @@ -3196,7 +3213,7 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls = mkProd (Anonymous, eq, lift 1 concl), [| refl |] else concl, [||] in - (* Abstract by equalitites *) + (* Abstract by equalities *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in (* Abstract by the "generalized" hypothesis. *) @@ -3207,11 +3224,11 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls = 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. *) + (* Then apply to the original instantiated hyp. *) let instc = Option.cata (fun _ -> instc) (mkApp (instc, [| mkVar id |])) body 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. *) + (* Finally, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) mkApp (appeqs, abshypt) let hyps_of_vars env sign nogen hyps = @@ -3737,7 +3754,7 @@ let recolle_clenv i params args elimclause gl = trying to unify (which would lead to trying to apply it to evars if y is a product). *) let indclause = mk_clenv_from_n gl (Some 0) (x,y) in - let elimclause' = clenv_fchain i acc indclause in + let elimclause' = clenv_fchain ~with_univs:false i acc indclause in elimclause') (List.rev clauses) elimclause @@ -4534,7 +4551,7 @@ module Simple = struct let case c = general_case_analysis false None (c,NoBindings) let apply_in id c = - apply_in false false None id [None,(Loc.ghost, (c, NoBindings))] None + apply_in false false id [None,(Loc.ghost, (c, NoBindings))] None end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index ade89fc9..c28cb521 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit Proofview.tactic val assumption : unit Proofview.tactic val exact_no_check : constr -> tactic val vm_cast_no_check : constr -> tactic +val native_cast_no_check : constr -> tactic val exact_check : constr -> unit Proofview.tactic val exact_proof : Constrexpr.constr_expr -> tactic @@ -196,12 +197,12 @@ val eapply_with_bindings : constr with_bindings -> unit Proofview.tactic val cut_and_apply : constr -> unit Proofview.tactic val apply_in : - advanced_flag -> evars_flag -> clear_flag -> Id.t -> + advanced_flag -> evars_flag -> Id.t -> (clear_flag * constr with_bindings located) list -> intro_pattern option -> unit Proofview.tactic val apply_delayed_in : - advanced_flag -> evars_flag -> clear_flag -> Id.t -> + advanced_flag -> evars_flag -> Id.t -> (clear_flag * delayed_open_constr_with_bindings located) list -> intro_pattern option -> unit Proofview.tactic diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index b4c7bffa..f41fac54 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* "$@" +report: summary.log + $(HIDE)if grep -F 'Error!' summary.log ; then false; fi + ####################################################################### # Regression (and progression) tests ####################################################################### @@ -349,7 +352,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v fi; \ } > "$@" -# Additionnal dependencies for module tests +# Additional dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo modules/%.vo: modules/%.v $(HIDE)$(coqtop) -R modules Mods -compile $< diff --git a/test-suite/bench/lists-100.v b/test-suite/bench/lists-100.v index 352c7cea..5c64716c 100644 --- a/test-suite/bench/lists-100.v +++ b/test-suite/bench/lists-100.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr:(proj1 T) | forall x : ?T', @?f x => - constr:(fun x : T' => $(let fx := constr:(T x) in + constr:(fun x : T' => ltac:(let fx := constr:(T x) in let t := ret_and_left fx in - exact t)$) + exact t)) end. diff --git a/test-suite/bugs/closed/3257.v b/test-suite/bugs/closed/3257.v new file mode 100644 index 00000000..d8aa6a04 --- /dev/null +++ b/test-suite/bugs/closed/3257.v @@ -0,0 +1,5 @@ +Require Import Setoid Morphisms Basics. +Lemma foo A B (P : B -> Prop) : + pointwise_relation _ impl (fun z => A -> P z) P. +Proof. + Fail reflexivity. diff --git a/test-suite/bugs/closed/3285.v b/test-suite/bugs/closed/3285.v index 25162329..68e6b738 100644 --- a/test-suite/bugs/closed/3285.v +++ b/test-suite/bugs/closed/3285.v @@ -1,7 +1,7 @@ Goal True. Proof. match goal with - | _ => let x := constr:($(fail)$) in idtac + | _ => let x := constr:(ltac:(fail)) in idtac | _ => idtac end. Abort. diff --git a/test-suite/bugs/closed/3286.v b/test-suite/bugs/closed/3286.v index b08b7ab3..701480fc 100644 --- a/test-suite/bugs/closed/3286.v +++ b/test-suite/bugs/closed/3286.v @@ -6,20 +6,20 @@ Ltac make_apply_under_binders_in lem H := | forall x : ?T, @?P x => let ret := constr:(fun x' : T => let Hx := H x' in - $(let ret' := tac lem Hx in - exact ret')$) in + ltac:(let ret' := tac lem Hx in + exact ret')) in match eval cbv zeta in ret with | fun x => Some (@?P x) => let P' := (eval cbv zeta in P) in constr:(Some P') end - | _ => let ret := constr:($(match goal with + | _ => let ret := constr:(ltac:(match goal with | _ => (let H' := fresh in pose H as H'; apply lem in H'; exact (Some H')) | _ => exact (@None nat) end - )$) in + )) in let ret' := (eval cbv beta zeta in ret) in constr:(ret') | _ => constr:(@None nat) diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v index fb3791af..a5782298 100644 --- a/test-suite/bugs/closed/3314.v +++ b/test-suite/bugs/closed/3314.v @@ -1,9 +1,9 @@ Require Import TestSuite.admit. Set Universe Polymorphism. Definition Lift -: $(let U1 := constr:(Type) in +: ltac:(let U1 := constr:(Type) in let U0 := constr:(Type : U1) in - exact (U0 -> U1))$ + exact (U0 -> U1)) := fun T => T. Fail Check nat:Prop. (* The command has indeed failed with message: diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v index e6a50449..e3b5e943 100644 --- a/test-suite/bugs/closed/3330.v +++ b/test-suite/bugs/closed/3330.v @@ -8,7 +8,7 @@ Inductive foo : Type@{l} := bar : foo . Section MakeEq. Variables (a : foo@{i}) (b : foo@{j}). - Let t := $(let ty := type of b in exact ty)$. + Let t := ltac:(let ty := type of b in exact ty). Definition make_eq (x:=b) := a : t. End MakeEq. diff --git a/test-suite/bugs/closed/3347.v b/test-suite/bugs/closed/3347.v index 63d5c7a5..dcf5394e 100644 --- a/test-suite/bugs/closed/3347.v +++ b/test-suite/bugs/closed/3347.v @@ -1,7 +1,7 @@ Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12653 lines to 12453 lines, then from 11673 lines to 681 lines, then from 693 lines to 469 lines, then from 375 lines to 56 lines *) Set Universe Polymorphism. -Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Notation Type1 := ltac:(let U := constr:(Type) in let gt := constr:(Set : U) in exact U) (only parsing). Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. Inductive Unit : Type1 := tt : Unit. Fail Check Unit : Set. (* [Check Unit : Set] should fail if [Type1] is defined correctly *) diff --git a/test-suite/bugs/closed/3354.v b/test-suite/bugs/closed/3354.v index 14b66db3..a635285f 100644 --- a/test-suite/bugs/closed/3354.v +++ b/test-suite/bugs/closed/3354.v @@ -1,5 +1,5 @@ Set Universe Polymorphism. -Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Notation Type1 := ltac:(let U := constr:(Type) in let gt := constr:(Set : U) in exact U) (only parsing). Inductive Empty : Type1 := . Fail Check Empty : Set. (* Toplevel input, characters 15-116: diff --git a/test-suite/bugs/closed/3467.v b/test-suite/bugs/closed/3467.v index 7e371162..88ae0305 100644 --- a/test-suite/bugs/closed/3467.v +++ b/test-suite/bugs/closed/3467.v @@ -1,5 +1,5 @@ Module foo. - Notation x := $(exact I)$. + Notation x := ltac:(exact I). End foo. Module bar. Include foo. diff --git a/test-suite/bugs/closed/3487.v b/test-suite/bugs/closed/3487.v index 03c60a8b..1321a859 100644 --- a/test-suite/bugs/closed/3487.v +++ b/test-suite/bugs/closed/3487.v @@ -1,4 +1,4 @@ -Notation bar := $(exact I)$. +Notation bar := ltac:(exact I). Notation foo := bar (only parsing). Class baz := { x : False }. Instance: baz. diff --git a/test-suite/bugs/closed/3554.v b/test-suite/bugs/closed/3554.v new file mode 100644 index 00000000..13a79cc8 --- /dev/null +++ b/test-suite/bugs/closed/3554.v @@ -0,0 +1 @@ +Example foo (f : forall {_ : Type}, Type) : Type. diff --git a/test-suite/bugs/closed/3682.v b/test-suite/bugs/closed/3682.v index 2a282d22..9d37d1a2 100644 --- a/test-suite/bugs/closed/3682.v +++ b/test-suite/bugs/closed/3682.v @@ -3,4 +3,4 @@ Class Foo. Definition bar `{Foo} (x : Set) := Set. Instance: Foo. Definition bar1 := bar nat. -Definition bar2 := bar $(admit)$. +Definition bar2 := bar ltac:(admit). diff --git a/test-suite/bugs/closed/3684.v b/test-suite/bugs/closed/3684.v index f7b13738..130d5777 100644 --- a/test-suite/bugs/closed/3684.v +++ b/test-suite/bugs/closed/3684.v @@ -1,5 +1,5 @@ Require Import TestSuite.admit. Definition foo : Set. Proof. - refine ($(abstract admit)$). + refine (ltac:(abstract admit)). Qed. diff --git a/test-suite/bugs/closed/3685.v b/test-suite/bugs/closed/3685.v index a5bea34a..7a0c3e6f 100644 --- a/test-suite/bugs/closed/3685.v +++ b/test-suite/bugs/closed/3685.v @@ -39,11 +39,11 @@ Module Export PointwiseCore. (G : Functor D D') : Functor (C -> D) (C' -> D'). Proof. - refine (Build_Functor + unshelve (refine (Build_Functor (C -> D) (C' -> D') _ _ - _); + _)); abstract admit. Defined. End PointwiseCore. diff --git a/test-suite/bugs/closed/3686.v b/test-suite/bugs/closed/3686.v index b650920b..df5f6674 100644 --- a/test-suite/bugs/closed/3686.v +++ b/test-suite/bugs/closed/3686.v @@ -33,11 +33,11 @@ Module Export PointwiseCore. (G : Functor D D') : Functor (C -> D) (C' -> D'). Proof. - refine (Build_Functor + unshelve (refine (Build_Functor (C -> D) (C' -> D') _ _ - _); + _)); abstract admit. Defined. End PointwiseCore. diff --git a/test-suite/bugs/closed/3690.v b/test-suite/bugs/closed/3690.v index df9f5f47..c24173ab 100644 --- a/test-suite/bugs/closed/3690.v +++ b/test-suite/bugs/closed/3690.v @@ -18,7 +18,7 @@ Top.8} Top.6 Top.7 Top.8 |= *) *) -Definition bar := $(let t := eval compute in foo in exact t)$. +Definition bar := ltac:(let t := eval compute in foo in exact t). Check @bar. (* bar@{Top.13 Top.14 Top.15 Top.16} : Type@{Top.16+1} diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v index 62137f0c..aad0bb44 100644 --- a/test-suite/bugs/closed/3699.v +++ b/test-suite/bugs/closed/3699.v @@ -34,8 +34,8 @@ Module NonPrim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intro x. exact (transport P x.2 (d x.1)). Defined. @@ -47,8 +47,8 @@ Module NonPrim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intros [a p]. exact (transport P p (d a)). Defined. @@ -111,8 +111,8 @@ Module Prim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intro x. exact (transport P x.2 (d x.1)). Defined. @@ -124,8 +124,8 @@ Module Prim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intros [a p]. exact (transport P p (d a)). Defined. diff --git a/test-suite/bugs/closed/3735.v b/test-suite/bugs/closed/3735.v new file mode 100644 index 00000000..a50572ac --- /dev/null +++ b/test-suite/bugs/closed/3735.v @@ -0,0 +1,4 @@ +Require Import Coq.Program.Tactics. +Class Foo := { bar : Type }. +Fail Lemma foo : Foo -> bar. (* 'Command has indeed failed.' in both 8.4 and trunk *) +Fail Program Lemma foo : Foo -> bar. \ No newline at end of file diff --git a/test-suite/bugs/closed/3743.v b/test-suite/bugs/closed/3743.v index 4dfb3380..c799d439 100644 --- a/test-suite/bugs/closed/3743.v +++ b/test-suite/bugs/closed/3743.v @@ -3,7 +3,7 @@ coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d65496f09c4b68fa318783e53f9cd6d5c18e1eb7) *) Require Export Coq.Setoids.Setoid. -Fail Add Parametric Relation A +Add Parametric Relation A : A (@eq A) transitivity proved by transitivity as refine_rel. diff --git a/test-suite/bugs/closed/3746.v b/test-suite/bugs/closed/3746.v new file mode 100644 index 00000000..a9463f94 --- /dev/null +++ b/test-suite/bugs/closed/3746.v @@ -0,0 +1,92 @@ + +(* Bug report #3746 : Include and restricted signature *) + +Module Type MT. Parameter p : nat. End MT. +Module Type EMPTY. End EMPTY. +Module Empty. End Empty. + +(* Include of an applied functor with restricted sig : + Used to create axioms (bug report #3746), now forbidden. *) + +Module F (X:EMPTY) : MT. + Definition p := 0. +End F. + +Module InclFunctRestr. + Fail Include F(Empty). +End InclFunctRestr. + +(* A few variants (indirect restricted signature), also forbidden. *) + +Module F1 := F. +Module F2 (X:EMPTY) := F X. + +Module F3a (X:EMPTY). Definition p := 0. End F3a. +Module F3 (X:EMPTY) : MT := F3a X. + +Module InclFunctRestrBis. + Fail Include F1(Empty). + Fail Include F2(Empty). + Fail Include F3(Empty). +End InclFunctRestrBis. + +(* Recommended workaround: manual instance before the include. *) + +Module InclWorkaround. + Module Temp := F(Empty). + Include Temp. +End InclWorkaround. + +Compute InclWorkaround.p. +Print InclWorkaround.p. +Print Assumptions InclWorkaround.p. (* Closed under the global context *) + + + +(* Related situations which are ok, just to check *) + +(* A) Include of non-functor with restricted signature : + creates a proxy to initial stuff *) + +Module M : MT. + Definition p := 0. +End M. + +Module InclNonFunct. + Include M. +End InclNonFunct. + +Definition check : InclNonFunct.p = M.p := eq_refl. +Print Assumptions InclNonFunct.p. (* Closed *) + + +(* B) Include of a module type with opaque content: + The opaque content is "copy-pasted". *) + +Module Type SigOpaque. + Definition p : nat. Proof. exact 0. Qed. +End SigOpaque. + +Module InclSigOpaque. + Include SigOpaque. +End InclSigOpaque. + +Compute InclSigOpaque.p. +Print InclSigOpaque.p. +Print Assumptions InclSigOpaque.p. (* Closed *) + + +(* C) Include of an applied functor with opaque proofs : + opaque proof "copy-pasted" (and substituted). *) + +Module F' (X:EMPTY). + Definition p : nat. Proof. exact 0. Qed. +End F'. + +Module InclFunctOpa. + Include F'(Empty). +End InclFunctOpa. + +Compute InclFunctOpa.p. +Print InclFunctOpa.p. +Print Assumptions InclFunctOpa.p. (* Closed *) diff --git a/test-suite/bugs/closed/3807.v b/test-suite/bugs/closed/3807.v new file mode 100644 index 00000000..108ebf59 --- /dev/null +++ b/test-suite/bugs/closed/3807.v @@ -0,0 +1,33 @@ +Set Universe Polymorphism. +Set Printing Universes. +Unset Universe Minimization ToSet. + + +Definition foo : Type := nat. +About foo. +(* foo@{Top.1} : Type@{Top.1}*) +(* Top.1 |= *) + +Definition bar : foo -> nat. +Admitted. +About bar. +(* bar@{Top.2} : foo@{Top.2} -> nat *) +(* Top.2 |= *) + +Lemma baz@{i} : foo@{i} -> nat. +Proof. + exact bar. +Defined. + +Definition bar'@{i} : foo@{i} -> nat. + intros f. exact 0. +Admitted. +About bar'. +(* bar'@{i} : foo@{i} -> nat *) +(* i |= *) + +Axiom f@{i} : Type@{i}. +(* +*** [ f@{i} : Type@{i} ] +(* i |= *) +*) \ No newline at end of file diff --git a/test-suite/bugs/closed/3848.v b/test-suite/bugs/closed/3848.v new file mode 100644 index 00000000..c0ef02f1 --- /dev/null +++ b/test-suite/bugs/closed/3848.v @@ -0,0 +1,22 @@ +Require Import TestSuite.admit. +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. +Arguments eisretr {A B} f {_} _. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'"). +Generalizable Variables A B f g e n. +Definition functor_forall `{P : A -> Type} `{Q : B -> Type} + (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) +: (forall a:A, P a) -> (forall b:B, Q b). + admit. +Defined. + +Lemma isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type} + `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} +: (forall b : B, Q b) -> forall a : A, P a. +Proof. + refine (functor_forall + (f^-1) + (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). +Defined. (* was: Error: Attempt to save an incomplete proof *) diff --git a/test-suite/bugs/closed/3881.v b/test-suite/bugs/closed/3881.v index 4408ab88..070d1e9c 100644 --- a/test-suite/bugs/closed/3881.v +++ b/test-suite/bugs/closed/3881.v @@ -8,7 +8,7 @@ Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Notation "A -> B" := (forall (_ : A), B) : type_scope. Axiom admit : forall {T}, T. Notation "g 'o' f" := (fun x => g (f x)) (at level 40, left associativity). -Notation "g 'o' f" := $(let g' := g in let f' := f in exact (fun x => g' (f' x)))$ (at level 40, left associativity). (* Ensure that x is not captured in [g] or [f] in case they contain holes *) +Notation "g 'o' f" := ltac:(let g' := g in let f' := f in exact (fun x => g' (f' x))) (at level 40, left associativity). (* Ensure that x is not captured in [g] or [f] in case they contain holes *) Inductive eq {A} (x:A) : A -> Prop := eq_refl : x = x where "x = y" := (@eq _ x y) : type_scope. Arguments eq_refl {_ _}. Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with eq_refl => eq_refl end. diff --git a/test-suite/bugs/closed/3923.v b/test-suite/bugs/closed/3923.v new file mode 100644 index 00000000..0aa029e7 --- /dev/null +++ b/test-suite/bugs/closed/3923.v @@ -0,0 +1,33 @@ +Module Type TRIVIAL. +Parameter t:Type. +End TRIVIAL. + +Module MkStore (Key : TRIVIAL). + +Module St : TRIVIAL. +Definition t := unit. +End St. + +End MkStore. + + + +Module Type CERTRUNTIMETYPES (B : TRIVIAL). + +Parameter cert_fieldstore : Type. +Parameter empty_fieldstore : cert_fieldstore. + +End CERTRUNTIMETYPES. + + + +Module MkCertRuntimeTypes (B : TRIVIAL) : CERTRUNTIMETYPES B. + +Module FieldStore := MkStore B. + +Definition cert_fieldstore := FieldStore.St.t. +Axiom empty_fieldstore : cert_fieldstore. + +End MkCertRuntimeTypes. + +Extraction MkCertRuntimeTypes. (* Was leading to an uncaught Not_found *) diff --git a/test-suite/bugs/closed/3998.v b/test-suite/bugs/closed/3998.v new file mode 100644 index 00000000..ced13839 --- /dev/null +++ b/test-suite/bugs/closed/3998.v @@ -0,0 +1,24 @@ +Class FieldType (F : Set) := mkFieldType { fldTy: F -> Set }. +Hint Mode FieldType + : typeclass_instances. (* The F parameter is an input *) + +Inductive I1 := C. +Inductive I2 := . + +Instance I1FieldType : FieldType I1 := { fldTy := I1_rect _ bool }. +Instance I2FieldType : FieldType I2 := { fldTy := I2_rect _ }. + +Definition RecordOf F (FT: FieldType F) := forall f:F, fldTy f. + +Class MapOps (M K : Set) := { + tgtTy: K -> Set; + update: M -> forall k:K, tgtTy k -> M +}. + +Instance RecordMapOps F (FT: FieldType F) : MapOps (RecordOf F FT) F := +{ tgtTy := fldTy; update := fun r (f: F) (x: fldTy f) z => r z }. + +Axiom ex : RecordOf _ I1FieldType. + +Definition works := (fun ex' => update ex' C true) (update ex C false). +Set Typeclasses Debug. +Definition doesnt := update (update ex C false) C true. \ No newline at end of file diff --git a/test-suite/bugs/closed/4116.v b/test-suite/bugs/closed/4116.v index f808cb45..5932c9c5 100644 --- a/test-suite/bugs/closed/4116.v +++ b/test-suite/bugs/closed/4116.v @@ -110,7 +110,7 @@ Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. Tactic Notation "transparent" "assert" "(" ident(name) ":" constr(type) ")" := - refine (let __transparent_assert_hypothesis := (_ : type) in _); + unshelve refine (let __transparent_assert_hypothesis := (_ : type) in _); [ | ( let H := match goal with H := _ |- _ => constr:(H) end in @@ -321,7 +321,7 @@ Section Grothendieck. Definition Gcategory : PreCategory. Proof. - refine (@Build_PreCategory + unshelve refine (@Build_PreCategory Pair (fun s d => Gmorphism s d) Gidentity @@ -346,7 +346,7 @@ Section Grothendieck2. Instance iscategory_grothendieck_toset : IsCategory (Gcategory F). Proof. intros s d. - refine (isequiv_adjointify _ _ _ _). + unshelve refine (isequiv_adjointify _ _ _ _). { intro m. transparent assert (H' : (s.(c) = d.(c))). diff --git a/test-suite/bugs/closed/4149.v b/test-suite/bugs/closed/4149.v new file mode 100644 index 00000000..b81c680c --- /dev/null +++ b/test-suite/bugs/closed/4149.v @@ -0,0 +1,4 @@ +Goal forall A, A -> Type. +Proof. + intros; eauto. +Qed. diff --git a/test-suite/bugs/closed/4256.v b/test-suite/bugs/closed/4256.v new file mode 100644 index 00000000..3cdc4ada --- /dev/null +++ b/test-suite/bugs/closed/4256.v @@ -0,0 +1,43 @@ +(* Testing 8.5 regression with type classes not solving evars + redefined while trying to solve them with the type class mechanism *) + +Global Set Universe Polymorphism. +Monomorphic Universe i. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. +Notation "-1" := (trunc_S minus_two) (at level 0). + +Class IsPointed (A : Type) := point : A. +Arguments point A {_}. + +Record pType := + { pointed_type : Type ; + ispointed_type : IsPointed pointed_type }. +Coercion pointed_type : pType >-> Sortclass. +Existing Instance ispointed_type. + +Private Inductive Trunc (n : trunc_index) (A :Type) : Type := + tr : A -> Trunc n A. +Arguments tr {n A} a. + + + +Record ooGroup := + { classifying_space : pType@{i} }. + +Definition group_loops (X : pType) +: ooGroup. +Proof. + (** This works: *) + pose (x0 := point X). + pose (H := existT (fun x:X => Trunc -1 (x = point X)) x0 (tr idpath)). + clear H x0. + (** But this doesn't: *) + pose (existT (fun x:X => Trunc -1 (x = point X)) (point X) (tr idpath)). diff --git a/test-suite/bugs/closed/4273.v b/test-suite/bugs/closed/4273.v new file mode 100644 index 00000000..591ea4b5 --- /dev/null +++ b/test-suite/bugs/closed/4273.v @@ -0,0 +1,9 @@ + + +Set Primitive Projections. +Record total2 (P : nat -> Prop) := tpair { pr1 : nat; pr2 : P pr1 }. +Theorem onefiber' (q : total2 (fun y => y = 0)) : True. +Proof. assert (foo:=pr2 _ q). simpl in foo. + destruct foo. (* Error: q is used in conclusion. *) exact I. Qed. + +Print onefiber'. \ No newline at end of file diff --git a/test-suite/bugs/closed/4284.v b/test-suite/bugs/closed/4284.v new file mode 100644 index 00000000..0fff3026 --- /dev/null +++ b/test-suite/bugs/closed/4284.v @@ -0,0 +1,6 @@ +Set Primitive Projections. +Record total2 { T: Type } ( P: T -> Type ) := tpair { pr1 : T; pr2 : P pr1 }. +Theorem onefiber' {X : Type} (P : X -> Type) (x : X) : True. +Proof. +set (Q1 := total2 (fun f => pr1 P f = x)). +set (f1:=fun q1 : Q1 => pr2 _ (pr1 _ q1)). diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v index 0623cf5b..43c9b512 100644 --- a/test-suite/bugs/closed/4287.v +++ b/test-suite/bugs/closed/4287.v @@ -118,8 +118,6 @@ Definition setle (B : Type@{i}) := let foo (A : Type@{j}) := A in foo B. Fail Check @setlt@{j Prop}. -Check @setlt@{Prop j}. -Check @setle@{Prop j}. - Fail Definition foo := @setle@{j Prop}. -Definition foo := @setle@{Prop j}. +Check setlt@{Set i}. +Check setlt@{Set j}. \ No newline at end of file diff --git a/test-suite/bugs/closed/4293.v b/test-suite/bugs/closed/4293.v new file mode 100644 index 00000000..3671c931 --- /dev/null +++ b/test-suite/bugs/closed/4293.v @@ -0,0 +1,7 @@ +Module Type Foo. +Definition T := let X := Type in Type. +End Foo. + +Module M : Foo. +Definition T := let X := Type in Type. +End M. \ No newline at end of file diff --git a/test-suite/bugs/closed/4363.v b/test-suite/bugs/closed/4363.v new file mode 100644 index 00000000..9895548c --- /dev/null +++ b/test-suite/bugs/closed/4363.v @@ -0,0 +1,9 @@ +Set Printing Universes. +Definition foo : Type. +Proof. + assert (H : Set) by abstract (assert Type by abstract exact Type using bar; exact nat). + exact bar. +Defined. (* Toplevel input, characters 0-8: +Error: +The term "(fun _ : Set => bar) foo_subproof" has type +"Type@{Top.2}" while it is expected to have type "Type@{Top.1}". *) diff --git a/test-suite/bugs/closed/4400.v b/test-suite/bugs/closed/4400.v new file mode 100644 index 00000000..5c23f840 --- /dev/null +++ b/test-suite/bugs/closed/4400.v @@ -0,0 +1,19 @@ +(* -*- coq-prog-args: ("-emacs" "-require" "Coq.Compat.Coq84" "-compat" "8.4") -*- *) +Require Import Coq.Lists.List Coq.Logic.JMeq Program.Equality. +Set Printing Universes. +Inductive Foo (I : Type -> Type) (A : Type) : Type := +| foo (B : Type) : A -> I B -> Foo I A. +Definition Family := Type -> Type. +Definition FooToo : Family -> Family := Foo. +Definition optionize (I : Type -> Type) (A : Type) := option (I A). +Definition bar (I : Type -> Type) (A : Type) : A -> option (I A) -> Foo(optionize I) A := foo (optionize I) A A. +Record Rec (I : Type -> Type) := { rec : forall A : Type, A -> I A -> Foo I A }. +Definition barRec : Rec (optionize id) := {| rec := bar id |}. +Inductive Empty {T} : T -> Prop := . +Theorem empty (family : Family) (a : fold_right prod unit (map (Foo family) +nil)) (b : unit) : + Empty (a, b) -> False. +Proof. + intro e. + dependent induction e. +Qed. diff --git a/test-suite/bugs/closed/4404.v b/test-suite/bugs/closed/4404.v new file mode 100644 index 00000000..27b43a61 --- /dev/null +++ b/test-suite/bugs/closed/4404.v @@ -0,0 +1,4 @@ +Inductive Foo : Type -> Type := foo A : Foo A. +Goal True. + remember Foo. + diff --git a/test-suite/bugs/closed/4412.v b/test-suite/bugs/closed/4412.v new file mode 100644 index 00000000..4b2aae0c --- /dev/null +++ b/test-suite/bugs/closed/4412.v @@ -0,0 +1,4 @@ +Require Import Coq.Bool.Bool Coq.Setoids.Setoid. +Goal forall (P : forall b : bool, b = true -> Type) (x y : bool) (H : andb x y = true) (H' : P _ H), True. + intros. + Fail rewrite Bool.andb_true_iff in H. diff --git a/test-suite/bugs/closed/4420.v b/test-suite/bugs/closed/4420.v new file mode 100644 index 00000000..0e16cb23 --- /dev/null +++ b/test-suite/bugs/closed/4420.v @@ -0,0 +1,19 @@ +Module foo. + Context (Char : Type). + Axiom foo : Type -> Type. + Goal foo Char = foo Char. + change foo with (fun x => foo x). + cbv beta. + reflexivity. + Defined. +End foo. + +Inductive foo (A : Type) : Prop := I. (*Top.1*) +Lemma bar : foo Type. (*Top.3*) +Proof. + Set Printing Universes. +change foo with (fun x : Type => foo x). (*Top.4*) +cbv beta. +apply I. (* I Type@{Top.3} : (fun x : Type@{Top.4} => foo x) Type@{Top.3} *) +Defined. + diff --git a/test-suite/bugs/closed/4429.v b/test-suite/bugs/closed/4429.v new file mode 100644 index 00000000..bf0e570a --- /dev/null +++ b/test-suite/bugs/closed/4429.v @@ -0,0 +1,31 @@ +Require Import Arith.Compare_dec. +Require Import Unicode.Utf8. + +Fixpoint my_nat_iter (n : nat) {A} (f : A → A) (x : A) : A := + match n with + | O => x + | S n' => f (my_nat_iter n' f x) + end. + +Definition gcd_IT_F (f : nat * nat → nat) (mn : nat * nat) : nat := + match mn with + | (0, 0) => 0 + | (0, S n') => S n' + | (S m', 0) => S m' + | (S m', S n') => + match le_gt_dec (S m') (S n') with + | left _ => f (S m', S n' - S m') + | right _ => f (S m' - S n', S n') + end + end. + +Axiom max_correct_l : ∀ m n : nat, m <= max m n. +Axiom max_correct_r : ∀ m n : nat, n <= max m n. + +Hint Resolve max_correct_l max_correct_r : arith. + +Theorem foo : ∀ p p' p'' : nat, p'' < S (max p (max p' p'')). +Proof. + intros. + Timeout 3 eauto with arith. +Qed. diff --git a/test-suite/bugs/closed/4433.v b/test-suite/bugs/closed/4433.v new file mode 100644 index 00000000..9eeb8646 --- /dev/null +++ b/test-suite/bugs/closed/4433.v @@ -0,0 +1,29 @@ +Require Import Coq.Arith.Arith Coq.Init.Wf. +Axiom proof_admitted : False. +Goal exists x y z : nat, Fix + Wf_nat.lt_wf + (fun _ => nat -> nat) + (fun x' f => match x' as x'0 + return match x'0 with + | 0 => True + | S x'' => x'' < x' + end + -> nat -> nat + with + | 0 => fun _ _ => 0 + | S x'' => f x'' + end + (match x' with + | 0 => I + | S x'' => (Nat.lt_succ_diag_r _) + end)) + z + y + = 0. +Proof. + do 3 (eexists; [ shelve.. | ]). + match goal with |- ?G => let G' := (eval lazy in G) in change G with G' end. + case proof_admitted. + Unshelve. + all:constructor. +Defined. \ No newline at end of file diff --git a/test-suite/bugs/closed/4443.v b/test-suite/bugs/closed/4443.v new file mode 100644 index 00000000..66dfa0e6 --- /dev/null +++ b/test-suite/bugs/closed/4443.v @@ -0,0 +1,31 @@ +Set Universe Polymorphism. + +Record TYPE@{i} := cType { + type : Type@{i}; +}. + +Definition PROD@{i j k} + (A : Type@{i}) + (B : A -> Type@{j}) + : TYPE@{k}. +Proof. + refine (cType@{i} _). ++ refine (forall x : A, B x). +Defined. + +Local Unset Strict Universe Declaration. +Definition PRODinj + (A : Type@{i}) + (B : A -> Type) + : TYPE. +Proof. + refine (cType@{i} _). ++ refine (forall x : A, B x). +Defined. + + Monomorphic Universe i j. + Monomorphic Constraint j < i. +Set Printing Universes. +Check PROD@{i i i}. +Check PRODinj@{i j}. +Fail Check PRODinj@{j i}. \ No newline at end of file diff --git a/test-suite/bugs/closed/4453.v b/test-suite/bugs/closed/4453.v new file mode 100644 index 00000000..009dd5e3 --- /dev/null +++ b/test-suite/bugs/closed/4453.v @@ -0,0 +1,8 @@ + +Section Foo. +Variable A : Type. +Lemma foo : A -> True. now intros _. Qed. +Goal Type -> True. +rename A into B. +intros A. +Fail apply foo. diff --git a/test-suite/bugs/closed/4456.v b/test-suite/bugs/closed/4456.v new file mode 100644 index 00000000..a32acf78 --- /dev/null +++ b/test-suite/bugs/closed/4456.v @@ -0,0 +1,647 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-R" "." "Fiat" "-top" "BooleanRecognizerMin" "-R" "." "Top") -*- *) +(* File reduced by coq-bug-finder from original input, then from 2475 lines to 729 lines, then from 746 lines to 658 lines, then from 675 lines to 658 lines *) +(* coqc version 8.5beta3 (November 2015) compiled on Nov 11 2015 18:23:0 with OCaml 4.01.0 + coqtop version 8.5beta3 (November 2015) *) +(* Variable P : forall n m : nat, n = m -> Prop. *) +(* Axiom Prefl : forall n : nat, P n n eq_refl. *) +Axiom proof_admitted : False. + +Tactic Notation "admit" := case proof_admitted. + +Require Coq.Program.Program. +Require Coq.Strings.String. +Require Coq.omega.Omega. +Module Export Fiat_DOT_Common. +Module Export Fiat. +Module Common. +Import Coq.Lists.List. +Export Coq.Program.Program. + +Global Set Implicit Arguments. + +Global Coercion is_true : bool >-> Sortclass. +Coercion bool_of_sum {A B} (b : sum A B) : bool := if b then true else false. + +Fixpoint ForallT {T} (P : T -> Type) (ls : list T) : Type + := match ls return Type with + | nil => True + | x::xs => (P x * ForallT P xs)%type + end. +Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type + := match ls with + | nil => P nil + | x::xs => (P (x::xs) * Forall_tails P xs)%type + end. + +End Common. + +End Fiat. + +End Fiat_DOT_Common. +Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. +Module Export Fiat. +Module Export Parsers. +Module Export StringLike. +Module Export Core. +Import Coq.Relations.Relation_Definitions. +Import Coq.Classes.Morphisms. + +Local Coercion is_true : bool >-> Sortclass. + +Module Export StringLike. + Class StringLike {Char : Type} := + { + String :> Type; + is_char : String -> Char -> bool; + length : String -> nat; + take : nat -> String -> String; + drop : nat -> String -> String; + get : nat -> String -> option Char; + unsafe_get : nat -> String -> Char; + bool_eq : String -> String -> bool; + beq : relation String := fun x y => bool_eq x y + }. + + Arguments StringLike : clear implicits. + Infix "=s" := (@beq _ _) (at level 70, no associativity) : type_scope. + Notation "s ~= [ ch ]" := (is_char s ch) (at level 70, no associativity) : string_like_scope. + Local Open Scope string_like_scope. + + Class StringLikeProperties (Char : Type) `{StringLike Char} := + { + singleton_unique : forall s ch ch', s ~= [ ch ] -> s ~= [ ch' ] -> ch = ch'; + singleton_exists : forall s, length s = 1 -> exists ch, s ~= [ ch ]; + get_0 : forall s ch, take 1 s ~= [ ch ] <-> get 0 s = Some ch; + get_S : forall n s, get (S n) s = get n (drop 1 s); + unsafe_get_correct : forall n s ch, get n s = Some ch -> unsafe_get n s = ch; + length_singleton : forall s ch, s ~= [ ch ] -> length s = 1; + bool_eq_char : forall s s' ch, s ~= [ ch ] -> s' ~= [ ch ] -> s =s s'; + is_char_Proper :> Proper (beq ==> eq ==> eq) is_char; + length_Proper :> Proper (beq ==> eq) length; + take_Proper :> Proper (eq ==> beq ==> beq) take; + drop_Proper :> Proper (eq ==> beq ==> beq) drop; + bool_eq_Equivalence :> Equivalence beq; + bool_eq_empty : forall str str', length str = 0 -> length str' = 0 -> str =s str'; + take_short_length : forall str n, n <= length str -> length (take n str) = n; + take_long : forall str n, length str <= n -> take n str =s str; + take_take : forall str n m, take n (take m str) =s take (min n m) str; + drop_length : forall str n, length (drop n str) = length str - n; + drop_0 : forall str, drop 0 str =s str; + drop_drop : forall str n m, drop n (drop m str) =s drop (n + m) str; + drop_take : forall str n m, drop n (take m str) =s take (m - n) (drop n str); + take_drop : forall str n m, take n (drop m str) =s drop m (take (n + m) str); + bool_eq_from_get : forall str str', (forall n, get n str = get n str') -> str =s str' + }. +Global Arguments StringLikeProperties _ {_}. +End StringLike. + +End Core. + +End StringLike. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. + +Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Core. +Import Coq.Strings.String. +Import Coq.Lists.List. +Export Fiat.Parsers.StringLike.Core. + +Section cfg. + Context {Char : Type}. + + Section definitions. + + Inductive item := + | Terminal (_ : Char) + | NonTerminal (_ : string). + + Definition production := list item. + Definition productions := list production. + + Record grammar := + { + Start_symbol :> string; + Lookup :> string -> productions; + Start_productions :> productions := Lookup Start_symbol; + Valid_nonterminals : list string; + Valid_productions : list productions := map Lookup Valid_nonterminals + }. + End definitions. + + End cfg. + +Arguments item _ : clear implicits. +Arguments production _ : clear implicits. +Arguments productions _ : clear implicits. +Arguments grammar _ : clear implicits. + +End Core. + +End ContextFreeGrammar. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. + +Module Export Fiat_DOT_Parsers_DOT_BaseTypes. +Module Export Fiat. +Module Export Parsers. +Module Export BaseTypes. +Import Coq.Arith.Wf_nat. + +Local Coercion is_true : bool >-> Sortclass. + +Section recursive_descent_parser. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + + Class parser_computational_predataT := + { nonterminals_listT : Type; + nonterminal_carrierT : Type; + of_nonterminal : String.string -> nonterminal_carrierT; + to_nonterminal : nonterminal_carrierT -> String.string; + initial_nonterminals_data : nonterminals_listT; + nonterminals_length : nonterminals_listT -> nat; + is_valid_nonterminal : nonterminals_listT -> nonterminal_carrierT -> bool; + remove_nonterminal : nonterminals_listT -> nonterminal_carrierT -> nonterminals_listT }. + + Class parser_removal_dataT' `{predata : parser_computational_predataT} := + { nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop + := ltof _ nonterminals_length; + nonterminals_length_zero : forall ls, + nonterminals_length ls = 0 + -> forall nt, is_valid_nonterminal ls nt = false; + remove_nonterminal_dec : forall ls nonterminal, + is_valid_nonterminal ls nonterminal + -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls; + remove_nonterminal_noninc : forall ls nonterminal, + ~nonterminals_listT_R ls (remove_nonterminal ls nonterminal); + initial_nonterminals_correct : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) <-> List.In nonterminal (Valid_nonterminals G); + initial_nonterminals_correct' : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data nonterminal <-> List.In (to_nonterminal nonterminal) (Valid_nonterminals G); + to_of_nonterminal : forall nonterminal, + List.In nonterminal (Valid_nonterminals G) + -> to_nonterminal (of_nonterminal nonterminal) = nonterminal; + of_to_nonterminal : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data nonterminal + -> of_nonterminal (to_nonterminal nonterminal) = nonterminal; + ntl_wf : well_founded nonterminals_listT_R + := well_founded_ltof _ _; + remove_nonterminal_1 + : forall ls ps ps', + is_valid_nonterminal (remove_nonterminal ls ps) ps' + -> is_valid_nonterminal ls ps'; + remove_nonterminal_2 + : forall ls ps ps', + is_valid_nonterminal (remove_nonterminal ls ps) ps' = false + <-> is_valid_nonterminal ls ps' = false \/ ps = ps' }. + + Class split_dataT := + { split_string_for_production + : item Char -> production Char -> String -> list nat }. + + Class boolean_parser_dataT := + { predata :> parser_computational_predataT; + split_data :> split_dataT }. +End recursive_descent_parser. + +End BaseTypes. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_BaseTypes. + +Module Export Fiat_DOT_Common_DOT_List_DOT_Operations. +Module Export Fiat. +Module Export Common. +Module Export List. +Module Export Operations. + +Import Coq.Lists.List. + +Module Export List. + Section InT. + Context {A : Type} (a : A). + + Fixpoint InT (ls : list A) : Set + := match ls return Set with + | nil => False + | b :: m => (b = a) + InT m + end%type. + End InT. + + End List. + +End Operations. + +End List. + +End Common. + +End Fiat. + +End Fiat_DOT_Common_DOT_List_DOT_Operations. + +Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. +Module Export Fiat. +Module Export Parsers. +Module Export StringLike. +Module Export Properties. + +Section String. + Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}. + + Lemma take_length {str n} + : length (take n str) = min n (length str). +admit. +Defined. + + End String. + +End Properties. + +End StringLike. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. + +Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Properties. + +Local Open Scope list_scope. +Definition production_is_reachableT {Char} (G : grammar Char) (p : production Char) + := { nt : _ + & { prefix : _ + & List.In nt (Valid_nonterminals G) + * List.InT + (prefix ++ p) + (Lookup G nt) } }%type. + +End Properties. + +End ContextFreeGrammar. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. + +Module Export Fiat_DOT_Parsers_DOT_MinimalParse. +Module Export Fiat. +Module Export Parsers. +Module Export MinimalParse. +Import Coq.Lists.List. +Import Fiat.Parsers.ContextFreeGrammar.Core. + +Local Coercion is_true : bool >-> Sortclass. +Local Open Scope string_like_scope. + +Section cfg. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + Context {predata : @parser_computational_predataT} + {rdata' : @parser_removal_dataT' _ G predata}. + + Inductive minimal_parse_of + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + productions Char -> Type := + | MinParseHead : forall len0 valid str pat pats, + @minimal_parse_of_production len0 valid str pat + -> @minimal_parse_of len0 valid str (pat::pats) + | MinParseTail : forall len0 valid str pat pats, + @minimal_parse_of len0 valid str pats + -> @minimal_parse_of len0 valid str (pat::pats) + with minimal_parse_of_production + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + production Char -> Type := + | MinParseProductionNil : forall len0 valid str, + length str = 0 + -> @minimal_parse_of_production len0 valid str nil + | MinParseProductionCons : forall len0 valid str n pat pats, + length str <= len0 + -> @minimal_parse_of_item len0 valid (take n str) pat + -> @minimal_parse_of_production len0 valid (drop n str) pats + -> @minimal_parse_of_production len0 valid str (pat::pats) + with minimal_parse_of_item + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + item Char -> Type := + | MinParseTerminal : forall len0 valid str ch, + str ~= [ ch ] + -> @minimal_parse_of_item len0 valid str (Terminal ch) + | MinParseNonTerminal + : forall len0 valid str (nt : String.string), + @minimal_parse_of_nonterminal len0 valid str nt + -> @minimal_parse_of_item len0 valid str (NonTerminal nt) + with minimal_parse_of_nonterminal + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + String.string -> Type := + | MinParseNonTerminalStrLt + : forall len0 valid (nt : String.string) str, + length str < len0 + -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) + -> @minimal_parse_of (length str) initial_nonterminals_data str (Lookup G nt) + -> @minimal_parse_of_nonterminal len0 valid str nt + | MinParseNonTerminalStrEq + : forall len0 str valid nonterminal, + length str = len0 + -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) + -> is_valid_nonterminal valid (of_nonterminal nonterminal) + -> @minimal_parse_of len0 (remove_nonterminal valid (of_nonterminal nonterminal)) str (Lookup G nonterminal) + -> @minimal_parse_of_nonterminal len0 valid str nonterminal. + +End cfg. + +End MinimalParse. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_MinimalParse. + +Module Export Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. +Module Export Fiat. +Module Export Parsers. +Module Export CorrectnessBaseTypes. +Import Coq.Lists.List. +Import Fiat.Parsers.ContextFreeGrammar.Core. +Import Fiat_DOT_Common.Fiat.Common. +Section general. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + + Definition split_list_completeT_for {data : @parser_computational_predataT} + {len0 valid} + (it : item Char) (its : production Char) + (str : String) + (pf : length str <= len0) + (split_list : list nat) + + := ({ n : nat + & (minimal_parse_of_item (G := G) (predata := data) len0 valid (take n str) it) + * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type) + -> ({ n : nat + & (In (min (length str) n) (map (min (length str)) split_list)) + * (minimal_parse_of_item (G := G) len0 valid (take n str) it) + * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type). + + Definition split_list_completeT {data : @parser_computational_predataT} + (splits : item Char -> production Char -> String -> list nat) + := forall len0 valid str (pf : length str <= len0) nt, + is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) + -> ForallT + (Forall_tails + (fun prod + => match prod return Type with + | nil => True + | it::its + => @split_list_completeT_for data len0 valid it its str pf (splits it its str) + end)) + (Lookup G nt). + + Class boolean_parser_completeness_dataT' {data : boolean_parser_dataT} := + { split_string_for_production_complete + : split_list_completeT split_string_for_production }. +End general. + +End CorrectnessBaseTypes. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. + +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Valid. +Export Fiat.Parsers.StringLike.Core. + +Section cfg. + Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) + {predata : parser_computational_predataT}. + + Definition item_valid (it : item Char) + := match it with + | Terminal _ => True + | NonTerminal nt' => is_true (is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt')) + end. + + Definition production_valid pat + := List.Forall item_valid pat. + + Definition productions_valid pats + := List.Forall production_valid pats. + + Definition grammar_valid + := forall nt, + List.In nt (Valid_nonterminals G) + -> productions_valid (Lookup G nt). +End cfg. + +End Valid. + +Section app. + Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) + {predata : parser_computational_predataT}. + + Lemma hd_production_valid + (it : item Char) + (its : production Char) + (H : production_valid (it :: its)) + : item_valid it. +admit. +Defined. + + Lemma production_valid_cons + (it : item Char) + (its : production Char) + (H : production_valid (it :: its)) + : production_valid its. +admit. +Defined. + + End app. + +Import Coq.Lists.List. +Import Coq.omega.Omega. +Import Fiat_DOT_Common.Fiat.Common. +Import Fiat.Parsers.ContextFreeGrammar.Valid. +Local Open Scope string_like_scope. + +Section recursive_descent_parser. + Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char). + Context {data : @boolean_parser_dataT Char _} + {cdata : @boolean_parser_completeness_dataT' Char _ G data} + {rdata : @parser_removal_dataT' _ G _} + {gvalid : grammar_valid G}. + + Local Notation dec T := (T + (T -> False))%type (only parsing). + + Local Notation iffT x y := ((x -> y) * (y -> x))%type (only parsing). + + Lemma dec_prod {A B} (HA : dec A) (HB : dec B) : dec (A * B). +admit. +Defined. + + Lemma dec_In {A} {P : A -> Type} (HA : forall a, dec (P a)) ls + : dec { a : _ & (In a ls * P a) }. +admit. +Defined. + + Section item. + Context {len0 valid} + (str : String) + (str_matches_nonterminal' + : nonterminal_carrierT -> bool) + (str_matches_nonterminal + : forall nt : nonterminal_carrierT, + dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). + + Section valid. + Context (Hmatches + : forall nt, + is_valid_nonterminal initial_nonterminals_data nt + -> str_matches_nonterminal nt = str_matches_nonterminal' nt :> bool) + (it : item Char) + (Hvalid : item_valid it). + + Definition parse_item' + : dec (minimal_parse_of_item (G := G) len0 valid str it). + Proof. + clear Hvalid. + refine (match it return dec (minimal_parse_of_item len0 valid str it) with + | Terminal ch => if Sumbool.sumbool_of_bool (str ~= [ ch ]) + then inl (MinParseTerminal _ _ _ _ _) + else inr (fun _ => !) + | NonTerminal nt => if str_matches_nonterminal (of_nonterminal nt) + then inl (MinParseNonTerminal _) + else inr (fun _ => !) + end); + clear str_matches_nonterminal Hmatches; + admit. + Defined. + End valid. + + End item. + Context {len0 valid} + (parse_nonterminal + : forall (str : String) (len : nat) (Hlen : length str = len) (pf : len <= len0) (nt : nonterminal_carrierT), + dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). + + Lemma dec_in_helper {ls it its str} + : iffT {n0 : nat & + (In (min (length str) n0) (map (min (length str)) ls) * + minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} + {n0 : nat & + (In n0 ls * + (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its))%type}. +admit. +Defined. + + Lemma parse_production'_helper {str it its} (pf : length str <= len0) + : dec {n0 : nat & + (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} + -> dec (minimal_parse_of_production (G := G) len0 valid str (it :: its)). +admit. +Defined. + Local Ltac t_parse_production_for := repeat + match goal with + | [ H : (beq_nat _ _) = true |- _ ] => apply EqNat.beq_nat_true in H + | _ => progress subst + | _ => solve [ constructor; assumption ] + | [ H : minimal_parse_of_production _ _ _ nil |- _ ] => (inversion H; clear H) + | [ H : minimal_parse_of_production _ _ _ (_::_) |- _ ] => (inversion H; clear H) + | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H' + | _ => progress simpl in * + | _ => discriminate + | [ H : forall x, (_ * _)%type -> _ |- _ ] => specialize (fun x y z => H x (y, z)) + | _ => solve [ eauto with nocore ] + | _ => solve [ apply Min.min_case_strong; omega ] + | _ => omega + | [ H : production_valid (_::_) |- _ ] + => let H' := fresh in + pose proof H as H'; + apply production_valid_cons in H; + apply hd_production_valid in H' + end. + + Definition parse_production'_for + (splits : item Char -> production Char -> String -> list nat) + (Hsplits : forall str it its (Hreachable : production_is_reachableT G (it::its)) pf', split_list_completeT_for (len0 := len0) (G := G) (valid := valid) it its str pf' (splits it its str)) + (str : String) + (len : nat) + (Hlen : length str = len) + (pf : len <= len0) + (prod : production Char) + (Hreachable : production_is_reachableT G prod) + : dec (minimal_parse_of_production (G := G) len0 valid str prod). + Proof. + revert prod Hreachable str len Hlen pf. + refine + ((fun pf_helper => + list_rect + (fun prod => + forall (Hreachable : production_is_reachableT G prod) + (str : String) + (len : nat) + (Hlen : length str = len) + (pf : len <= len0), + dec (minimal_parse_of_production (G := G) len0 valid str prod)) + ( + fun Hreachable str len Hlen pf + => match Utils.dec (beq_nat len 0) with + | left H => inl _ + | right H => inr (fun p => _) + end) + (fun it its parse_production' Hreachable str len Hlen pf + => parse_production'_helper + _ + (let parse_item := (fun n pf => parse_item' (parse_nonterminal (take n str) (len := min n len) (eq_trans take_length (f_equal (min _) Hlen)) pf) it) in + let parse_item := (fun n => parse_item n (Min.min_case_strong n len (fun k => k <= len0) (fun Hlen => (Nat.le_trans _ _ _ Hlen pf)) (fun Hlen => pf))) in + let parse_production := (fun n => parse_production' (pf_helper it its Hreachable) (drop n str) (len - n) (eq_trans (drop_length _ _) (f_equal (fun x => x - _) Hlen)) (Nat.le_trans _ _ _ (Nat.le_sub_l _ _) pf)) in + match dec_In + (fun n => dec_prod (parse_item n) (parse_production n)) + (splits it its str) + with + | inl p => inl (existT _ (projT1 p) (snd (projT2 p))) + | inr p + => let pf' := (Nat.le_trans _ _ _ (Nat.eq_le_incl _ _ Hlen) pf) in + let H := (_ : split_list_completeT_for (G := G) (len0 := len0) (valid := valid) it its str pf' (splits it its str)) in + inr (fun p' => p (fst dec_in_helper (H p'))) + end) + )) _); + [ clear parse_nonterminal Hsplits splits rdata cdata + | clear parse_nonterminal Hsplits splits rdata cdata + | .. + | admit ]. + abstract t_parse_production_for. + abstract t_parse_production_for. + abstract t_parse_production_for. + abstract t_parse_production_for. + Defined. diff --git a/test-suite/bugs/closed/4462.v b/test-suite/bugs/closed/4462.v new file mode 100644 index 00000000..c680518c --- /dev/null +++ b/test-suite/bugs/closed/4462.v @@ -0,0 +1,7 @@ +Variables P Q : Prop. +Axiom pqrw : P <-> Q. + +Require Setoid. + +Goal P -> Q. +unshelve (rewrite pqrw). diff --git a/test-suite/bugs/closed/4467.v b/test-suite/bugs/closed/4467.v new file mode 100644 index 00000000..6f8631d4 --- /dev/null +++ b/test-suite/bugs/closed/4467.v @@ -0,0 +1,15 @@ +(* Fixing missing test for variable shadowing *) + +Definition test (x y:bool*bool) := + match x with + | (e as e1, (true) as e2) + | ((true) as e1, e as e2) => + let '(e, b) := y in + e + | _ => true + end. + +Goal test (true,false) (true,true) = true. +(* used to evaluate to "false = true" in 8.4 *) +reflexivity. +Qed. diff --git a/test-suite/bugs/closed/4480.v b/test-suite/bugs/closed/4480.v new file mode 100644 index 00000000..08a86330 --- /dev/null +++ b/test-suite/bugs/closed/4480.v @@ -0,0 +1,12 @@ +Require Import Setoid. + +Definition proj (P Q : Prop) := P. + +Lemma foo (P : Prop) : proj P P = P. +Admitted. +Lemma trueI : True <-> True. +Admitted. +Goal True. + Fail setoid_rewrite foo. + Fail setoid_rewrite trueI. + \ No newline at end of file diff --git a/test-suite/bugs/closed/4484.v b/test-suite/bugs/closed/4484.v new file mode 100644 index 00000000..f988539d --- /dev/null +++ b/test-suite/bugs/closed/4484.v @@ -0,0 +1,10 @@ +(* Testing 8.5 regression with type classes not solving evars + redefined while trying to solve them with the type class mechanism *) + +Class A := {}. +Axiom foo : forall {ac : A}, bool. +Lemma bar (ac : A) : True. +Check (match foo as k return foo = k -> True with + | true => _ + | false => _ + end eq_refl). diff --git a/test-suite/bugs/closed/931.v b/test-suite/bugs/closed/931.v index e86b3be6..ea3347a8 100644 --- a/test-suite/bugs/closed/931.v +++ b/test-suite/bugs/closed/931.v @@ -2,6 +2,6 @@ Parameter P : forall n : nat, n=n -> Prop. Goal Prop. refine (P _ _). - 2:instantiate (1:=0). + instantiate (1:=0). trivial. Qed. diff --git a/test-suite/bugs/closed/HoTT_coq_077.v b/test-suite/bugs/closed/HoTT_coq_077.v index db3b60ed..017780c1 100644 --- a/test-suite/bugs/closed/HoTT_coq_077.v +++ b/test-suite/bugs/closed/HoTT_coq_077.v @@ -30,7 +30,7 @@ Definition prod_rect' A B (P : prod A B -> Type) (u : forall (fst : A) (snd : B) (p : prod A B) : P p := u (fst p) (snd p). -Notation typeof x := ($(let T := type of x in exact T)$) (only parsing). +Notation typeof x := (ltac:(let T := type of x in exact T)) (only parsing). (* Check for eta *) Check eq_refl : typeof (@prod_rect) = typeof (@prod_rect'). diff --git a/test-suite/bugs/closed/HoTT_coq_090.v b/test-suite/bugs/closed/HoTT_coq_090.v index 5fa16703..d77b9b63 100644 --- a/test-suite/bugs/closed/HoTT_coq_090.v +++ b/test-suite/bugs/closed/HoTT_coq_090.v @@ -84,7 +84,7 @@ Arguments transport {A} P {x y} p%path_scope u : simpl nomatch. Instance isequiv_path {A B : Type} (p : A = B) : IsEquiv (transport (fun X:Type => X) p) | 0. Proof. - refine (@BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) _ _ _); + unshelve refine (@BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) _ _ _); admit. Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_114.v b/test-suite/bugs/closed/HoTT_coq_114.v index 34112833..3535e6c4 100644 --- a/test-suite/bugs/closed/HoTT_coq_114.v +++ b/test-suite/bugs/closed/HoTT_coq_114.v @@ -1 +1 @@ -Inductive test : $(let U := type of Type in exact U)$ := t. +Inductive test : ltac:(let U := type of Type in exact U) := t. diff --git a/test-suite/bugs/opened/3248.v b/test-suite/bugs/opened/3248.v index 9e7d1eb5..33c408a2 100644 --- a/test-suite/bugs/opened/3248.v +++ b/test-suite/bugs/opened/3248.v @@ -3,7 +3,7 @@ Ltac ret_and_left f := let T := type of f in lazymatch eval hnf in T with | ?T' -> _ => - let ret := constr:(fun x' : T' => $(tac (f x'))$) in + let ret := constr:(fun x' : T' => ltac:(tac (f x'))) in exact ret | ?T' => exact f end. @@ -12,6 +12,6 @@ Goal forall A B : Prop, forall x y : A, True. Proof. intros A B x y. pose (f := fun (x y : A) => conj x y). - pose (a := $(ret_and_left f)$). + pose (a := ltac:(ret_and_left f)). Fail unify (a x y) (conj x y). Abort. diff --git a/test-suite/bugs/opened/3277.v b/test-suite/bugs/opened/3277.v index 19ed787d..5f423136 100644 --- a/test-suite/bugs/opened/3277.v +++ b/test-suite/bugs/opened/3277.v @@ -4,4 +4,4 @@ Goal True. evarr _. Admitted. Goal True. - Fail exact $(evarr _)$. (* Error: Cannot infer this placeholder. *) + Fail exact ltac:(evarr _). (* Error: Cannot infer this placeholder. *) diff --git a/test-suite/bugs/opened/3278.v b/test-suite/bugs/opened/3278.v index ced535af..1c6deae9 100644 --- a/test-suite/bugs/opened/3278.v +++ b/test-suite/bugs/opened/3278.v @@ -1,8 +1,8 @@ Module a. Check let x' := _ in - $(exact x')$. + ltac:(exact x'). - Notation foo x := (let x' := x in $(exact x')$). + Notation foo x := (let x' := x in ltac:(exact x')). Fail Check foo _. (* Error: Cannot infer an internal placeholder of type "Type" in environment: @@ -12,10 +12,10 @@ x' := ?42 : ?41 End a. Module b. - Notation foo x := (let x' := x in let y := ($(exact I)$ : True) in I). + Notation foo x := (let x' := x in let y := (ltac:(exact I) : True) in I). Notation bar x := (let x' := x in let y := (I : True) in I). - Check let x' := _ in $(exact I)$. (* let x' := ?5 in I *) + Check let x' := _ in ltac:(exact I). (* let x' := ?5 in I *) Check bar _. (* let x' := ?9 in let y := I in I *) Fail Check foo _. (* Error: Cannot infer an internal placeholder of type "Type" in environment: diff --git a/test-suite/bugs/opened/3304.v b/test-suite/bugs/opened/3304.v index 529cc737..66668930 100644 --- a/test-suite/bugs/opened/3304.v +++ b/test-suite/bugs/opened/3304.v @@ -1,3 +1,3 @@ -Fail Notation "( x , y , .. , z )" := $(let r := constr:(prod .. (prod x y) .. z) in r)$. +Fail Notation "( x , y , .. , z )" := ltac:(let r := constr:(prod .. (prod x y) .. z) in r). (* The command has indeed failed with message: => Error: Special token .. is for use in the Notation command. *) diff --git a/test-suite/bugs/opened/3459.v b/test-suite/bugs/opened/3459.v index 9e6107b3..762611f7 100644 --- a/test-suite/bugs/opened/3459.v +++ b/test-suite/bugs/opened/3459.v @@ -7,9 +7,9 @@ Proof. (* This line used to fail with a Not_found up to some point, and then to produce an ill-typed term *) match goal with - | [ |- context G[2] ] => let y := constr:(fun x => $(let r := constr:(@eq Set x x) in + | [ |- context G[2] ] => let y := constr:(fun x => ltac:(let r := constr:(@eq Set x x) in clear x; - exact r)$) in + exact r)) in pose y end. (* Add extra test for typability (should not fail when bug closed) *) diff --git a/test-suite/bugs/opened/3554.v b/test-suite/bugs/opened/3554.v deleted file mode 100644 index 422c5770..00000000 --- a/test-suite/bugs/opened/3554.v +++ /dev/null @@ -1 +0,0 @@ -Fail Example foo (f : forall {_ : Type}, Type) : Type. diff --git a/test-suite/bugs/opened/3848.v b/test-suite/bugs/opened/3848.v deleted file mode 100644 index a03e8ffd..00000000 --- a/test-suite/bugs/opened/3848.v +++ /dev/null @@ -1,22 +0,0 @@ -Require Import TestSuite.admit. -Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. -Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). -Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. -Class IsEquiv {A B} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. -Arguments eisretr {A B} f {_} _. -Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'"). -Generalizable Variables A B f g e n. -Definition functor_forall `{P : A -> Type} `{Q : B -> Type} - (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) -: (forall a:A, P a) -> (forall b:B, Q b). - admit. -Defined. - -Lemma isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type} - `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} -: (forall b : B, Q b) -> forall a : A, P a. -Proof. - refine (functor_forall - (f^-1) - (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). -Fail Defined. (* Error: Attempt to save an incomplete proof *) diff --git a/test-suite/complexity/f_equal.v b/test-suite/complexity/f_equal.v new file mode 100644 index 00000000..86698fa8 --- /dev/null +++ b/test-suite/complexity/f_equal.v @@ -0,0 +1,14 @@ +(* Checks that f_equal does not reduce the term uselessly *) +(* Expected time < 1.00s *) + +Fixpoint stupid (n : nat) : unit := +match n with +| 0 => tt +| S n => + let () := stupid n in + let () := stupid n in + tt +end. + +Goal stupid 23 = stupid 23. +Timeout 5 Time f_equal. diff --git a/test-suite/failure/Tauto.v b/test-suite/failure/Tauto.v index 749db000..d91d159d 100644 --- a/test-suite/failure/Tauto.v +++ b/test-suite/failure/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop) : Prop := - forall x : T, P x. - -Polymorphic Axiom todo : forall {T:Type}, T -> T. - -Polymorphic Definition todo' (T : Type) := @todo T. - -Definition _3 : @todo'@{Set} = @todo@{Set} := - @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. -*) - -(* Inductive Types *) -Inductive sumbool (A B : Prop) : Set := -| left : A -> sumbool A B -| right : B -> sumbool A B. - -Definition x : sumbool True False := left _ _ I. - -Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := - match H with - | left _ _ x => left _ _ x - | right _ _ x => right _ _ x - end. - -Definition _4 : sumbool_copy x = x := - @eq_refl _ x <: sumbool_copy x = x. - -(* Polymorphic Inductive Types *) -Polymorphic Inductive poption (T : Type@{i}) : Type@{i} := -| PSome : T -> poption@{i} T -| PNone : poption@{i} T. - -Polymorphic Definition poption_default {T : Type@{i}} (p : poption@{i} T) (x : T) : T := - match p with - | @PSome _ y => y - | @PNone _ => x - end. - -Polymorphic Inductive plist (T : Type@{i}) : Type@{i} := -| pnil -| pcons : T -> plist@{i} T -> plist@{i} T. - -Arguments pnil {_}. -Arguments pcons {_} _ _. - -Section pmap. - Context {T : Type@{i}} {U : Type@{j}} (f : T -> U). - - Polymorphic Fixpoint pmap (ls : plist@{i} T) : plist@{j} U := - match ls with - | @pnil _ => @pnil _ - | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls) - end. -End pmap. - -Universe Ubool. -Inductive tbool : Type@{Ubool} := ttrue | tfalse. - - -Eval vm_compute in pmap pid (pcons true (pcons false pnil)). -Eval vm_compute in pmap (fun x => match x with - | pnil => true - | pcons _ _ => false - end) (pcons pnil (pcons (pcons false pnil) pnil)). -Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). - -Polymorphic Inductive Tree (T : Type@{i}) : Type@{i} := -| Empty -| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. - -Section pfold. - Context {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U). - - Polymorphic Fixpoint pfold (acc : U) (ls : plist@{i} T) : U := - match ls with - | pnil => acc - | pcons a b => pfold (f a acc) b - end. -End pfold. - -Polymorphic Inductive nat : Type@{i} := -| O -| S : nat -> nat. - -Fixpoint nat_max (a b : nat) : nat := - match a , b with - | O , b => b - | a , O => a - | S a , S b => S (nat_max a b) - end. - -Polymorphic Fixpoint height {T : Type@{i}} (t : Tree@{i} T) : nat := - match t with - | Empty _ => O - | Branch _ ls => S (pfold nat_max O (pmap height ls)) - end. - -Polymorphic Fixpoint repeat {T : Type@{i}} (n : nat) (v : T) : plist@{i} T := - match n with - | O => pnil - | S n => pcons v (repeat n v) - end. - -Polymorphic Fixpoint big_tree (n : nat) : Tree@{i} nat := - match n with - | O => @Empty nat - | S n' => Branch _ (repeat n' (big_tree n')) - end. - -Eval compute in height (big_tree (S (S (S O)))). - -Let big := S (S (S (S (S O)))). -Polymorphic Definition really_big := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). - -Time Definition _5 : height (@Empty nat) = O := - @eq_refl nat O <: height (@Empty nat) = O. - -Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := - @eq_refl nat@{Set} (S@{Set} O@{Set}) <: height@{Set} (@Branch nat pnil) = S O. - -Time Definition _7 : height (big_tree big) = big := - @eq_refl nat big <: height (big_tree big) = big. - -Time Definition _8 : height (big_tree really_big) = really_big := - @eq_refl nat@{Set} (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) - <: - @eq nat@{Set} - (@height nat@{Set} (big_tree really_big@{Set})) - really_big@{Set}. diff --git a/test-suite/misc/berardi_test.v b/test-suite/misc/berardi_test.v index 219686b9..a64db4da 100644 --- a/test-suite/misc/berardi_test.v +++ b/test-suite/misc/berardi_test.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool **) -let test2 b = +let test2 _ = False (** val wrong_id : 'a1 hole -> 'a2 hole **) diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v index ce9050d4..3c696502 100644 --- a/test-suite/success/Case22.v +++ b/test-suite/success/Case22.v @@ -17,3 +17,47 @@ Definition foo (x : I') : bool := match x with C' => true end. + +(* Bug found in november 2015: was wrongly failing in 8.5beta2 and 8.5beta3 *) + +Inductive I2 (A:Type) : let B:=A in forall C, let D:=(C*B)%type in Type := + E2 : I2 A nat. + +Check fun x:I2 nat nat => match x in I2 _ X Y Z return X*Y*Z with + E2 _ => (0,0,(0,0)) + end. + +(* This used to succeed in 8.3, 8.4 and 8.5beta1 *) + +Inductive IND : forall X:Type, let Y:=X in Type := + CONSTR : IND True. + +Definition F (x:IND True) (A:Type) := + (* This failed in 8.5beta2 though it should have been accepted *) + match x in IND X Y return Y with + CONSTR => Logic.I + end. + +Theorem paradox : False. + (* This succeeded in 8.3, 8.4 and 8.5beta1 because F had wrong type *) +Fail Proof (F C False). + +(* Another bug found in November 2015 (a substitution was wrongly + reversed at pretyping level) *) + +Inductive Ind (A:Type) : + let X:=A in forall Y:Type, let Z:=(X*Y)%type in Type := + Constr : Ind A nat. + +Check fun x:Ind bool nat => + match x in Ind _ X Y Z return Z with + | Constr _ => (true,0) + end. + +(* A vm_compute bug (the type of constructors was not supposed to + contain local definitions before proper parameters) *) + +Inductive Ind2 (b:=1) (c:nat) : Type := + Constr2 : Ind2 c. + +Eval vm_compute in Constr2 2. diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index e4266350..49c465b6 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -1861,3 +1861,10 @@ Type (fun n => match n with Definition transport {A} (P : A->Type) {x y : A} (p : x=y) (u : P x) : P y := match p with eq_refl => u end. + +(* Check in-pattern clauses with constant constructors, which were + previously interpreted as variables (before 8.5) *) + +Check match eq_refl 0 in _=O return O=O with eq_refl => eq_refl end. + +Check match niln in listn O return O=O with niln => eq_refl end. diff --git a/test-suite/success/Check.v b/test-suite/success/Check.v index 87c38cfa..e4ee351c 100644 --- a/test-suite/success/Check.v +++ b/test-suite/success/Check.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* match x with S (FORALL x, _) => 0 end. Parameter traverse : (nat -> unit) -> (nat -> unit). Notation traverse_var f l := (traverse (fun l => f l) l). + +(* Check that when an ident become a keyword, it does not break + previous rules relying on the string to be classified as an ident *) + +Notation "'intros' x" := (S x) (at level 0). +Goal True -> True. intros H. exact H. Qed. diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v index 01d9afb4..767f15be 100644 --- a/test-suite/success/Tauto.v +++ b/test-suite/success/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Type := +| d0 : dnat 0 +| ds : forall n m, n = m -> dnat n -> dnat (S n). + +Extraction Implicit ds [m]. + +Lemma dnat_nat: forall n, dnat n -> nat. +Proof. + intros n d. + induction d as [| n m Heq d IHn]. + exact 0. exact (S IHn). +Defined. + +Recursive Extraction dnat_nat. + +Extraction Implicit dnat_nat [n]. +Recursive Extraction dnat_nat. + +(** Same, with a Fixpoint *) + +Fixpoint dnat_nat' n (d:dnat n) := + match d with + | d0 => 0 + | ds n m _ d => S (dnat_nat' n d) + end. + +Recursive Extraction dnat_nat'. + +Extraction Implicit dnat_nat' [n]. +Recursive Extraction dnat_nat'. + +(** Bug #4243, part 2 *) + +Inductive enat: nat -> Type := + e0: enat 0 +| es: forall n, enat n -> enat (S n). + +Lemma enat_nat: forall n, enat n -> nat. +Proof. + intros n e. + induction e as [| n e IHe]. + exact (O). + exact (S IHe). +Defined. + +Extraction Implicit es [n]. +Extraction Implicit enat_nat [n]. +Recursive Extraction enat_nat. + +(** Same, with a Fixpoint *) + +Fixpoint enat_nat' n (e:enat n) : nat := + match e with + | e0 => 0 + | es n e => S (enat_nat' n e) + end. + +Extraction Implicit enat_nat' [n]. +Recursive Extraction enat_nat'. + +(** Bug #4228 *) + +Module Food. +Inductive Course := +| main: nat -> Course +| dessert: nat -> Course. + +Inductive Meal : Course -> Type := +| one_course : forall n:nat, Meal (main n) +| two_course : forall n m, Meal (main n) -> Meal (dessert m). +Extraction Implicit two_course [n]. +End Food. + +Recursive Extraction Food.Meal. diff --git a/test-suite/success/inds_type_sec.v b/test-suite/success/inds_type_sec.v index b733aef6..c729b23c 100644 --- a/test-suite/success/inds_type_sec.v +++ b/test-suite/success/inds_type_sec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0=0) -> True /\ False -> 0=0. -intros H (H1/H,_). +intros H (H1%H,_). exact H1. Qed. (* A test about bugs in 8.5beta2 *) Goal (True -> 0=0) -> True /\ False -> False -> 0=0. intros H H0 H1. -destruct H0 as (a/H,_). +destruct H0 as (a%H,_). (* Check that H0 is removed (was bugged in 8.5beta2) *) Fail clear H0. -(* Check position of newly created hypotheses when using pat/c (was +(* Check position of newly created hypotheses when using pat%c (was left at top in 8.5beta2) *) match goal with H:_ |- _ => clear H end. (* clear H1:False *) match goal with H:_ |- _ => exact H end. (* check that next hyp shows 0=0 *) Qed. Goal (True -> 0=0) -> True -> 0=0. -intros H H1/H. +intros H H1%H. exact H1. Qed. Goal forall n, n = S n -> 0=0. -intros n H/n_Sn. +intros n H%n_Sn. destruct H. Qed. (* Another check about generated names and cleared hypotheses with - pat/c patterns *) + pat%c patterns *) Goal (True -> 0=0 /\ 1=1) -> True -> 0=0. -intros H (H1,?)/H. +intros H (H1,?)%H. change (1=1) in H0. exact H1. Qed. + +(* Checking iterated pat%c1...%cn introduction patterns and side conditions *) + +Goal forall A B C D:Prop, (A -> B -> C) -> (C -> D) -> B -> A -> D. +intros * H H0 H1. +intros H2%H%H0. +- exact H2. +- exact H1. +Qed. + +(* Bug found by Enrico *) + +Goal forall x : nat, True. +intros y%(fun x => x). +Abort. diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index bbe9d4bf..5b0502cf 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -22,3 +22,40 @@ Qed. Print Equivalent Keys. End foo. + +Require Import Arith List Omega. + +Definition G {A} (f : A -> A -> A) (x : A) := f x x. + +Lemma list_foo A (l : list A) : G (@app A) (l ++ nil) = G (@app A) l. +Proof. unfold G; rewrite app_nil_r; reflexivity. Qed. + +(* Bundled version of a magma *) +Structure magma := Magma { b_car :> Type; op : b_car -> b_car -> b_car }. +Arguments op {_} _ _. + +(* Instance for lists *) +Canonical Structure list_magma A := Magma (list A) (@app A). + +(* Basically like list_foo, but now uses the op projection instead of app for +the argument of G *) +Lemma test1 A (l : list A) : G op (l ++ nil) = G op l. + +(* Ensure that conversion of terms with evars is allowed once a keyed candidate unifier is found *) +rewrite -> list_foo. +reflexivity. +Qed. + +(* Basically like list_foo, but now uses the op projection for everything *) +Lemma test2 A (l : list A) : G op (op l nil) = G op l. +Proof. +rewrite ->list_foo. +reflexivity. +Qed. + + Require Import Bool. + Set Keyed Unification. + + Lemma test b : b && true = b. + Fail rewrite andb_true_l. + Admitted. \ No newline at end of file diff --git a/test-suite/success/mutual_ind.v b/test-suite/success/mutual_ind.v index 54cfa658..45c1a5e5 100644 --- a/test-suite/success/mutual_ind.v +++ b/test-suite/success/mutual_ind.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* eq_refl. Definition RLRL' : forall x : R, RL x = RL (RL x). intros. apply eq_refl. diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v index 125615c5..281d707c 100644 --- a/test-suite/success/primitiveproj.v +++ b/test-suite/success/primitiveproj.v @@ -194,4 +194,17 @@ Record wrap (A : Type) := { unwrap : A; unwrap2 : A }. Definition term (x : wrap nat) := x.(unwrap). Definition term' (x : wrap nat) := let f := (@unwrap2 nat) in f x. Recursive Extraction term term'. -(*Unset Printing Primitive Projection Parameters.*) \ No newline at end of file +(*Unset Printing Primitive Projection Parameters.*) + +(* Primitive projections in the presence of let-ins (was not failing in beta3)*) + +Set Primitive Projections. +Record s (x:nat) (y:=S x) := {c:=x; d:x=c}. +Lemma f : 0=1. +Proof. +Fail apply d. +(* +split. +reflexivity. +Qed. +*) diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v index c83f45e2..adaa05ad 100644 --- a/test-suite/success/proof_using.v +++ b/test-suite/success/proof_using.v @@ -178,6 +178,7 @@ End Let. Check (test_let 3). +(* Disabled Section Clear. Variable a: nat. @@ -192,6 +193,6 @@ trivial. Qed. End Clear. - +*) diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v index 1e667884..352abb2a 100644 --- a/test-suite/success/refine.v +++ b/test-suite/success/refine.v @@ -62,7 +62,7 @@ Abort. Goal (forall n : nat, n = 0 -> Prop) -> Prop. intro P. refine (P _ _). -2:reflexivity. +reflexivity. Abort. (* Submitted by Jacek Chrzaszcz (bug #1102) *) diff --git a/test-suite/success/unfold.v b/test-suite/success/unfold.v index 2954e255..d595cbc2 100644 --- a/test-suite/success/unfold.v +++ b/test-suite/success/unfold.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + forall (i : unit), i = i -> True. + +Goal True. +Proof. +unshelve (refine (F _ _ _ _)). ++ exact true. ++ exact tt. ++ exact (@eq_refl bool true). ++ exact (@eq_refl unit tt). +Qed. diff --git a/test-suite/success/vm_univ_poly.v b/test-suite/success/vm_univ_poly.v new file mode 100644 index 00000000..58fa3974 --- /dev/null +++ b/test-suite/success/vm_univ_poly.v @@ -0,0 +1,141 @@ +(* Basic tests *) +Polymorphic Definition pid {T : Type} (x : T) : T := x. +(* +Definition _1 : pid true = true := + @eq_refl _ true <: pid true = true. + +Polymorphic Definition a_type := Type. + +Definition _2 : a_type@{i} = Type@{i} := + @eq_refl _ Type@{i} <: a_type@{i} = Type@{i}. + +Polymorphic Definition FORALL (T : Type) (P : T -> Prop) : Prop := + forall x : T, P x. + +Polymorphic Axiom todo : forall {T:Type}, T -> T. + +Polymorphic Definition todo' (T : Type) := @todo T. + +Definition _3 : @todo'@{Set} = @todo@{Set} := + @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. +*) + +(* Inductive Types *) +Inductive sumbool (A B : Prop) : Set := +| left : A -> sumbool A B +| right : B -> sumbool A B. + +Definition x : sumbool True False := left _ _ I. + +Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := + match H with + | left _ _ x => left _ _ x + | right _ _ x => right _ _ x + end. + +Definition _4 : sumbool_copy x = x := + @eq_refl _ x <: sumbool_copy x = x. + +(* Polymorphic Inductive Types *) +Polymorphic Inductive poption@{i} (T : Type@{i}) : Type@{i} := +| PSome : T -> poption@{i} T +| PNone : poption@{i} T. + +Polymorphic Definition poption_default@{i} {T : Type@{i}} (p : poption@{i} T) (x : T) : T := + match p with + | @PSome _ y => y + | @PNone _ => x + end. + +Polymorphic Inductive plist@{i} (T : Type@{i}) : Type@{i} := +| pnil +| pcons : T -> plist@{i} T -> plist@{i} T. + +Arguments pnil {_}. +Arguments pcons {_} _ _. + +Polymorphic Definition pmap@{i j} + {T : Type@{i}} {U : Type@{j}} (f : T -> U) := + fix pmap (ls : plist@{i} T) : plist@{j} U := + match ls with + | @pnil _ => @pnil _ + | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls) + end. + +Universe Ubool. +Inductive tbool : Type@{Ubool} := ttrue | tfalse. + + +Eval vm_compute in pmap pid (pcons true (pcons false pnil)). +Eval vm_compute in pmap (fun x => match x with + | pnil => true + | pcons _ _ => false + end) (pcons pnil (pcons (pcons false pnil) pnil)). +Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). + +Polymorphic Inductive Tree@{i} (T : Type@{i}) : Type@{i} := +| Empty +| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. + +Polymorphic Definition pfold@{i u} + {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U) := + fix pfold (acc : U) (ls : plist@{i} T) : U := + match ls with + | pnil => acc + | pcons a b => pfold (f a acc) b + end. + +Polymorphic Inductive nat@{i} : Type@{i} := +| O +| S : nat -> nat. + +Polymorphic Fixpoint nat_max@{i} (a b : nat@{i}) : nat@{i} := + match a , b with + | O , b => b + | a , O => a + | S a , S b => S (nat_max a b) + end. + +Polymorphic Fixpoint height@{i} {T : Type@{i}} (t : Tree@{i} T) : nat@{i} := + match t return nat@{i} with + | Empty _ => O + | Branch _ ls => S@{i} (pfold@{i i} nat_max O (pmap height ls)) + end. + +Polymorphic Fixpoint repeat@{i} {T : Type@{i}} (n : nat@{i}) (v : T) : plist@{i} T := + match n return plist@{i} T with + | O => pnil + | S n => pcons@{i} v (repeat n v) + end. + +Polymorphic Fixpoint big_tree@{i} (n : nat@{i}) : Tree@{i} nat@{i} := + match n with + | O => @Empty nat@{i} + | S n' => Branch@{i} nat@{i} (repeat@{i} n' (big_tree@{i} n')) + end. + +Eval compute in height (big_tree (S (S (S O)))). + +Let big := S (S (S (S (S O)))). +Polymorphic Definition really_big@{i} := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). + +Time Definition _5 : height (@Empty nat) = O := + @eq_refl nat O <: height (@Empty nat) = O. + +Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := + @eq_refl nat@{Set} (S@{Set} O@{Set}) <: @eq nat@{Set} (height@{Set} (@Branch@{Set} nat@{Set} (@pnil@{Set} (Tree@{Set} nat@{Set})))) (S@{Set} O@{Set}). + +Time Definition _7 : height (big_tree big) = big := + @eq_refl nat big <: height (big_tree big) = big. + +Time Definition _8 : height (big_tree really_big) = really_big := + @eq_refl nat@{Set} (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) + <: + @eq nat@{Set} + (@height nat@{Set} (big_tree really_big@{Set})) + really_big@{Set}. diff --git a/test-suite/success/vm_univ_poly_match.v b/test-suite/success/vm_univ_poly_match.v new file mode 100644 index 00000000..abe6d0fe --- /dev/null +++ b/test-suite/success/vm_univ_poly_match.v @@ -0,0 +1,28 @@ +Set Dump Bytecode. +Set Printing Universes. +Set Printing All. + +Polymorphic Class Applicative@{d c} (T : Type@{d} -> Type@{c}) := +{ pure : forall {A : Type@{d}}, A -> T A + ; ap : forall {A B : Type@{d}}, T (A -> B) -> T A -> T B +}. + +Universes Uo Ua. + +Eval compute in @pure@{Uo Ua}. + +Global Instance Applicative_option : Applicative@{Uo Ua} option := +{| pure := @Some + ; ap := fun _ _ f x => + match f , x with + | Some f , Some x => Some (f x) + | _ , _ => None + end +|}. + +Definition foo := ap (ap (pure plus) (pure 1)) (pure 1). + +Print foo. + + +Eval vm_compute in foo. diff --git a/test-suite/typeclasses/NewSetoid.v b/test-suite/typeclasses/NewSetoid.v index 6f37de65..49f20a23 100644 --- a/test-suite/typeclasses/NewSetoid.v +++ b/test-suite/typeclasses/NewSetoid.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* A -> Prop) (RA ==> RA ==> iff) R) : - Proper (RA ==> RA ==> iff) (complement@{i j Prop} R) := _. - - Next Obligation. - Proof. - unfold complement. - pose (mR x y X x0 y0 X0). - intuition. - Qed. (** The [flip] too, actually the [flip] instance is a bit more general. *) Program Definition flip_proper @@ -521,8 +511,8 @@ Ltac proper_reflexive := Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. -Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper - : typeclass_instances. +(* Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper *) +(* : typeclass_instances. *) Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper : typeclass_instances. Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index 35b2b8a3..3d7ef01f 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* class_apply @subrelation_symmetric : typeclass_instances. Arguments irreflexivity {A R Irreflexive} [x] _. +Arguments symmetry {A} {R} {_} [x] [y] _. +Arguments asymmetry {A} {R} {_} [x] [y] _ _. +Arguments transitivity {A} {R} {_} [x] [y] [z] _ _. +Arguments Antisymmetric A eqA {_} _. Hint Resolve irreflexivity : ord. diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index f20100fe..4b133a4d 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* A->Prop)(st:Equivalence eqA) (f:key->elt->A->A)(i:A), diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 3eac15b0..9e59f0c5 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -1061,7 +1061,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End PositiveMap. -(** Here come some additionnal facts about this implementation. +(** Here come some additional facts about this implementation. Most are facts that cannot be derivable from the general interface. *) diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index de615301..4850c9ca 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* list B)(l:list A)(y:B), In y (flat_map f l) <-> exists x, In x l /\ In y (f x). Proof using A B. + clear Hfinjective. induction l; simpl; split; intros. contradiction. destruct H as (x,(H,_)); contradiction. diff --git a/theories/Lists/ListDec.v b/theories/Lists/ListDec.v index 8bd2daaf..3e2eeac0 100644 --- a/theories/Lists/ListDec.v +++ b/theories/Lists/ListDec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ~~P -> P) B _ in _). + unshelve (refine (let NB := exist (fun P=>~~P -> P) B _ in _)). { exact (fun _ => b1). } pose proof (NoRetractToNegativeProp.paradox NB p2b b2p (wp2p2 h) wp2p1) as paradox. - refine (let F := exist (fun P=>~~P->P) False _ in _). + unshelve (refine (let F := exist (fun P=>~~P->P) False _ in _)). { auto. } exact (paradox F). Qed. @@ -658,4 +658,3 @@ Proof. exists x; intro; exact Hx. exists x0; exact Hnot. Qed. - diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v index 4b0ec15e..57f367e5 100644 --- a/theories/Logic/ClassicalUniqueChoice.v +++ b/theories/Logic/ClassicalUniqueChoice.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ));cycle 1. + unshelve (refine ((fun h => _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ))). End Generic. @@ -319,77 +319,31 @@ Proof. + cbn. exact (fun u F => forall x:u, F x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. easy. + + cbn. exact (fun F => u22u1 (forall x, F x)). + cbn. exact (fun _ x => u22u1_unit _ x). + cbn. exact (fun _ x => u22u1_counit _ x). - + cbn. intros **. now rewrite u22u1_coherent. (** Small universe *) + exact U0. (** The interpretation of the small universe is the image of [U0] in [U1]. *) + cbn. exact (fun X => u02u1 X). + cbn. exact (fun u F => u12u0 (forall x:(u02u1 u), u02u1 (F x))). - + cbn. intros * x. exact (u12u0_unit _ x). - + cbn. intros * x. exact (u12u0_counit _ x). + cbn. exact (fun u F => u12u0 (forall x:u, u02u1 (F x))). - + cbn. intros * x. exact (u12u0_unit _ x). - + cbn. intros * x. exact (u12u0_counit _ x). + cbn. exact (u12u0 F). + cbn in h. exact (u12u0_counit _ h). -Qed. - -End Paradox. - -End NoRetractToImpredicativeUniverse. - -(** * Prop is not a retract *) - -(** The existence in the pure Calculus of Constructions of a retract - from [Prop] into a small type of [Prop] is inconsistent. This is a - special case of the previous result. *) - -Module NoRetractFromSmallPropositionToProp. - -Section Paradox. - -(** ** Retract of [Prop] in a small type *) - -(** The retract is axiomatized using logical equivalence as the - equality on propositions. *) - -Variable bool : Prop. -Variable p2b : Prop -> bool. -Variable b2p : bool -> Prop. -Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A. -Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A). - -(** ** Paradox *) - -Theorem paradox : forall B:Prop, B. -Proof. - intros B. - pose proof - (NoRetractToImpredicativeUniverse.paradox@{Type Prop}) as P. - refine (P _ _ _ _ _ _ _ _ _ _);clear P. - + exact bool. - + exact (fun x => forall P:Prop, (x->P)->P). - + cbn. exact (fun _ x P k => k x). - + cbn. intros F P x. - apply P. - intros f. - exact (f x). + cbn. easy. - + exact b2p. - + exact p2b. - + exact p2p2. - + exact p2p1. + + cbn. intros **. now rewrite u22u1_coherent. + + cbn. intros * x. exact (u12u0_unit _ x). + + cbn. intros * x. exact (u12u0_counit _ x). + + cbn. intros * x. exact (u12u0_unit _ x). + + cbn. intros * x. exact (u12u0_counit _ x). Qed. End Paradox. -End NoRetractFromSmallPropositionToProp. +End NoRetractToImpredicativeUniverse. (** * Modal fragments of [Prop] are not retracts *) @@ -428,7 +382,7 @@ Qed. Definition Forall {A:Type} (P:A->MProp) : MProp. Proof. - refine (exist _ _ _). + unshelve (refine (exist _ _ _)). + exact (forall x:A, El (P x)). + intros h x. eapply strength in h. @@ -458,27 +412,27 @@ Proof. + exact (fun _ => Forall). + cbn. exact (fun _ _ f => f). + cbn. exact (fun _ _ f => f). - + cbn. easy. + exact Forall. + cbn. exact (fun _ f => f). + cbn. exact (fun _ f => f). - + cbn. easy. (** Small universe *) + exact bool. + exact (fun b => El (b2p b)). + cbn. exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + + apply p2b. + exact B. + + cbn in h. auto. + + cbn. easy. + + cbn. easy. + cbn. auto. + cbn. intros * f. apply p2p1 in f. cbn in f. exact f. - + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + cbn. auto. + cbn. intros * f. apply p2p1 in f. cbn in f. exact f. - + apply p2b. - exact B. - + cbn in h. auto. Qed. End Paradox. @@ -516,23 +470,97 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). Theorem paradox : forall B:NProp, El B. Proof. intros B. - refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _));cycle 1. + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + exact (fun P => ~~P). + + exact bool. + + exact p2b. + + exact b2p. + + exact B. + + exact h. + cbn. auto. + cbn. auto. + cbn. auto. + + auto. + + auto. +Qed. + +End Paradox. + +End NoRetractToNegativeProp. + +(** * Prop is not a retract *) + +(** The existence in the pure Calculus of Constructions of a retract + from [Prop] into a small type of [Prop] is inconsistent. This is a + special case of the previous result. *) + +Module NoRetractFromSmallPropositionToProp. + +(** ** The universe of propositions. *) + +Definition NProp := { P:Prop | P -> P}. +Definition El : NProp -> Prop := @proj1_sig _ _. + +Section MParadox. + +(** ** Retract of [Prop] in a small type, using the identity modality. *) + +Variable bool : NProp. +Variable p2b : NProp -> El bool. +Variable b2p : El bool -> NProp. +Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A. +Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). + +(** ** Paradox *) + +Theorem mparadox : forall B:NProp, El B. +Proof. + intros B. + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + + exact (fun P => P). + exact bool. + exact p2b. + exact b2p. - + auto. - + auto. + exact B. + exact h. + + cbn. auto. + + cbn. auto. + + cbn. auto. + + auto. + + auto. +Qed. + +End MParadox. + +Section Paradox. + +(** ** Retract of [Prop] in a small type *) + +(** The retract is axiomatized using logical equivalence as the + equality on propositions. *) +Variable bool : Prop. +Variable p2b : Prop -> bool. +Variable b2p : bool -> Prop. +Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A. +Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A). + +(** ** Paradox *) + +Theorem paradox : forall B:Prop, B. +Proof. + intros B. + unshelve (refine (mparadox (exist _ bool (fun x => x)) _ _ _ _ + (exist _ B (fun x => x)))). + + intros p. red. red. exact (p2b (El p)). + + cbn. intros b. red. exists (b2p b). exact (fun x => x). + + cbn. intros [A H]. cbn. apply p2p1. + + cbn. intros [A H]. cbn. apply p2p2. Qed. End Paradox. -End NoRetractToNegativeProp. +End NoRetractFromSmallPropositionToProp. + (** * Large universes are no retracts of [Prop]. *) @@ -569,7 +597,6 @@ Proof. + cbn. exact (fun u F => forall x, F x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. easy. + exact (fun F => forall A:Prop, F(up A)). + cbn. exact (fun F f A => f (up A)). + cbn. @@ -577,20 +604,21 @@ Proof. specialize (f (down A)). rewrite up_down in f. exact f. + + exact Prop. + + cbn. exact (fun X => X). + + cbn. exact (fun A P => forall x:A, P x). + + cbn. exact (fun A P => forall x:A, P x). + + cbn. exact P. + + exact h. + + cbn. easy. + cbn. intros F f A. destruct (up_down A). cbn. reflexivity. - + exact Prop. - + cbn. exact (fun X => X). - + cbn. exact (fun A P => forall x:A, P x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. exact (fun A P => forall x:A, P x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. exact P. - + exact h. Qed. End Paradox. @@ -637,37 +665,37 @@ Proof. + cbn. exact (fun X F => forall x:X, F x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. easy. + exact (fun F => forall x:A, F (up x)). + cbn. exact (fun _ f => fun x:A => f (up x)). + cbn. intros * f X. specialize (f (down X)). rewrite up_down in f. exact f. - + cbn. intros ? f X. - destruct (up_down X). cbn. - reflexivity. (** Small universe *) + exact A. (** The interpretation of [A] as a universe is [U]. *) + cbn. exact up. + cbn. exact (fun _ F => down (forall x, up (F x))). + + cbn. exact (fun _ F => down (forall x, up (F x))). + + cbn. exact (down False). + + rewrite up_down in p. + exact p. + + cbn. easy. + + cbn. intros ? f X. + destruct (up_down X). cbn. + reflexivity. + cbn. intros ? ? f. rewrite up_down. exact f. + cbn. intros ? ? f. rewrite up_down in f. exact f. - + cbn. exact (fun _ F => down (forall x, up (F x))). + cbn. intros ? ? f. rewrite up_down. exact f. + cbn. intros ? ? f. rewrite up_down in f. exact f. - + cbn. exact (down False). - + rewrite up_down in p. - exact p. Qed. End Paradox. @@ -683,7 +711,7 @@ Module PropNeqType. Theorem paradox : Prop <> Type. Proof. intros h. - refine (TypeNeqSmallType.paradox _ _). + unshelve (refine (TypeNeqSmallType.paradox _ _)). + exact Prop. + easy. Qed. diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v index 9875710e..21be5032 100644 --- a/theories/Logic/IndefiniteDescription.v +++ b/theories/Logic/IndefiniteDescription.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* inductively_barred P []. Proof. intros P Hbar. -destruct Hbar with (X P) as (l,(Hd/Y_approx,HP)). +destruct Hbar with (X P) as (l,(Hd%Y_approx,HP)). assert (inductively_barred P l) by (apply (now P l), HP). clear Hbar HP. induction l as [|a l]. diff --git a/theories/MMaps/MMapAVL.v b/theories/MMaps/MMapAVL.v deleted file mode 100644 index d840f1f3..00000000 --- a/theories/MMaps/MMapAVL.v +++ /dev/null @@ -1,2158 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* key -> elt -> tree -> int -> tree. - -Notation t := tree. - -(** * Basic functions on trees: height and cardinal *) - -Definition height (m : t) : int := - match m with - | Leaf => 0 - | Node _ _ _ _ h => h - end. - -Fixpoint cardinal (m : t) : nat := - match m with - | Leaf => 0%nat - | Node l _ _ r _ => S (cardinal l + cardinal r) - end. - -(** * Empty Map *) - -Definition empty := Leaf. - -(** * Emptyness test *) - -Definition is_empty m := match m with Leaf => true | _ => false end. - -(** * Membership *) - -(** The [mem] function is deciding membership. It exploits the [Bst] property - to achieve logarithmic complexity. *) - -Fixpoint mem x m : bool := - match m with - | Leaf => false - | Node l y _ r _ => - match X.compare x y with - | Eq => true - | Lt => mem x l - | Gt => mem x r - end - end. - -Fixpoint find x m : option elt := - match m with - | Leaf => None - | Node l y d r _ => - match X.compare x y with - | Eq => Some d - | Lt => find x l - | Gt => find x r - end - end. - -(** * Helper functions *) - -(** [create l x r] creates a node, assuming [l] and [r] - to be balanced and [|height l - height r| <= 2]. *) - -Definition create l x e r := - Node l x e r (max (height l) (height r) + 1). - -(** [bal l x e r] acts as [create], but performs one step of - rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) - -Definition assert_false := create. - -Fixpoint bal l x d r := - let hl := height l in - let hr := height r in - if (hr+2) assert_false l x d r - | Node ll lx ld lr _ => - if (height lr) <=? (height ll) then - create ll lx ld (create lr x d r) - else - match lr with - | Leaf => assert_false l x d r - | Node lrl lrx lrd lrr _ => - create (create ll lx ld lrl) lrx lrd (create lrr x d r) - end - end - else - if (hl+2) assert_false l x d r - | Node rl rx rd rr _ => - if (height rl) <=? (height rr) then - create (create l x d rl) rx rd rr - else - match rl with - | Leaf => assert_false l x d r - | Node rll rlx rld rlr _ => - create (create l x d rll) rlx rld (create rlr rx rd rr) - end - end - else - create l x d r. - -(** * Insertion *) - -Fixpoint add x d m := - match m with - | Leaf => Node Leaf x d Leaf 1 - | Node l y d' r h => - match X.compare x y with - | Eq => Node l y d r h - | Lt => bal (add x d l) y d' r - | Gt => bal l y d' (add x d r) - end - end. - -(** * Extraction of minimum binding - - Morally, [remove_min] is to be applied to a non-empty tree - [t = Node l x e r h]. Since we can't deal here with [assert false] - for [t=Leaf], we pre-unpack [t] (and forget about [h]). -*) - -Fixpoint remove_min l x d r : t*(key*elt) := - match l with - | Leaf => (r,(x,d)) - | Node ll lx ld lr lh => - let (l',m) := remove_min ll lx ld lr in - (bal l' x d r, m) - end. - -(** * Merging two trees - - [merge0 t1 t2] builds the union of [t1] and [t2] assuming all elements - of [t1] to be smaller than all elements of [t2], and - [|height t1 - height t2| <= 2]. -*) - -Definition merge0 s1 s2 := - match s1,s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node l2 x2 d2 r2 h2 => - let '(s2',(x,d)) := remove_min l2 x2 d2 r2 in - bal s1 x d s2' - end. - -(** * Deletion *) - -Fixpoint remove x m := match m with - | Leaf => Leaf - | Node l y d r h => - match X.compare x y with - | Eq => merge0 l r - | Lt => bal (remove x l) y d r - | Gt => bal l y d (remove x r) - end - end. - -(** * join - - Same as [bal] but does not assume anything regarding heights of [l] - and [r]. -*) - -Fixpoint join l : key -> elt -> t -> t := - match l with - | Leaf => add - | Node ll lx ld lr lh => fun x d => - fix join_aux (r:t) : t := match r with - | Leaf => add x d l - | Node rl rx rd rr rh => - if rh+2 x] - - [o] is the result of [find x m]. -*) - -Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. -Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9). - -Fixpoint split x m : triple := match m with - | Leaf => 〚 Leaf, None, Leaf 〛 - | Node l y d r h => - match X.compare x y with - | Lt => let (ll,o,rl) := split x l in 〚 ll, o, join rl y d r 〛 - | Eq => 〚 l, Some d, r 〛 - | Gt => let (rl,o,rr) := split x r in 〚 join l y d rl, o, rr 〛 - end - end. - -(** * Concatenation - - Same as [merge] but does not assume anything about heights. -*) - -Definition concat m1 m2 := - match m1, m2 with - | Leaf, _ => m2 - | _ , Leaf => m1 - | _, Node l2 x2 d2 r2 _ => - let (m2',xd) := remove_min l2 x2 d2 r2 in - join m1 xd#1 xd#2 m2' - end. - -(** * Bindings *) - -(** [bindings_aux acc t] catenates the bindings of [t] in infix - order to the list [acc] *) - -Fixpoint bindings_aux (acc : list (key*elt)) m : list (key*elt) := - match m with - | Leaf => acc - | Node l x d r _ => bindings_aux ((x,d) :: bindings_aux acc r) l - end. - -(** then [bindings] is an instantiation with an empty [acc] *) - -Definition bindings := bindings_aux nil. - -(** * Fold *) - -Fixpoint fold {A} (f : key -> elt -> A -> A) (m : t) : A -> A := - fun a => match m with - | Leaf => a - | Node l x d r _ => fold f r (f x d (fold f l a)) - end. - -(** * Comparison *) - -Variable cmp : elt->elt->bool. - -(** ** Enumeration of the elements of a tree *) - -Inductive enumeration := - | End : enumeration - | More : key -> elt -> t -> enumeration -> enumeration. - -(** [cons m e] adds the elements of tree [m] on the head of - enumeration [e]. *) - -Fixpoint cons m e : enumeration := - match m with - | Leaf => e - | Node l x d r h => cons l (More x d r e) - end. - -(** One step of comparison of elements *) - -Definition equal_more x1 d1 (cont:enumeration->bool) e2 := - match e2 with - | End => false - | More x2 d2 r2 e2 => - match X.compare x1 x2 with - | Eq => cmp d1 d2 &&& cont (cons r2 e2) - | _ => false - end - end. - -(** Comparison of left tree, middle element, then right tree *) - -Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := - match m1 with - | Leaf => cont e2 - | Node l1 x1 d1 r1 _ => - equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2 - end. - -(** Initial continuation *) - -Definition equal_end e2 := match e2 with End => true | _ => false end. - -(** The complete comparison *) - -Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End). - -End Elt. -Notation t := tree. -Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9). -Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). -Notation "t #o" := (t_opt t) (at level 9, format "t '#o'"). -Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). - - -(** * Map *) - -Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => Node (map f l) x (f d) (map f r) h - end. - -(* * Mapi *) - -Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h - end. - -(** * Map with removal *) - -Fixpoint mapo (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) - : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => - match f x d with - | Some d' => join (mapo f l) x d' (mapo f r) - | None => concat (mapo f l) (mapo f r) - end - end. - -(** * Generalized merge - - Suggestion by B. Gregoire: a [merge] function with specialized - arguments that allows bypassing some tree traversal. Instead of one - [f0] of type [key -> option elt -> option elt' -> option elt''], - we ask here for: - - [f] which is a specialisation of [f0] when first option isn't [None] - - [mapl] treats a [tree elt] with [f0] when second option is [None] - - [mapr] treats a [tree elt'] with [f0] when first option is [None] - - The idea is that [mapl] and [mapr] can be instantaneous (e.g. - the identity or some constant function). -*) - -Section GMerge. -Variable elt elt' elt'' : Type. -Variable f : key -> elt -> option elt' -> option elt''. -Variable mapl : t elt -> t elt''. -Variable mapr : t elt' -> t elt''. - -Fixpoint gmerge m1 m2 := - match m1, m2 with - | Leaf _, _ => mapr m2 - | _, Leaf _ => mapl m1 - | Node l1 x1 d1 r1 h1, _ => - let (l2',o2,r2') := split x1 m2 in - match f x1 d1 o2 with - | Some e => join (gmerge l1 l2') x1 e (gmerge r1 r2') - | None => concat (gmerge l1 l2') (gmerge r1 r2') - end - end. - -End GMerge. - -(** * Merge - - The [merge] function of the Map interface can be implemented - via [gmerge] and [mapo]. -*) - -Section Merge. -Variable elt elt' elt'' : Type. -Variable f : key -> option elt -> option elt' -> option elt''. - -Definition merge : t elt -> t elt' -> t elt'' := - gmerge - (fun k d o => f k (Some d) o) - (mapo (fun k d => f k (Some d) None)) - (mapo (fun k d' => f k None (Some d'))). - -End Merge. - - - -(** * Invariants *) - -Section Invariants. -Variable elt : Type. - -(** ** Occurrence in a tree *) - -Inductive MapsTo (x : key)(e : elt) : t elt -> Prop := - | MapsRoot : forall l r h y, - X.eq x y -> MapsTo x e (Node l y e r h) - | MapsLeft : forall l r h y e', - MapsTo x e l -> MapsTo x e (Node l y e' r h) - | MapsRight : forall l r h y e', - MapsTo x e r -> MapsTo x e (Node l y e' r h). - -Inductive In (x : key) : t elt -> Prop := - | InRoot : forall l r h y e, - X.eq x y -> In x (Node l y e r h) - | InLeft : forall l r h y e', - In x l -> In x (Node l y e' r h) - | InRight : forall l r h y e', - In x r -> In x (Node l y e' r h). - -Definition In0 k m := exists e:elt, MapsTo k e m. - -(** ** Binary search trees *) - -(** [Above x m] : [x] is strictly greater than any key in [m]. - [Below x m] : [x] is strictly smaller than any key in [m]. *) - -Inductive Above (x:key) : t elt -> Prop := - | AbLeaf : Above x (Leaf _) - | AbNode l r h y e : Above x l -> X.lt y x -> Above x r -> - Above x (Node l y e r h). - -Inductive Below (x:key) : t elt -> Prop := - | BeLeaf : Below x (Leaf _) - | BeNode l r h y e : Below x l -> X.lt x y -> Below x r -> - Below x (Node l y e r h). - -Definition Apart (m1 m2 : t elt) : Prop := - forall x1 x2, In x1 m1 -> In x2 m2 -> X.lt x1 x2. - -(** Alternative statements, equivalent with [LtTree] and [GtTree] *) - -Definition lt_tree x m := forall y, In y m -> X.lt y x. -Definition gt_tree x m := forall y, In y m -> X.lt x y. - -(** [Bst t] : [t] is a binary search tree *) - -Inductive Bst : t elt -> Prop := - | BSLeaf : Bst (Leaf _) - | BSNode : forall x e l r h, Bst l -> Bst r -> - Above x l -> Below x r -> Bst (Node l x e r h). - -End Invariants. - - -(** * Correctness proofs, isolated in a sub-module *) - -Module Proofs. - Module MX := OrderedTypeFacts X. - Module PX := KeyOrderedType X. - Module L := MMapList.Raw X. - -Local Infix "∈" := In (at level 70). -Local Infix "==" := X.eq (at level 70). -Local Infix "<" := X.lt (at level 70). -Local Infix "<<" := Below (at level 70). -Local Infix ">>" := Above (at level 70). -Local Infix "<<<" := Apart (at level 70). - -Scheme tree_ind := Induction for tree Sort Prop. -Scheme Bst_ind := Induction for Bst Sort Prop. -Scheme MapsTo_ind := Induction for MapsTo Sort Prop. -Scheme In_ind := Induction for In Sort Prop. -Scheme Above_ind := Induction for Above Sort Prop. -Scheme Below_ind := Induction for Below Sort Prop. - -Functional Scheme mem_ind := Induction for mem Sort Prop. -Functional Scheme find_ind := Induction for find Sort Prop. -Functional Scheme bal_ind := Induction for bal Sort Prop. -Functional Scheme add_ind := Induction for add Sort Prop. -Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. -Functional Scheme merge0_ind := Induction for merge0 Sort Prop. -Functional Scheme remove_ind := Induction for remove Sort Prop. -Functional Scheme concat_ind := Induction for concat Sort Prop. -Functional Scheme split_ind := Induction for split Sort Prop. -Functional Scheme mapo_ind := Induction for mapo Sort Prop. -Functional Scheme gmerge_ind := Induction for gmerge Sort Prop. - -(** * Automation and dedicated tactics. *) - -Local Hint Constructors tree MapsTo In Bst Above Below. -Local Hint Unfold lt_tree gt_tree Apart. -Local Hint Immediate MX.eq_sym. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans. - -Tactic Notation "factornode" ident(s) := - try clear s; - match goal with - | |- context [Node ?l ?x ?e ?r ?h] => - set (s:=Node l x e r h) in *; clearbody s; clear l x e r h - | _ : context [Node ?l ?x ?e ?r ?h] |- _ => - set (s:=Node l x e r h) in *; clearbody s; clear l x e r h - end. - -(** A tactic for cleaning hypothesis after use of functional induction. *) - -Ltac cleanf := - match goal with - | H : X.compare _ _ = Eq |- _ => - rewrite ?H; apply MX.compare_eq in H; cleanf - | H : X.compare _ _ = Lt |- _ => - rewrite ?H; apply MX.compare_lt_iff in H; cleanf - | H : X.compare _ _ = Gt |- _ => - rewrite ?H; apply MX.compare_gt_iff in H; cleanf - | _ => idtac - end. - - -(** A tactic to repeat [inversion_clear] on all hyps of the - form [(f (Node ...))] *) - -Ltac inv f := - match goal with - | H:f (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | _ => idtac - end. - -Ltac inv_all f := - match goal with - | H: f _ |- _ => inversion_clear H; inv f - | H: f _ _ |- _ => inversion_clear H; inv f - | H: f _ _ _ |- _ => inversion_clear H; inv f - | H: f _ _ _ _ |- _ => inversion_clear H; inv f - | _ => idtac - end. - -Ltac intuition_in := repeat (intuition; inv In; inv MapsTo). - -(* Function/Functional Scheme can't deal with internal fix. - Let's do its job by hand: *) - -Ltac join_tac l x d r := - revert x d r; - induction l as [| ll _ lx ld lr Hlr lh]; - [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join; - [ | destruct (rh+2 - replace (bal u v w z) - with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto] - end - | destruct (lh+2 - replace (bal u v w z) - with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] - end - | ] ] ] ]; intros. - -Ltac cleansplit := - simpl; cleanf; inv Bst; - match goal with - | E:split _ _ = 〚 ?l, ?o, ?r 〛 |- _ => - change l with (〚l,o,r〛#l); rewrite <- ?E; - change o with (〚l,o,r〛#o); rewrite <- ?E; - change r with (〚l,o,r〛#r); rewrite <- ?E - | _ => idtac - end. - -(** * Basic results about [MapsTo], [In], [lt_tree], [gt_tree], [height] *) - -(** Facts about [MapsTo] and [In]. *) - -Lemma MapsTo_In {elt} k (e:elt) m : MapsTo k e m -> k ∈ m. -Proof. - induction 1; auto. -Qed. -Local Hint Resolve MapsTo_In. - -Lemma In_MapsTo {elt} k m : k ∈ m -> exists (e:elt), MapsTo k e m. -Proof. - induction 1; try destruct IHIn as (e,He); exists e; auto. -Qed. - -Lemma In_alt {elt} k (m:t elt) : In0 k m <-> k ∈ m. -Proof. - split. - intros (e,H); eauto. - unfold In0; apply In_MapsTo; auto. -Qed. - -Lemma MapsTo_1 {elt} m x y (e:elt) : - x == y -> MapsTo x e m -> MapsTo y e m. -Proof. - induction m; simpl; intuition_in; eauto. -Qed. -Hint Immediate MapsTo_1. - -Instance MapsTo_compat {elt} : - Proper (X.eq==>Logic.eq==>Logic.eq==>iff) (@MapsTo elt). -Proof. - intros x x' Hx e e' He m m' Hm. subst. - split; now apply MapsTo_1. -Qed. - -Instance In_compat {elt} : - Proper (X.eq==>Logic.eq==>iff) (@In elt). -Proof. - intros x x' H m m' <-. - induction m; simpl; intuition_in; eauto. -Qed. - -Lemma In_node_iff {elt} l x (e:elt) r h y : - y ∈ (Node l x e r h) <-> y ∈ l \/ y == x \/ y ∈ r. -Proof. - intuition_in. -Qed. - -(** Results about [Above] and [Below] *) - -Lemma above {elt} (m:t elt) x : - x >> m <-> forall y, y ∈ m -> y < x. -Proof. - split. - - induction 1; intuition_in; MX.order. - - induction m; constructor; auto. -Qed. - -Lemma below {elt} (m:t elt) x : - x << m <-> forall y, y ∈ m -> x < y. -Proof. - split. - - induction 1; intuition_in; MX.order. - - induction m; constructor; auto. -Qed. - -Lemma AboveLt {elt} (m:t elt) x y : x >> m -> y ∈ m -> y < x. -Proof. - rewrite above; intuition. -Qed. - -Lemma BelowGt {elt} (m:t elt) x y : x << m -> y ∈ m -> x < y. -Proof. - rewrite below; intuition. -Qed. - -Lemma Above_not_In {elt} (m:t elt) x : x >> m -> ~ x ∈ m. -Proof. - induction 1; intuition_in; MX.order. -Qed. - -Lemma Below_not_In {elt} (m:t elt) x : x << m -> ~ x ∈ m. -Proof. - induction 1; intuition_in; MX.order. -Qed. - -Lemma Above_trans {elt} (m:t elt) x y : x < y -> x >> m -> y >> m. -Proof. - induction 2; constructor; trivial; MX.order. -Qed. - -Lemma Below_trans {elt} (m:t elt) x y : y < x -> x << m -> y << m. -Proof. - induction 2; constructor; trivial; MX.order. -Qed. - -Local Hint Resolve - AboveLt Above_not_In Above_trans - BelowGt Below_not_In Below_trans. - -(** Helper tactic concerning order of elements. *) - -Ltac order := match goal with - | U: _ >> ?m, V: _ ∈ ?m |- _ => - generalize (AboveLt U V); clear U; order - | U: _ << ?m, V: _ ∈ ?m |- _ => - generalize (BelowGt U V); clear U; order - | U: _ >> ?m, V: MapsTo _ _ ?m |- _ => - generalize (AboveLt U (MapsTo_In V)); clear U; order - | U: _ << ?m, V: MapsTo _ _ ?m |- _ => - generalize (BelowGt U (MapsTo_In V)); clear U; order - | _ => MX.order -end. - -Lemma between {elt} (m m':t elt) x : - x >> m -> x << m' -> m <<< m'. -Proof. - intros H H' y y' Hy Hy'. order. -Qed. - -Section Elt. -Variable elt:Type. -Implicit Types m r : t elt. - -(** * Membership *) - -Lemma find_1 m x e : Bst m -> MapsTo x e m -> find x m = Some e. -Proof. - functional induction (find x m); cleanf; - intros; inv Bst; intuition_in; order. -Qed. - -Lemma find_2 m x e : find x m = Some e -> MapsTo x e m. -Proof. - functional induction (find x m); cleanf; subst; intros; auto. - - discriminate. - - injection H as ->. auto. -Qed. - -Lemma find_spec m x e : Bst m -> - (find x m = Some e <-> MapsTo x e m). -Proof. - split; auto using find_1, find_2. -Qed. - -Lemma find_in m x : find x m <> None -> x ∈ m. -Proof. - destruct (find x m) eqn:F; intros H. - - apply MapsTo_In with e. now apply find_2. - - now elim H. -Qed. - -Lemma in_find m x : Bst m -> x ∈ m -> find x m <> None. -Proof. - intros H H'. - destruct (In_MapsTo H') as (d,Hd). - now rewrite (find_1 H Hd). -Qed. - -Lemma find_in_iff m x : Bst m -> - (find x m <> None <-> x ∈ m). -Proof. - split; auto using find_in, in_find. -Qed. - -Lemma not_find_iff m x : Bst m -> - (find x m = None <-> ~ x ∈ m). -Proof. - intros H. rewrite <- find_in_iff; trivial. - destruct (find x m); split; try easy. now destruct 1. -Qed. - -Lemma eq_option_alt (o o':option elt) : - o=o' <-> (forall e, o=Some e <-> o'=Some e). -Proof. -split; intros. -- now subst. -- destruct o, o'; rewrite ?H; auto. symmetry; now apply H. -Qed. - -Lemma find_mapsto_equiv : forall m m' x, Bst m -> Bst m' -> - (find x m = find x m' <-> - (forall d, MapsTo x d m <-> MapsTo x d m')). -Proof. - intros m m' x Hm Hm'. rewrite eq_option_alt. - split; intros H d. now rewrite <- 2 find_spec. now rewrite 2 find_spec. -Qed. - -Lemma find_in_equiv : forall m m' x, Bst m -> Bst m' -> - find x m = find x m' -> - (x ∈ m <-> x ∈ m'). -Proof. - split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ]; - apply in_find; auto. -Qed. - -Lemma find_compat m x x' : Bst m -> X.eq x x' -> find x m = find x' m. -Proof. - intros B E. - destruct (find x' m) eqn:H. - - apply find_1; trivial. rewrite E. now apply find_2. - - rewrite not_find_iff in *; trivial. now rewrite E. -Qed. - -Lemma mem_spec m x : Bst m -> mem x m = true <-> x ∈ m. -Proof. - functional induction (mem x m); auto; intros; cleanf; - inv Bst; intuition_in; try discriminate; order. -Qed. - -(** * Empty map *) - -Lemma empty_bst : Bst (empty elt). -Proof. - constructor. -Qed. - -Lemma empty_spec x : find x (empty elt) = None. -Proof. - reflexivity. -Qed. - -(** * Emptyness test *) - -Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. -Proof. - destruct m as [|r x e l h]; simpl; split; try easy. - intros H. specialize (H x). now rewrite MX.compare_refl in H. -Qed. - -(** * Helper functions *) - -Lemma create_bst l x e r : - Bst l -> Bst r -> x >> l -> x << r -> Bst (create l x e r). -Proof. - unfold create; auto. -Qed. -Hint Resolve create_bst. - -Lemma create_in l x e r y : - y ∈ (create l x e r) <-> y == x \/ y ∈ l \/ y ∈ r. -Proof. - unfold create; split; [ inversion_clear 1 | ]; intuition. -Qed. - -Lemma bal_bst l x e r : Bst l -> Bst r -> - x >> l -> x << r -> Bst (bal l x e r). -Proof. - functional induction (bal l x e r); intros; cleanf; - inv Bst; inv Above; inv Below; - repeat apply create_bst; auto; unfold create; constructor; eauto. -Qed. -Hint Resolve bal_bst. - -Lemma bal_in l x e r y : - y ∈ (bal l x e r) <-> y == x \/ y ∈ l \/ y ∈ r. -Proof. - functional induction (bal l x e r); intros; cleanf; - rewrite !create_in; intuition_in. -Qed. - -Lemma bal_mapsto l x e r y e' : - MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r). -Proof. - functional induction (bal l x e r); intros; cleanf; - unfold assert_false, create; intuition_in. -Qed. - -Lemma bal_find l x e r y : - Bst l -> Bst r -> x >> l -> x << r -> - find y (bal l x e r) = find y (create l x e r). -Proof. - functional induction (bal l x e r); intros; cleanf; trivial; - inv Bst; inv Above; inv Below; - simpl; repeat case X.compare_spec; intuition; order. -Qed. - -(** * Insertion *) - -Lemma add_in m x y e : - y ∈ (add x e m) <-> y == x \/ y ∈ m. -Proof. - functional induction (add x e m); auto; intros; cleanf; - rewrite ?bal_in; intuition_in. setoid_replace y with x; auto. -Qed. - -Lemma add_lt m x e y : y >> m -> x < y -> y >> add x e m. -Proof. - intros. apply above. intros z. rewrite add_in. destruct 1; order. -Qed. - -Lemma add_gt m x e y : y << m -> y < x -> y << add x e m. -Proof. - intros. apply below. intros z. rewrite add_in. destruct 1; order. -Qed. - -Lemma add_bst m x e : Bst m -> Bst (add x e m). -Proof. - functional induction (add x e m); intros; cleanf; - inv Bst; try apply bal_bst; auto using add_lt, add_gt. -Qed. -Hint Resolve add_lt add_gt add_bst. - -Lemma add_spec1 m x e : Bst m -> find x (add x e m) = Some e. -Proof. - functional induction (add x e m); simpl; intros; cleanf; trivial. - - now rewrite MX.compare_refl. - - inv Bst. rewrite bal_find; auto. - simpl. case X.compare_spec; try order; auto. - - inv Bst. rewrite bal_find; auto. - simpl. case X.compare_spec; try order; auto. -Qed. - -Lemma add_spec2 m x y e : Bst m -> ~ x == y -> - find y (add x e m) = find y m. -Proof. - functional induction (add x e m); simpl; intros; cleanf; trivial. - - case X.compare_spec; trivial; order. - - case X.compare_spec; trivial; order. - - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt. - - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt. -Qed. - -Lemma add_find m x y e : Bst m -> - find y (add x e m) = - match X.compare y x with Eq => Some e | _ => find y m end. -Proof. - intros. - case X.compare_spec; intros. - - apply find_spec; auto. rewrite H0. apply find_spec; auto. - now apply add_spec1. - - apply add_spec2; trivial; order. - - apply add_spec2; trivial; order. -Qed. - -(** * Extraction of minimum binding *) - -Definition RemoveMin m res := - match m with - | Leaf _ => False - | Node l x e r h => remove_min l x e r = res - end. - -Lemma RemoveMin_step l x e r h m' p : - RemoveMin (Node l x e r h) (m',p) -> - (l = Leaf _ /\ m' = r /\ p = (x,e) \/ - exists m0, RemoveMin l (m0,p) /\ m' = bal m0 x e r). -Proof. - simpl. destruct l as [|ll lx le lr lh]; simpl. - - intros [= -> ->]. now left. - - destruct (remove_min ll lx le lr) as (l',p'). - intros [= <- <-]. right. now exists l'. -Qed. - -Lemma remove_min_mapsto m m' p : RemoveMin m (m',p) -> - forall y e, - MapsTo y e m <-> (y == p#1 /\ e = p#2) \/ MapsTo y e m'. -Proof. - revert m'. - induction m as [|l IH x d r _ h]; [destruct 1|]. - intros m' R. apply RemoveMin_step in R. - destruct R as [(->,(->,->))|[m0 (R,->)]]; intros y e; simpl. - - intuition_in. subst. now constructor. - - rewrite bal_mapsto. unfold create. specialize (IH _ R y e). - intuition_in. -Qed. - -Lemma remove_min_in m m' p : RemoveMin m (m',p) -> - forall y, y ∈ m <-> y == p#1 \/ y ∈ m'. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R y. apply RemoveMin_step in R. - destruct R as [(->,(->,->))|[m0 (R,->)]]. - + intuition_in. - + rewrite bal_in, In_node_iff, (IH _ R); intuition. -Qed. - -Lemma remove_min_lt m m' p : RemoveMin m (m',p) -> - forall y, y >> m -> y >> m'. -Proof. - intros R y L. apply above. intros z Hz. - apply (AboveLt L). - apply (remove_min_in R). now right. -Qed. - -Lemma remove_min_gt m m' p : RemoveMin m (m',p) -> - Bst m -> p#1 << m'. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R H. inv Bst. apply RemoveMin_step in R. - destruct R as [(_,(->,->))|[m0 (R,->)]]; auto. - assert (p#1 << m0) by now apply IH. - assert (In p#1 l) by (apply (remove_min_in R); now left). - apply below. intros z. rewrite bal_in. - intuition_in; order. -Qed. - -Lemma remove_min_bst m m' p : RemoveMin m (m',p) -> - Bst m -> Bst m'. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R H. inv Bst. apply RemoveMin_step in R. - destruct R as [(_,(->,->))|[m0 (R,->)]]; auto. - apply bal_bst; eauto using remove_min_lt. -Qed. - -Lemma remove_min_find m m' p : RemoveMin m (m',p) -> - Bst m -> - forall y, - find y m = - match X.compare y p#1 with - | Eq => Some p#2 - | Lt => None - | Gt => find y m' - end. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R B y. inv Bst. apply RemoveMin_step in R. - destruct R as [(->,(->,->))|[m0 (R,->)]]; auto. - assert (Bst m0) by now apply (remove_min_bst R). - assert (p#1 << m0) by now apply (remove_min_gt R). - assert (x >> m0) by now apply (remove_min_lt R). - assert (In p#1 l) by (apply (remove_min_in R); now left). - simpl in *. - rewrite (IH _ R), bal_find by trivial. clear IH. simpl. - do 2 case X.compare_spec; trivial; try order. -Qed. - -(** * Merging two trees *) - -Ltac factor_remove_min m R := match goal with - | h:int, H:remove_min ?l ?x ?e ?r = ?p |- _ => - assert (R:RemoveMin (Node l x e r h) p) by exact H; - set (m:=Node l x e r h) in *; clearbody m; clear H l x e r -end. - -Lemma merge0_in m1 m2 y : - y ∈ (merge0 m1 m2) <-> y ∈ m1 \/ y ∈ m2. -Proof. - functional induction (merge0 m1 m2); intros; try factornode m1. - - intuition_in. - - intuition_in. - - factor_remove_min l R. rewrite bal_in, (remove_min_in R). - simpl; intuition. -Qed. - -Lemma merge0_mapsto m1 m2 y e : - MapsTo y e (merge0 m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2. -Proof. - functional induction (merge0 m1 m2); intros; try factornode m1. - - intuition_in. - - intuition_in. - - factor_remove_min l R. rewrite bal_mapsto, (remove_min_mapsto R). - simpl. unfold create; intuition_in. subst. now constructor. -Qed. - -Lemma merge0_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 -> - Bst (merge0 m1 m2). -Proof. - functional induction (merge0 m1 m2); intros B1 B2 B12; trivial. - factornode m1. factor_remove_min l R. - apply bal_bst; auto. - - eapply remove_min_bst; eauto. - - apply above. intros z Hz. apply B12; trivial. - rewrite (remove_min_in R). now left. - - now apply (remove_min_gt R). -Qed. -Hint Resolve merge0_bst. - -(** * Deletion *) - -Lemma remove_in m x y : Bst m -> - (y ∈ remove x m <-> ~ y == x /\ y ∈ m). -Proof. - functional induction (remove x m); simpl; intros; cleanf; inv Bst; - rewrite ?merge0_in, ?bal_in, ?IHt; intuition_in; order. -Qed. - -Lemma remove_lt m x y : Bst m -> y >> m -> y >> remove x m. -Proof. - intros. apply above. intro. rewrite remove_in by trivial. - destruct 1; order. -Qed. - -Lemma remove_gt m x y : Bst m -> y << m -> y << remove x m. -Proof. - intros. apply below. intro. rewrite remove_in by trivial. - destruct 1; order. -Qed. - -Lemma remove_bst m x : Bst m -> Bst (remove x m). -Proof. - functional induction (remove x m); simpl; intros; cleanf; inv Bst. - - trivial. - - apply merge0_bst; eauto. - - apply bal_bst; auto using remove_lt. - - apply bal_bst; auto using remove_gt. -Qed. -Hint Resolve remove_bst remove_gt remove_lt. - -Lemma remove_spec1 m x : Bst m -> find x (remove x m) = None. -Proof. - intros. apply not_find_iff; auto. rewrite remove_in; intuition. -Qed. - -Lemma remove_spec2 m x y : Bst m -> ~ x == y -> - find y (remove x m) = find y m. -Proof. - functional induction (remove x m); simpl; intros; cleanf; inv Bst. - - trivial. - - case X.compare_spec; intros; try order; - rewrite find_mapsto_equiv; auto. - + intros. rewrite merge0_mapsto; intuition; order. - + apply merge0_bst; auto. red; intros; transitivity y0; order. - + intros. rewrite merge0_mapsto; intuition; order. - + apply merge0_bst; auto. now apply between with y0. - - rewrite bal_find by auto. simpl. case X.compare_spec; auto. - - rewrite bal_find by auto. simpl. case X.compare_spec; auto. -Qed. - -(** * join *) - -Lemma join_in l x d r y : - y ∈ (join l x d r) <-> y == x \/ y ∈ l \/ y ∈ r. -Proof. - join_tac l x d r. - - simpl join. rewrite add_in. intuition_in. - - rewrite add_in. intuition_in. - - rewrite bal_in, Hlr. clear Hlr Hrl. intuition_in. - - rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in. - - apply create_in. -Qed. - -Lemma join_bst l x d r : - Bst (create l x d r) -> Bst (join l x d r). -Proof. - join_tac l x d r; unfold create in *; - inv Bst; inv Above; inv Below; auto. - - simpl. auto. - - apply bal_bst; auto. - apply below. intro. rewrite join_in. intuition_in; order. - - apply bal_bst; auto. - apply above. intro. rewrite join_in. intuition_in; order. -Qed. -Hint Resolve join_bst. - -Lemma join_find l x d r y : - Bst (create l x d r) -> - find y (join l x d r) = find y (create l x d r). -Proof. - unfold create at 1. - join_tac l x d r; trivial. - - simpl in *. inv Bst. - rewrite add_find; trivial. - case X.compare_spec; intros; trivial. - apply not_find_iff; auto. intro. order. - - clear Hlr. factornode l. simpl. inv Bst. - rewrite add_find by auto. - case X.compare_spec; intros; trivial. - apply not_find_iff; auto. intro. order. - - clear Hrl LT. factornode r. inv Bst; inv Above; inv Below. - rewrite bal_find; auto; simpl. - + rewrite Hlr; auto; simpl. - repeat (case X.compare_spec; trivial; try order). - + apply below. intro. rewrite join_in. intuition_in; order. - - clear Hlr LT LT'. factornode l. inv Bst; inv Above; inv Below. - rewrite bal_find; auto; simpl. - + rewrite Hrl; auto; simpl. - repeat (case X.compare_spec; trivial; try order). - + apply above. intro. rewrite join_in. intuition_in; order. -Qed. - -(** * split *) - -Lemma split_in_l0 m x y : y ∈ (split x m)#l -> y ∈ m. -Proof. - functional induction (split x m); cleansplit; - rewrite ?join_in; intuition. -Qed. - -Lemma split_in_r0 m x y : y ∈ (split x m)#r -> y ∈ m. -Proof. - functional induction (split x m); cleansplit; - rewrite ?join_in; intuition. -Qed. - -Lemma split_in_l m x y : Bst m -> - (y ∈ (split x m)#l <-> y ∈ m /\ y < x). -Proof. - functional induction (split x m); intros; cleansplit; - rewrite ?join_in, ?IHt; intuition_in; order. -Qed. - -Lemma split_in_r m x y : Bst m -> - (y ∈ (split x m)#r <-> y ∈ m /\ x < y). -Proof. - functional induction (split x m); intros; cleansplit; - rewrite ?join_in, ?IHt; intuition_in; order. -Qed. - -Lemma split_in_o m x : (split x m)#o = find x m. -Proof. - functional induction (split x m); intros; cleansplit; auto. -Qed. - -Lemma split_lt_l m x : Bst m -> x >> (split x m)#l. -Proof. - intro. apply above. intro. rewrite split_in_l; intuition; order. -Qed. - -Lemma split_lt_r m x y : y >> m -> y >> (split x m)#r. -Proof. - intro. apply above. intros z Hz. apply split_in_r0 in Hz. order. -Qed. - -Lemma split_gt_r m x : Bst m -> x << (split x m)#r. -Proof. - intro. apply below. intro. rewrite split_in_r; intuition; order. -Qed. - -Lemma split_gt_l m x y : y << m -> y << (split x m)#l. -Proof. - intro. apply below. intros z Hz. apply split_in_l0 in Hz. order. -Qed. -Hint Resolve split_lt_l split_lt_r split_gt_l split_gt_r. - -Lemma split_bst_l m x : Bst m -> Bst (split x m)#l. -Proof. - functional induction (split x m); intros; cleansplit; intuition; - auto using join_bst. -Qed. - -Lemma split_bst_r m x : Bst m -> Bst (split x m)#r. -Proof. - functional induction (split x m); intros; cleansplit; intuition; - auto using join_bst. -Qed. -Hint Resolve split_bst_l split_bst_r. - -Lemma split_find m x y : Bst m -> - find y m = match X.compare y x with - | Eq => (split x m)#o - | Lt => find y (split x m)#l - | Gt => find y (split x m)#r - end. -Proof. - functional induction (split x m); intros; cleansplit. - - now case X.compare. - - repeat case X.compare_spec; trivial; order. - - simpl in *. rewrite join_find, IHt; auto. - simpl. repeat case X.compare_spec; trivial; order. - - rewrite join_find, IHt; auto. - simpl; repeat case X.compare_spec; trivial; order. -Qed. - -(** * Concatenation *) - -Lemma concat_in m1 m2 y : - y ∈ (concat m1 m2) <-> y ∈ m1 \/ y ∈ m2. -Proof. - functional induction (concat m1 m2); intros; try factornode m1. - - intuition_in. - - intuition_in. - - factor_remove_min m2 R. - rewrite join_in, (remove_min_in R); simpl; intuition. -Qed. - -Lemma concat_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 -> - Bst (concat m1 m2). -Proof. - functional induction (concat m1 m2); intros B1 B2 LT; auto; - try factornode m1. - factor_remove_min m2 R. - apply join_bst, create_bst; auto. - - now apply (remove_min_bst R). - - apply above. intros y Hy. apply LT; trivial. - rewrite (remove_min_in R); now left. - - now apply (remove_min_gt R). -Qed. -Hint Resolve concat_bst. - -Definition oelse {A} (o1 o2:option A) := - match o1 with - | Some x => Some x - | None => o2 - end. - -Lemma concat_find m1 m2 y : Bst m1 -> Bst m2 -> m1 <<< m2 -> - find y (concat m1 m2) = oelse (find y m2) (find y m1). -Proof. - functional induction (concat m1 m2); intros B1 B2 B; auto; try factornode m1. - - destruct (find y m2); auto. - - factor_remove_min m2 R. - assert (xd#1 >> m1). - { apply above. intros z Hz. apply B; trivial. - rewrite (remove_min_in R). now left. } - rewrite join_find; simpl; auto. - + rewrite (remove_min_find R B2 y). - case X.compare_spec; intros; auto. - destruct (find y m2'); trivial. - simpl. symmetry. apply not_find_iff; eauto. - + apply create_bst; auto. - * now apply (remove_min_bst R). - * now apply (remove_min_gt R). -Qed. - - -(** * Elements *) - -Notation eqk := (PX.eqk (elt:= elt)). -Notation eqke := (PX.eqke (elt:= elt)). -Notation ltk := (PX.ltk (elt:= elt)). - -Lemma bindings_aux_mapsto : forall (s:t elt) acc x e, - InA eqke (x,e) (bindings_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc. -Proof. - induction s as [ | l Hl x e r Hr h ]; simpl; auto. - intuition. - inversion H0. - intros. - rewrite Hl. - destruct (Hr acc x0 e0); clear Hl Hr. - intuition; inversion_clear H3; intuition. - compute in H0. destruct H0; simpl in *; subst; intuition. -Qed. - -Lemma bindings_mapsto : forall (s:t elt) x e, - InA eqke (x,e) (bindings s) <-> MapsTo x e s. -Proof. - intros; generalize (bindings_aux_mapsto s nil x e); intuition. - inversion_clear H0. -Qed. - -Lemma bindings_in : forall (s:t elt) x, L.PX.In x (bindings s) <-> x ∈ s. -Proof. - intros. - unfold L.PX.In. - rewrite <- In_alt; unfold In0. - split; intros (y,H); exists y. - - now rewrite <- bindings_mapsto. - - unfold L.PX.MapsTo; now rewrite bindings_mapsto. -Qed. - -Lemma bindings_aux_sort : forall (s:t elt) acc, - Bst s -> sort ltk acc -> - (forall x e y, InA eqke (x,e) acc -> y ∈ s -> y < x) -> - sort ltk (bindings_aux acc s). -Proof. - induction s as [ | l Hl y e r Hr h]; simpl; intuition. - inv Bst. - apply Hl; auto. - - constructor. - + apply Hr; eauto. - + clear Hl Hr. - apply InA_InfA with (eqA:=eqke); auto with *. - intros (y',e') Hy'. - apply bindings_aux_mapsto in Hy'. compute. intuition; eauto. - - clear Hl Hr. intros x e' y' Hx Hy'. - inversion_clear Hx. - + compute in H. destruct H; simpl in *. order. - + apply bindings_aux_mapsto in H. intuition eauto. -Qed. - -Lemma bindings_sort : forall s : t elt, Bst s -> sort ltk (bindings s). -Proof. - intros; unfold bindings; apply bindings_aux_sort; auto. - intros; inversion H0. -Qed. -Hint Resolve bindings_sort. - -Lemma bindings_nodup : forall s : t elt, Bst s -> NoDupA eqk (bindings s). -Proof. - intros; apply PX.Sort_NoDupA; auto. -Qed. - -Lemma bindings_aux_cardinal m acc : - (length acc + cardinal m)%nat = length (bindings_aux acc m). -Proof. - revert acc. induction m; simpl; intuition. - rewrite <- IHm1; simpl. - rewrite <- IHm2. rewrite Nat.add_succ_r, <- Nat.add_assoc. - f_equal. f_equal. apply Nat.add_comm. -Qed. - -Lemma bindings_cardinal m : cardinal m = length (bindings m). -Proof. - exact (bindings_aux_cardinal m nil). -Qed. - -Lemma bindings_app : - forall (s:t elt) acc, bindings_aux acc s = bindings s ++ acc. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1, IHs2. - unfold bindings; simpl. - rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto. -Qed. - -Lemma bindings_node : - forall (t1 t2:t elt) x e z l, - bindings t1 ++ (x,e) :: bindings t2 ++ l = - bindings (Node t1 x e t2 z) ++ l. -Proof. - unfold bindings; simpl; intros. - rewrite !bindings_app, !app_nil_r, !app_ass; auto. -Qed. - -(** * Fold *) - -Definition fold' {A} (f : key -> elt -> A -> A)(s : t elt) := - L.fold f (bindings s). - -Lemma fold_equiv_aux {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) acc : - L.fold f (bindings_aux acc s) a = L.fold f acc (fold f s a). -Proof. - revert a acc. - induction s; simpl; trivial. - intros. rewrite IHs1. simpl. apply IHs2. -Qed. - -Lemma fold_equiv {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) : - fold f s a = fold' f s a. -Proof. - unfold fold', bindings. now rewrite fold_equiv_aux. -Qed. - -Lemma fold_spec (s:t elt)(Hs:Bst s){A}(i:A)(f : key -> elt -> A -> A) : - fold f s i = fold_left (fun a p => f p#1 p#2 a) (bindings s) i. -Proof. - rewrite fold_equiv. unfold fold'. now rewrite L.fold_spec. -Qed. - -(** * Comparison *) - -(** [flatten_e e] returns the list of bindings of the enumeration [e] - i.e. the list of bindings actually compared *) - -Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with - | End _ => nil - | More x e t r => (x,e) :: bindings t ++ flatten_e r - end. - -Lemma flatten_e_bindings : - forall (l:t elt) r x d z e, - bindings l ++ flatten_e (More x d r e) = - bindings (Node l x d r z) ++ flatten_e e. -Proof. - intros; apply bindings_node. -Qed. - -Lemma cons_1 : forall (s:t elt) e, - flatten_e (cons s e) = bindings s ++ flatten_e e. -Proof. - induction s; auto; intros. - simpl flatten_e; rewrite IHs1; apply flatten_e_bindings; auto. -Qed. - -(** Proof of correction for the comparison *) - -Variable cmp : elt->elt->bool. - -Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b. - -Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, - X.eq x1 x2 -> cmp d1 d2 = true -> - IfEq b l1 l2 -> - IfEq b ((x1,d1)::l1) ((x2,d2)::l2). -Proof. - unfold IfEq; destruct b; simpl; intros; case X.compare_spec; simpl; - try rewrite H0; auto; order. -Qed. - -Lemma equal_end_IfEq : forall e2, - IfEq (equal_end e2) nil (flatten_e e2). -Proof. - destruct e2; red; auto. -Qed. - -Lemma equal_more_IfEq : - forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, - IfEq (cont (cons r2 e2)) l (bindings r2 ++ flatten_e e2) -> - IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l) - (flatten_e (More x2 d2 r2 e2)). -Proof. - unfold IfEq; simpl; intros; destruct X.compare; simpl; auto. - rewrite <-andb_lazy_alt; f_equal; auto. -Qed. - -Lemma equal_cont_IfEq : forall m1 cont e2 l, - (forall e, IfEq (cont e) l (flatten_e e)) -> - IfEq (equal_cont cmp m1 cont e2) (bindings m1 ++ l) (flatten_e e2). -Proof. - induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto. - rewrite <- bindings_node; simpl. - apply Hl1; auto. - clear e2; intros [|x2 d2 r2 e2]. - simpl; red; auto. - apply equal_more_IfEq. - rewrite <- cons_1; auto. -Qed. - -Lemma equal_IfEq : forall (m1 m2:t elt), - IfEq (equal cmp m1 m2) (bindings m1) (bindings m2). -Proof. - intros; unfold equal. - rewrite <- (app_nil_r (bindings m1)). - replace (bindings m2) with (flatten_e (cons m2 (End _))) - by (rewrite cons_1; simpl; rewrite app_nil_r; auto). - apply equal_cont_IfEq. - intros. - apply equal_end_IfEq; auto. -Qed. - -Definition Equivb m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma Equivb_bindings : forall s s', - Equivb s s' <-> L.Equivb cmp (bindings s) (bindings s'). -Proof. -unfold Equivb, L.Equivb; split; split; intros. -do 2 rewrite bindings_in; firstorder. -destruct H. -apply (H2 k); rewrite <- bindings_mapsto; auto. -do 2 rewrite <- bindings_in; firstorder. -destruct H. -apply (H2 k); unfold L.PX.MapsTo; rewrite bindings_mapsto; auto. -Qed. - -Lemma equal_Equivb : forall (s s': t elt), Bst s -> Bst s' -> - (equal cmp s s' = true <-> Equivb s s'). -Proof. - intros s s' B B'. - rewrite Equivb_bindings, <- equal_IfEq. - split; [apply L.equal_2|apply L.equal_1]; auto. -Qed. - -End Elt. - -Section Map. -Variable elt elt' : Type. -Variable f : elt -> elt'. - -Lemma map_spec m x : - find x (map f m) = option_map f (find x m). -Proof. -induction m; simpl; trivial. case X.compare_spec; auto. -Qed. - -Lemma map_in m x : x ∈ (map f m) <-> x ∈ m. -Proof. -induction m; simpl; intuition_in. -Qed. - -Lemma map_bst m : Bst m -> Bst (map f m). -Proof. -induction m; simpl; auto. intros; inv Bst; constructor; auto. -- apply above. intro. rewrite map_in. intros. order. -- apply below. intro. rewrite map_in. intros. order. -Qed. - -End Map. -Section Mapi. -Variable elt elt' : Type. -Variable f : key -> elt -> elt'. - -Lemma mapi_spec m x : - exists y:key, - X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). -Proof. - induction m; simpl. - - now exists x. - - case X.compare_spec; simpl; auto. intros. now exists k. -Qed. - -Lemma mapi_in m x : x ∈ (mapi f m) <-> x ∈ m. -Proof. -induction m; simpl; intuition_in. -Qed. - -Lemma mapi_bst m : Bst m -> Bst (mapi f m). -Proof. -induction m; simpl; auto. intros; inv Bst; constructor; auto. -- apply above. intro. rewrite mapi_in. intros. order. -- apply below. intro. rewrite mapi_in. intros. order. -Qed. - -End Mapi. - -Section Mapo. -Variable elt elt' : Type. -Variable f : key -> elt -> option elt'. - -Lemma mapo_in m x : - x ∈ (mapo f m) -> - exists y d, X.eq y x /\ MapsTo x d m /\ f y d <> None. -Proof. -functional induction (mapo f m); simpl; auto; intro H. -- inv In. -- rewrite join_in in H; destruct H as [H|[H|H]]. - + exists x0, d. do 2 (split; auto). congruence. - + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto. - + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto. -- rewrite concat_in in H; destruct H as [H|H]. - + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto. - + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto. -Qed. - -Lemma mapo_lt m x : x >> m -> x >> mapo f m. -Proof. - intros H. apply above. intros y Hy. - destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order. -Qed. - -Lemma mapo_gt m x : x << m -> x << mapo f m. -Proof. - intros H. apply below. intros y Hy. - destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order. -Qed. -Hint Resolve mapo_lt mapo_gt. - -Lemma mapo_bst m : Bst m -> Bst (mapo f m). -Proof. -functional induction (mapo f m); simpl; auto; intro H; inv Bst. -- apply join_bst, create_bst; auto. -- apply concat_bst; auto. apply between with x; auto. -Qed. -Hint Resolve mapo_bst. - -Ltac nonify e := - replace e with (@None elt) by - (symmetry; rewrite not_find_iff; auto; intro; order). - -Definition obind {A B} (o:option A) (f:A->option B) := - match o with Some a => f a | None => None end. - -Lemma mapo_find m x : - Bst m -> - exists y, X.eq y x /\ - find x (mapo f m) = obind (find x m) (f y). -Proof. -functional induction (mapo f m); simpl; auto; intros B; - inv Bst. -- now exists x. -- rewrite join_find; auto. - + simpl. case X.compare_spec; simpl; intros. - * now exists x0. - * destruct IHt as (y' & ? & ?); auto. - exists y'; split; trivial. - * destruct IHt0 as (y' & ? & ?); auto. - exists y'; split; trivial. - + constructor; auto using mapo_lt, mapo_gt. -- rewrite concat_find; auto. - + destruct IHt0 as (y' & ? & ->); auto. - destruct IHt as (y'' & ? & ->); auto. - case X.compare_spec; simpl; intros. - * nonify (find x r). nonify (find x l). simpl. now exists x0. - * nonify (find x r). now exists y''. - * nonify (find x l). exists y'. split; trivial. - destruct (find x r); simpl; trivial. - now destruct (f y' e). - + apply between with x0; auto. -Qed. - -End Mapo. - -Section Gmerge. -Variable elt elt' elt'' : Type. -Variable f0 : key -> option elt -> option elt' -> option elt''. -Variable f : key -> elt -> option elt' -> option elt''. -Variable mapl : t elt -> t elt''. -Variable mapr : t elt' -> t elt''. -Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o. -Hypothesis mapl_bst : forall m, Bst m -> Bst (mapl m). -Hypothesis mapr_bst : forall m', Bst m' -> Bst (mapr m'). -Hypothesis mapl_f0 : forall x m, Bst m -> - exists y, X.eq y x /\ - find x (mapl m) = obind (find x m) (fun d => f0 y (Some d) None). -Hypothesis mapr_f0 : forall x m, Bst m -> - exists y, X.eq y x /\ - find x (mapr m) = obind (find x m) (fun d => f0 y None (Some d)). - -Notation gmerge := (gmerge f mapl mapr). - -Lemma gmerge_in m m' y : Bst m -> Bst m' -> - y ∈ (gmerge m m') -> y ∈ m \/ y ∈ m'. -Proof. - functional induction (gmerge m m'); intros B1 B2 H; - try factornode m2; inv Bst. - - right. apply find_in. - generalize (in_find (mapr_bst B2) H). - destruct (@mapr_f0 y m2) as (y' & ? & ->); trivial. - intros A B. rewrite B in A. now elim A. - - left. apply find_in. - generalize (in_find (mapl_bst B1) H). - destruct (@mapl_f0 y m2) as (y' & ? & ->); trivial. - intros A B. rewrite B in A. now elim A. - - rewrite join_in in *. revert IHt1 IHt0 H. cleansplit. - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite split_in_r, split_in_l; intuition_in. - - rewrite concat_in in *. revert IHt1 IHt0 H; cleansplit. - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite split_in_r, split_in_l; intuition_in. -Qed. - -Lemma gmerge_lt m m' x : Bst m -> Bst m' -> - x >> m -> x >> m' -> x >> gmerge m m'. -Proof. - intros. apply above. intros y Hy. - apply gmerge_in in Hy; intuition_in; order. -Qed. - -Lemma gmerge_gt m m' x : Bst m -> Bst m' -> - x << m -> x << m' -> x << gmerge m m'. -Proof. - intros. apply below. intros y Hy. - apply gmerge_in in Hy; intuition_in; order. -Qed. -Hint Resolve gmerge_lt gmerge_gt. -Hint Resolve split_bst_l split_bst_r split_lt_l split_gt_r. - -Lemma gmerge_bst m m' : Bst m -> Bst m' -> Bst (gmerge m m'). -Proof. - functional induction (gmerge m m'); intros B1 B2; auto; - factornode m2; inv Bst; - (apply join_bst, create_bst || apply concat_bst); - revert IHt1 IHt0; cleansplit; intuition. - apply between with x1; auto. -Qed. -Hint Resolve gmerge_bst. - -Lemma oelse_none_r {A} (o:option A) : oelse o None = o. -Proof. now destruct o. Qed. - -Ltac nonify e := - let E := fresh "E" in - assert (E : e = None); - [ rewrite not_find_iff; auto; intro U; - try apply gmerge_in in U; intuition_in; order - | rewrite E; clear E ]. - -Lemma gmerge_find m m' x : Bst m -> Bst m' -> - In x m \/ In x m' -> - exists y, X.eq y x /\ - find x (gmerge m m') = f0 y (find x m) (find x m'). -Proof. - functional induction (gmerge m m'); intros B1 B2 H; - try factornode m2; inv Bst. - - destruct H; [ intuition_in | ]. - destruct (@mapr_f0 x m2) as (y,(Hy,E)); trivial. - exists y; split; trivial. - rewrite E. simpl. apply in_find in H; trivial. - destruct (find x m2); simpl; intuition. - - destruct H; [ | intuition_in ]. - destruct (@mapl_f0 x m2) as (y,(Hy,E)); trivial. - exists y; split; trivial. - rewrite E. simpl. apply in_find in H; trivial. - destruct (find x m2); simpl; intuition. - - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite (split_find x1 x B2). - rewrite e1 in *; simpl in *. intros. - rewrite join_find by (cleansplit; constructor; auto). - simpl. case X.compare_spec; intros. - + exists x1. split; auto. now rewrite <- e3, f0_f. - + apply IHt1; auto. clear IHt1 IHt0. - cleansplit; rewrite split_in_l; trivial. - intuition_in; order. - + apply IHt0; auto. clear IHt1 IHt0. - cleansplit; rewrite split_in_r; trivial. - intuition_in; order. - - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite (split_find x1 x B2). - pose proof (split_lt_l x1 B2). - pose proof (split_gt_r x1 B2). - rewrite e1 in *; simpl in *. intros. - rewrite concat_find by (try apply between with x1; auto). - case X.compare_spec; intros. - + clear IHt0 IHt1. - exists x1. split; auto. rewrite <- f0_f, e2. - nonify (find x (gmerge r1 r2')). - nonify (find x (gmerge l1 l2')). trivial. - + nonify (find x (gmerge r1 r2')). - simpl. apply IHt1; auto. clear IHt1 IHt0. - intuition_in; try order. - right. cleansplit. now apply split_in_l. - + nonify (find x (gmerge l1 l2')). simpl. - rewrite oelse_none_r. - apply IHt0; auto. clear IHt1 IHt0. - intuition_in; try order. - right. cleansplit. now apply split_in_r. -Qed. - -End Gmerge. - -Section Merge. -Variable elt elt' elt'' : Type. -Variable f : key -> option elt -> option elt' -> option elt''. - -Lemma merge_bst m m' : Bst m -> Bst m' -> Bst (merge f m m'). -Proof. -unfold merge; intros. -apply gmerge_bst with f; - auto using mapo_bst, mapo_find. -Qed. - -Lemma merge_spec1 m m' x : Bst m -> Bst m' -> - In x m \/ In x m' -> - exists y, X.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). -Proof. - unfold merge; intros. - edestruct (gmerge_find (f0:=f)) as (y,(Hy,E)); - eauto using mapo_bst. - - reflexivity. - - intros. now apply mapo_find. - - intros. now apply mapo_find. -Qed. - -Lemma merge_spec2 m m' x : Bst m -> Bst m' -> - In x (merge f m m') -> In x m \/ In x m'. -Proof. -unfold merge; intros. -eapply gmerge_in with (f0:=f); try eassumption; - auto using mapo_bst, mapo_find. -Qed. - -End Merge. -End Proofs. -End Raw. - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of balanced binary search trees. *) - -Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. - - Module E := X. - Module Raw := Raw I X. - Import Raw.Proofs. - - Record tree (elt:Type) := - Mk {this :> Raw.tree elt; is_bst : Raw.Bst this}. - - Definition t := tree. - Definition key := E.t. - - Section Elt. - Variable elt elt' elt'': Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition empty : t elt := Mk (empty_bst elt). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Mk (add_bst x e m.(is_bst)). - Definition remove x m : t elt := Mk (remove_bst x m.(is_bst)). - Definition mem x m : bool := Raw.mem x m.(this). - Definition find x m : option elt := Raw.find x m.(this). - Definition map f m : t elt' := Mk (map_bst f m.(is_bst)). - Definition mapi (f:key->elt->elt') m : t elt' := - Mk (mapi_bst f m.(is_bst)). - Definition merge f m (m':t elt') : t elt'' := - Mk (merge_bst f m.(is_bst) m'.(is_bst)). - Definition bindings m : list (key*elt) := Raw.bindings m.(this). - Definition cardinal m := Raw.cardinal m.(this). - Definition fold {A} (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i. - Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). - - Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this). - Definition In x m : Prop := Raw.In0 x m.(this). - - Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. - Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. - Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. - - Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - Proof. - intros k k' Hk e e' He m m' Hm. unfold MapsTo; simpl. - now rewrite Hk, He, Hm. - Qed. - - Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m. - Proof. apply find_spec. apply is_bst. Qed. - - Lemma mem_spec m x : mem x m = true <-> In x m. - Proof. - unfold In, mem; rewrite In_alt. apply mem_spec. apply is_bst. - Qed. - - Lemma empty_spec x : find x empty = None. - Proof. apply empty_spec. Qed. - - Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. - Proof. apply is_empty_spec. Qed. - - Lemma add_spec1 m x e : find x (add x e m) = Some e. - Proof. apply add_spec1. apply is_bst. Qed. - Lemma add_spec2 m x y e : ~ E.eq x y -> find y (add x e m) = find y m. - Proof. apply add_spec2. apply is_bst. Qed. - - Lemma remove_spec1 m x : find x (remove x m) = None. - Proof. apply remove_spec1. apply is_bst. Qed. - Lemma remove_spec2 m x y : ~E.eq x y -> find y (remove x m) = find y m. - Proof. apply remove_spec2. apply is_bst. Qed. - - Lemma bindings_spec1 m x e : - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - Proof. apply bindings_mapsto. Qed. - - Lemma bindings_spec2 m : sort lt_key (bindings m). - Proof. apply bindings_sort. apply is_bst. Qed. - - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. apply bindings_nodup. apply is_bst. Qed. - - Lemma fold_spec m {A} (i : A) (f : key -> elt -> A -> A) : - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. apply fold_spec. apply is_bst. Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. apply bindings_cardinal. Qed. - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp := Equiv (Cmp cmp). - - Lemma Equivb_Equivb cmp m m' : - Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. - Proof. - unfold Equivb, Equiv, Raw.Proofs.Equivb, In. intuition. - generalize (H0 k); do 2 rewrite In_alt; intuition. - generalize (H0 k); do 2 rewrite In_alt; intuition. - generalize (H0 k); do 2 rewrite <- In_alt; intuition. - generalize (H0 k); do 2 rewrite <- In_alt; intuition. - Qed. - - Lemma equal_spec m m' cmp : - equal cmp m m' = true <-> Equivb cmp m m'. - Proof. rewrite Equivb_Equivb. apply equal_Equivb; apply is_bst. Qed. - - End Elt. - - Lemma map_spec {elt elt'} (f:elt->elt') m x : - find x (map f m) = option_map f (find x m). - Proof. apply map_spec. Qed. - - Lemma mapi_spec {elt elt'} (f:key->elt->elt') m x : - exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - Proof. apply mapi_spec. Qed. - - Lemma merge_spec1 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' x : - In x m \/ In x m' -> - exists y:key, E.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). - Proof. - unfold In. rewrite !In_alt. apply merge_spec1; apply is_bst. - Qed. - - Lemma merge_spec2 {elt elt' elt''} - (f:key -> option elt->option elt'->option elt'') m m' x : - In x (merge f m m') -> In x m \/ In x m'. - Proof. - unfold In. rewrite !In_alt. apply merge_spec2; apply is_bst. - Qed. - -End IntMake. - - -Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: - Sord with Module Data := D - with Module MapS.E := X. - - Module Data := D. - Module Import MapS := IntMake(I)(X). - Module LO := MMapList.Make_ord(X)(D). - Module R := Raw. - Module P := Raw.Proofs. - - Definition t := MapS.t D.t. - - Definition cmp e e' := - match D.compare e e' with Eq => true | _ => false end. - - (** One step of comparison of bindings *) - - Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 := - match e2 with - | R.End _ => Gt - | R.More x2 d2 r2 e2 => - match X.compare x1 x2 with - | Eq => match D.compare d1 d2 with - | Eq => cont (R.cons r2 e2) - | Lt => Lt - | Gt => Gt - end - | Lt => Lt - | Gt => Gt - end - end. - - (** Comparison of left tree, middle element, then right tree *) - - Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 := - match s1 with - | R.Leaf _ => cont e2 - | R.Node l1 x1 d1 r1 _ => - compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2 - end. - - (** Initial continuation *) - - Definition compare_end (e2:R.enumeration D.t) := - match e2 with R.End _ => Eq | _ => Lt end. - - (** The complete comparison *) - - Definition compare m1 m2 := - compare_cont m1.(this) compare_end (R.cons m2 .(this) (Raw.End _)). - - (** Correctness of this comparison *) - - Definition Cmp c := - match c with - | Eq => LO.eq_list - | Lt => LO.lt_list - | Gt => (fun l1 l2 => LO.lt_list l2 l1) - end. - - Lemma cons_Cmp c x1 x2 d1 d2 l1 l2 : - X.eq x1 x2 -> D.eq d1 d2 -> - Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). - Proof. - destruct c; simpl; intros; case X.compare_spec; auto; try P.MX.order. - intros. right. split; auto. now symmetry. - Qed. - Hint Resolve cons_Cmp. - - Lemma compare_end_Cmp e2 : - Cmp (compare_end e2) nil (P.flatten_e e2). - Proof. - destruct e2; simpl; auto. - Qed. - - Lemma compare_more_Cmp x1 d1 cont x2 d2 r2 e2 l : - Cmp (cont (R.cons r2 e2)) l (R.bindings r2 ++ P.flatten_e e2) -> - Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l) - (P.flatten_e (R.More x2 d2 r2 e2)). - Proof. - simpl; case X.compare_spec; simpl; - try case D.compare_spec; simpl; auto; - case X.compare_spec; try P.MX.order; auto. - Qed. - - Lemma compare_cont_Cmp : forall s1 cont e2 l, - (forall e, Cmp (cont e) l (P.flatten_e e)) -> - Cmp (compare_cont s1 cont e2) (R.bindings s1 ++ l) (P.flatten_e e2). - Proof. - induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1] using P.tree_ind; - intros; auto. - rewrite <- P.bindings_node; simpl. - apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2]. - simpl; auto. - apply compare_more_Cmp. - rewrite <- P.cons_1; auto. - Qed. - - Lemma compare_Cmp m1 m2 : - Cmp (compare m1 m2) (bindings m1) (bindings m2). - Proof. - destruct m1 as (s1,H1), m2 as (s2,H2). - unfold compare, bindings; simpl. - rewrite <- (app_nil_r (R.bindings s1)). - replace (R.bindings s2) with (P.flatten_e (R.cons s2 (R.End _))) by - (rewrite P.cons_1; simpl; rewrite app_nil_r; auto). - auto using compare_cont_Cmp, compare_end_Cmp. - Qed. - - Definition eq (m1 m2 : t) := LO.eq_list (bindings m1) (bindings m2). - Definition lt (m1 m2 : t) := LO.lt_list (bindings m1) (bindings m2). - - Lemma compare_spec m1 m2 : CompSpec eq lt m1 m2 (compare m1 m2). - Proof. - assert (H := compare_Cmp m1 m2). - unfold Cmp in H. - destruct (compare m1 m2); auto. - Qed. - - (* Proofs about [eq] and [lt] *) - - Definition sbindings (m1 : t) := - LO.MapS.Mk (P.bindings_sort m1.(is_bst)). - - Definition seq (m1 m2 : t) := LO.eq (sbindings m1) (sbindings m2). - Definition slt (m1 m2 : t) := LO.lt (sbindings m1) (sbindings m2). - - Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2. - Proof. - unfold eq, seq, sbindings, bindings, LO.eq; intuition. - Qed. - - Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2. - Proof. - unfold lt, slt, sbindings, bindings, LO.lt; intuition. - Qed. - - Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'. - Proof. - rewrite eq_seq; unfold seq. - rewrite Equivb_Equivb. - rewrite P.Equivb_bindings. apply LO.eq_spec. - Qed. - - Instance eq_equiv : Equivalence eq. - Proof. - constructor; red; [intros x|intros x y| intros x y z]; - rewrite !eq_seq; apply LO.eq_equiv. - Qed. - - Instance lt_compat : Proper (eq ==> eq ==> iff) lt. - Proof. - intros m1 m2 H1 m1' m2' H2. rewrite !lt_slt. rewrite eq_seq in *. - now apply LO.lt_compat. - Qed. - - Instance lt_strorder : StrictOrder lt. - Proof. - constructor; red; [intros x; red|intros x y z]; - rewrite !lt_slt; apply LO.lt_strorder. - Qed. - -End IntMake_ord. - -(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) - -Module Make (X: OrderedType) <: S with Module E := X - :=IntMake(Z_as_Int)(X). - -Module Make_ord (X: OrderedType)(D: OrderedType) - <: Sord with Module Data := D - with Module MapS.E := X - :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/theories/MMaps/MMapFacts.v b/theories/MMaps/MMapFacts.v deleted file mode 100644 index 69066a7b..00000000 --- a/theories/MMaps/MMapFacts.v +++ /dev/null @@ -1,2434 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (b=true <-> b'=true). -Proof. - destruct b, b'; intuition. -Qed. - -Lemma eq_option_alt {elt}(o o':option elt) : - o=o' <-> (forall e, o=Some e <-> o'=Some e). -Proof. -split; intros. -- now subst. -- destruct o, o'; rewrite ?H; auto. - symmetry; now apply H. -Qed. - -Lemma option_map_some {A B}(f:A->B) o : - option_map f o <> None <-> o <> None. -Proof. - destruct o; simpl. now split. split; now destruct 1. -Qed. - -(** * Properties about weak maps *) - -Module WProperties_fun (E:DecidableType)(Import M:WSfun E). - -Definition Empty {elt}(m : t elt) := forall x e, ~MapsTo x e m. - -(** A few things about E.eq *) - -Lemma eq_refl x : E.eq x x. Proof. apply E.eq_equiv. Qed. -Lemma eq_sym x y : E.eq x y -> E.eq y x. Proof. apply E.eq_equiv. Qed. -Lemma eq_trans x y z : E.eq x y -> E.eq y z -> E.eq x z. -Proof. apply E.eq_equiv. Qed. -Hint Immediate eq_refl eq_sym : map. -Hint Resolve eq_trans eq_equivalence E.eq_equiv : map. - -Definition eqb x y := if E.eq_dec x y then true else false. - -Lemma eqb_eq x y : eqb x y = true <-> E.eq x y. -Proof. - unfold eqb; case E.eq_dec; now intuition. -Qed. - -Lemma eqb_sym x y : eqb x y = eqb y x. -Proof. - apply eq_bool_alt. rewrite !eqb_eq. split; apply E.eq_equiv. -Qed. - -(** Initial results about MapsTo and In *) - -Lemma mapsto_fun {elt} m x (e e':elt) : - MapsTo x e m -> MapsTo x e' m -> e=e'. -Proof. -rewrite <- !find_spec. congruence. -Qed. - -Lemma in_find {elt} (m : t elt) x : In x m <-> find x m <> None. -Proof. - unfold In. split. - - intros (e,H). rewrite <-find_spec in H. congruence. - - destruct (find x m) as [e|] eqn:H. - + exists e. now apply find_spec. - + now destruct 1. -Qed. - -Lemma not_in_find {elt} (m : t elt) x : ~In x m <-> find x m = None. -Proof. - rewrite in_find. split; auto. - intros; destruct (find x m); trivial. now destruct H. -Qed. - -Notation in_find_iff := in_find (only parsing). -Notation not_find_in_iff := not_in_find (only parsing). - -(** * [Equal] is a setoid equality. *) - -Infix "==" := Equal (at level 30). - -Lemma Equal_refl {elt} (m : t elt) : m == m. -Proof. red; reflexivity. Qed. - -Lemma Equal_sym {elt} (m m' : t elt) : m == m' -> m' == m. -Proof. unfold Equal; auto. Qed. - -Lemma Equal_trans {elt} (m m' m'' : t elt) : - m == m' -> m' == m'' -> m == m''. -Proof. unfold Equal; congruence. Qed. - -Instance Equal_equiv {elt} : Equivalence (@Equal elt). -Proof. -constructor; [exact Equal_refl | exact Equal_sym | exact Equal_trans]. -Qed. - -Arguments Equal {elt} m m'. - -Instance MapsTo_m {elt} : - Proper (E.eq==>Logic.eq==>Equal==>iff) (@MapsTo elt). -Proof. -intros k k' Hk e e' <- m m' Hm. rewrite <- Hk. -now rewrite <- !find_spec, Hm. -Qed. - -Instance In_m {elt} : - Proper (E.eq==>Equal==>iff) (@In elt). -Proof. -intros k k' Hk m m' Hm. unfold In. -split; intros (e,H); exists e; revert H; - now rewrite Hk, <- !find_spec, Hm. -Qed. - -Instance find_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@find elt). -Proof. -intros k k' Hk m m' <-. -rewrite eq_option_alt. intros. now rewrite !find_spec, Hk. -Qed. - -Instance mem_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@mem elt). -Proof. -intros k k' Hk m m' Hm. now rewrite eq_bool_alt, !mem_spec, Hk, Hm. -Qed. - -Instance Empty_m {elt} : Proper (Equal==>iff) (@Empty elt). -Proof. -intros m m' Hm. unfold Empty. now setoid_rewrite Hm. -Qed. - -Instance is_empty_m {elt} : Proper (Equal ==> Logic.eq) (@is_empty elt). -Proof. -intros m m' Hm. rewrite eq_bool_alt, !is_empty_spec. - now setoid_rewrite Hm. -Qed. - -Instance add_m {elt} : Proper (E.eq==>Logic.eq==>Equal==>Equal) (@add elt). -Proof. -intros k k' Hk e e' <- m m' Hm y. -destruct (E.eq_dec k y) as [H|H]. -- rewrite <-H, add_spec1. now rewrite Hk, add_spec1. -- rewrite !add_spec2; trivial. now rewrite <- Hk. -Qed. - -Instance remove_m {elt} : Proper (E.eq==>Equal==>Equal) (@remove elt). -Proof. -intros k k' Hk m m' Hm y. -destruct (E.eq_dec k y) as [H|H]. -- rewrite <-H, remove_spec1. now rewrite Hk, remove_spec1. -- rewrite !remove_spec2; trivial. now rewrite <- Hk. -Qed. - -Instance map_m {elt elt'} : - Proper ((Logic.eq==>Logic.eq)==>Equal==>Equal) (@map elt elt'). -Proof. -intros f f' Hf m m' Hm y. rewrite !map_spec, Hm. -destruct (find y m'); simpl; trivial. f_equal. now apply Hf. -Qed. - -Instance mapi_m {elt elt'} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@mapi elt elt'). -Proof. -intros f f' Hf m m' Hm y. -destruct (mapi_spec f m y) as (x,(Hx,->)). -destruct (mapi_spec f' m' y) as (x',(Hx',->)). -rewrite <- Hm. destruct (find y m); trivial. simpl. -f_equal. apply Hf; trivial. now rewrite Hx, Hx'. -Qed. - -Instance merge_m {elt elt' elt''} : - Proper ((E.eq==>Logic.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal==>Equal) - (@merge elt elt' elt''). -Proof. -intros f f' Hf m1 m1' Hm1 m2 m2' Hm2 y. -destruct (find y m1) as [e1|] eqn:H1. -- apply find_spec in H1. - assert (H : In y m1 \/ In y m2) by (left; now exists e1). - destruct (merge_spec1 f H) as (y1,(Hy1,->)). - rewrite Hm1,Hm2 in H. - destruct (merge_spec1 f' H) as (y2,(Hy2,->)). - rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y. -- destruct (find y m2) as [e2|] eqn:H2. - + apply find_spec in H2. - assert (H : In y m1 \/ In y m2) by (right; now exists e2). - destruct (merge_spec1 f H) as (y1,(Hy1,->)). - rewrite Hm1,Hm2 in H. - destruct (merge_spec1 f' H) as (y2,(Hy2,->)). - rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y. - + apply not_in_find in H1. apply not_in_find in H2. - assert (H : ~In y (merge f m1 m2)). - { intro H. apply merge_spec2 in H. intuition. } - apply not_in_find in H. rewrite H. - symmetry. apply not_in_find. intro H'. - apply merge_spec2 in H'. rewrite <- Hm1, <- Hm2 in H'. - intuition. -Qed. - -(* Later: compatibility for cardinal, fold, ... *) - -(** ** Earlier specifications (cf. FMaps) *) - -Section OldSpecs. -Variable elt: Type. -Implicit Type m: t elt. -Implicit Type x y z: key. -Implicit Type e: elt. - -Lemma MapsTo_1 m x y e : E.eq x y -> MapsTo x e m -> MapsTo y e m. -Proof. - now intros ->. -Qed. - -Lemma find_1 m x e : MapsTo x e m -> find x m = Some e. -Proof. apply find_spec. Qed. - -Lemma find_2 m x e : find x m = Some e -> MapsTo x e m. -Proof. apply find_spec. Qed. - -Lemma mem_1 m x : In x m -> mem x m = true. -Proof. apply mem_spec. Qed. - -Lemma mem_2 m x : mem x m = true -> In x m. -Proof. apply mem_spec. Qed. - -Lemma empty_1 : Empty (@empty elt). -Proof. - intros x e. now rewrite <- find_spec, empty_spec. -Qed. - -Lemma is_empty_1 m : Empty m -> is_empty m = true. -Proof. - unfold Empty; rewrite is_empty_spec. setoid_rewrite <- find_spec. - intros H x. specialize (H x). - destruct (find x m) as [e|]; trivial. - now destruct (H e). -Qed. - -Lemma is_empty_2 m : is_empty m = true -> Empty m. -Proof. - rewrite is_empty_spec. intros H x e. now rewrite <- find_spec, H. -Qed. - -Lemma add_1 m x y e : E.eq x y -> MapsTo y e (add x e m). -Proof. - intros <-. rewrite <-find_spec. apply add_spec1. -Qed. - -Lemma add_2 m x y e e' : - ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). -Proof. - intro. now rewrite <- !find_spec, add_spec2. -Qed. - -Lemma add_3 m x y e e' : - ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. -Proof. - intro. rewrite <- !find_spec, add_spec2; trivial. -Qed. - -Lemma remove_1 m x y : E.eq x y -> ~ In y (remove x m). -Proof. - intros <-. apply not_in_find. apply remove_spec1. -Qed. - -Lemma remove_2 m x y e : - ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). -Proof. - intro. now rewrite <- !find_spec, remove_spec2. -Qed. - -Lemma remove_3bis m x y e : - find y (remove x m) = Some e -> find y m = Some e. -Proof. - destruct (E.eq_dec x y) as [<-|H]. - - now rewrite remove_spec1. - - now rewrite remove_spec2. -Qed. - -Lemma remove_3 m x y e : MapsTo y e (remove x m) -> MapsTo y e m. -Proof. - rewrite <-!find_spec. apply remove_3bis. -Qed. - -Lemma bindings_1 m x e : - MapsTo x e m -> InA eq_key_elt (x,e) (bindings m). -Proof. apply bindings_spec1. Qed. - -Lemma bindings_2 m x e : - InA eq_key_elt (x,e) (bindings m) -> MapsTo x e m. -Proof. apply bindings_spec1. Qed. - -Lemma bindings_3w m : NoDupA eq_key (bindings m). -Proof. apply bindings_spec2w. Qed. - -Lemma cardinal_1 m : cardinal m = length (bindings m). -Proof. apply cardinal_spec. Qed. - -Lemma fold_1 m (A : Type) (i : A) (f : key -> elt -> A -> A) : - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. -Proof. apply fold_spec. Qed. - -Lemma equal_1 m m' cmp : Equivb cmp m m' -> equal cmp m m' = true. -Proof. apply equal_spec. Qed. - -Lemma equal_2 m m' cmp : equal cmp m m' = true -> Equivb cmp m m'. -Proof. apply equal_spec. Qed. - -End OldSpecs. - -Lemma map_1 {elt elt'}(m: t elt)(x:key)(e:elt)(f:elt->elt') : - MapsTo x e m -> MapsTo x (f e) (map f m). -Proof. - rewrite <- !find_spec, map_spec. now intros ->. -Qed. - -Lemma map_2 {elt elt'}(m: t elt)(x:key)(f:elt->elt') : - In x (map f m) -> In x m. -Proof. - rewrite !in_find, map_spec. apply option_map_some. -Qed. - -Lemma mapi_1 {elt elt'}(m: t elt)(x:key)(e:elt)(f:key->elt->elt') : - MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). -Proof. - destruct (mapi_spec f m x) as (y,(Hy,Eq)). - intro H. exists y; split; trivial. - rewrite <-find_spec in *. now rewrite Eq, H. -Qed. - -Lemma mapi_2 {elt elt'}(m: t elt)(x:key)(f:key->elt->elt') : - In x (mapi f m) -> In x m. -Proof. - destruct (mapi_spec f m x) as (y,(Hy,Eq)). - rewrite !in_find. intro H; contradict H. now rewrite Eq, H. -Qed. - -(** The ancestor [map2] of the current [merge] was dealing with functions - on datas only, not on keys. *) - -Definition map2 {elt elt' elt''} (f:option elt->option elt'->option elt'') - := merge (fun _ => f). - -Lemma map2_1 {elt elt' elt''}(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt'') : - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). -Proof. - intros. unfold map2. - now destruct (merge_spec1 (fun _ => f) H) as (y,(_,->)). -Qed. - -Lemma map2_2 {elt elt' elt''}(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt'') : - In x (map2 f m m') -> In x m \/ In x m'. -Proof. apply merge_spec2. Qed. - -Hint Immediate MapsTo_1 mem_2 is_empty_2 - map_2 mapi_2 add_3 remove_3 find_2 : map. -Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1 - remove_2 find_1 fold_1 map_1 mapi_1 mapi_2 : map. - -(** ** Specifications written using equivalences *) - -Section IffSpec. -Variable elt: Type. -Implicit Type m: t elt. -Implicit Type x y z: key. -Implicit Type e: elt. - -Lemma in_iff m x y : E.eq x y -> (In x m <-> In y m). -Proof. now intros ->. Qed. - -Lemma mapsto_iff m x y e : E.eq x y -> (MapsTo x e m <-> MapsTo y e m). -Proof. now intros ->. Qed. - -Lemma mem_in_iff m x : In x m <-> mem x m = true. -Proof. symmetry. apply mem_spec. Qed. - -Lemma not_mem_in_iff m x : ~In x m <-> mem x m = false. -Proof. -rewrite mem_in_iff; destruct (mem x m); intuition. -Qed. - -Lemma mem_find m x : mem x m = true <-> find x m <> None. -Proof. - rewrite <- mem_in_iff. apply in_find. -Qed. - -Lemma not_mem_find m x : mem x m = false <-> find x m = None. -Proof. - rewrite <- not_mem_in_iff. apply not_in_find. -Qed. - -Lemma In_dec m x : { In x m } + { ~ In x m }. -Proof. - generalize (mem_in_iff m x). - destruct (mem x m); [left|right]; intuition. -Qed. - -Lemma find_mapsto_iff m x e : MapsTo x e m <-> find x m = Some e. -Proof. symmetry. apply find_spec. Qed. - -Lemma equal_iff m m' cmp : Equivb cmp m m' <-> equal cmp m m' = true. -Proof. symmetry. apply equal_spec. Qed. - -Lemma empty_mapsto_iff x e : MapsTo x e empty <-> False. -Proof. -rewrite <- find_spec, empty_spec. now split. -Qed. - -Lemma not_in_empty x : ~In x (@empty elt). -Proof. -intros (e,H). revert H. apply empty_mapsto_iff. -Qed. - -Lemma empty_in_iff x : In x (@empty elt) <-> False. -Proof. -split; [ apply not_in_empty | destruct 1 ]. -Qed. - -Lemma is_empty_iff m : Empty m <-> is_empty m = true. -Proof. split; [apply is_empty_1 | apply is_empty_2 ]. Qed. - -Lemma add_mapsto_iff m x y e e' : - MapsTo y e' (add x e m) <-> - (E.eq x y /\ e=e') \/ - (~E.eq x y /\ MapsTo y e' m). -Proof. -split. -- intros H. destruct (E.eq_dec x y); [left|right]; split; trivial. - + symmetry. apply (mapsto_fun H); auto with map. - + now apply add_3 with x e. -- destruct 1 as [(H,H')|(H,H')]; subst; auto with map. -Qed. - -Lemma add_mapsto_new m x y e e' : ~In x m -> - MapsTo y e' (add x e m) <-> (E.eq x y /\ e=e') \/ MapsTo y e' m. -Proof. - intros. - rewrite add_mapsto_iff. intuition. - right; split; trivial. contradict H. exists e'. now rewrite H. -Qed. - -Lemma in_add m x y e : In y m -> In y (add x e m). -Proof. - destruct (E.eq_dec x y) as [<-|H']. - - now rewrite !in_find, add_spec1. - - now rewrite !in_find, add_spec2. -Qed. - -Lemma add_in_iff m x y e : In y (add x e m) <-> E.eq x y \/ In y m. -Proof. -split. -- intros H. destruct (E.eq_dec x y); [now left|right]. - rewrite in_find, add_spec2 in H; trivial. now apply in_find. -- intros [<-|H]. - + exists e. now apply add_1. - + now apply in_add. -Qed. - -Lemma add_neq_mapsto_iff m x y e e' : - ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). -Proof. -split; [apply add_3|apply add_2]; auto. -Qed. - -Lemma add_neq_in_iff m x y e : - ~ E.eq x y -> (In y (add x e m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -- now apply add_3 with x e. -- now apply add_2. -Qed. - -Lemma remove_mapsto_iff m x y e : - MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. -Proof. -split; [split|destruct 1]. -- intro E. revert H. now rewrite <-E, <- find_spec, remove_spec1. -- now apply remove_3 with x. -- now apply remove_2. -Qed. - -Lemma remove_in_iff m x y : In y (remove x m) <-> ~E.eq x y /\ In y m. -Proof. -unfold In; split; [ intros (e,H) | intros (E,(e,H)) ]. -- apply remove_mapsto_iff in H. destruct H; split; trivial. - now exists e. -- exists e. now apply remove_2. -Qed. - -Lemma remove_neq_mapsto_iff : forall m x y e, - ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m). -Proof. -split; [apply remove_3|apply remove_2]; auto. -Qed. - -Lemma remove_neq_in_iff : forall m x y, - ~ E.eq x y -> (In y (remove x m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -- now apply remove_3 with x. -- now apply remove_2. -Qed. - -Lemma bindings_mapsto_iff m x e : - MapsTo x e m <-> InA eq_key_elt (x,e) (bindings m). -Proof. symmetry. apply bindings_spec1. Qed. - -Lemma bindings_in_iff m x : - In x m <-> exists e, InA eq_key_elt (x,e) (bindings m). -Proof. -unfold In; split; intros (e,H); exists e; now apply bindings_spec1. -Qed. - -End IffSpec. - -Lemma map_mapsto_iff {elt elt'} m x b (f : elt -> elt') : - MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. -Proof. -rewrite <-find_spec, map_spec. setoid_rewrite <- find_spec. -destruct (find x m); simpl; split. -- injection 1. now exists e. -- intros (a,(->,H)). now injection H as ->. -- discriminate. -- intros (a,(_,H)); discriminate. -Qed. - -Lemma map_in_iff {elt elt'} m x (f : elt -> elt') : - In x (map f m) <-> In x m. -Proof. -rewrite !in_find, map_spec. apply option_map_some. -Qed. - -Lemma mapi_in_iff {elt elt'} m x (f:key->elt->elt') : - In x (mapi f m) <-> In x m. -Proof. -rewrite !in_find. destruct (mapi_spec f m x) as (y,(_,->)). -apply option_map_some. -Qed. - -(** Unfortunately, we don't have simple equivalences for [mapi] - and [MapsTo]. The only correct one needs compatibility of [f]. *) - -Lemma mapi_inv {elt elt'} m x b (f : key -> elt -> elt') : - MapsTo x b (mapi f m) -> - exists a y, E.eq y x /\ b = f y a /\ MapsTo x a m. -Proof. -rewrite <- find_spec. setoid_rewrite <- find_spec. -destruct (mapi_spec f m x) as (y,(E,->)). -destruct (find x m); simpl. -- injection 1 as <-. now exists e, y. -- discriminate. -Qed. - -Lemma mapi_spec' {elt elt'} (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - forall m x, - find x (mapi f m) = option_map (f x) (find x m). -Proof. - intros. destruct (mapi_spec f m x) as (y,(Hy,->)). - destruct (find x m); simpl; trivial. - now rewrite Hy. -Qed. - -Lemma mapi_1bis {elt elt'} m x e (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - MapsTo x e m -> MapsTo x (f x e) (mapi f m). -Proof. -intros. destruct (mapi_1 f H0) as (y,(->,H2)). trivial. -Qed. - -Lemma mapi_mapsto_iff {elt elt'} m x b (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). -Proof. -rewrite <-find_spec. setoid_rewrite <-find_spec. -intros Pr. rewrite mapi_spec' by trivial. -destruct (find x m); simpl; split. -- injection 1 as <-. now exists e. -- intros (a,(->,H)). now injection H as <-. -- discriminate. -- intros (a,(_,H)). discriminate. -Qed. - -(** Things are even worse for [merge] : we don't try to state any - equivalence, see instead boolean results below. *) - -(** Useful tactic for simplifying expressions like - [In y (add x e (remove z m))] *) - -Ltac map_iff := - repeat (progress ( - rewrite add_mapsto_iff || rewrite add_in_iff || - rewrite remove_mapsto_iff || rewrite remove_in_iff || - rewrite empty_mapsto_iff || rewrite empty_in_iff || - rewrite map_mapsto_iff || rewrite map_in_iff || - rewrite mapi_in_iff)). - -(** ** Specifications written using boolean predicates *) - -Section BoolSpec. - -Lemma mem_find_b {elt}(m:t elt)(x:key) : - mem x m = if find x m then true else false. -Proof. -apply eq_bool_alt. rewrite mem_find. destruct (find x m). -- now split. -- split; (discriminate || now destruct 1). -Qed. - -Variable elt elt' elt'' : Type. -Implicit Types m : t elt. -Implicit Types x y z : key. -Implicit Types e : elt. - -Lemma mem_b m x y : E.eq x y -> mem x m = mem y m. -Proof. now intros ->. Qed. - -Lemma find_o m x y : E.eq x y -> find x m = find y m. -Proof. now intros ->. Qed. - -Lemma empty_o x : find x (@empty elt) = None. -Proof. apply empty_spec. Qed. - -Lemma empty_a x : mem x (@empty elt) = false. -Proof. apply not_mem_find. apply empty_spec. Qed. - -Lemma add_eq_o m x y e : - E.eq x y -> find y (add x e m) = Some e. -Proof. - intros <-. apply add_spec1. -Qed. - -Lemma add_neq_o m x y e : - ~ E.eq x y -> find y (add x e m) = find y m. -Proof. apply add_spec2. Qed. -Hint Resolve add_neq_o : map. - -Lemma add_o m x y e : - find y (add x e m) = if E.eq_dec x y then Some e else find y m. -Proof. -destruct (E.eq_dec x y); auto with map. -Qed. - -Lemma add_eq_b m x y e : - E.eq x y -> mem y (add x e m) = true. -Proof. -intros <-. apply mem_spec, add_in_iff. now left. -Qed. - -Lemma add_neq_b m x y e : - ~E.eq x y -> mem y (add x e m) = mem y m. -Proof. -intros. now rewrite !mem_find_b, add_neq_o. -Qed. - -Lemma add_b m x y e : - mem y (add x e m) = eqb x y || mem y m. -Proof. -rewrite !mem_find_b, add_o. unfold eqb. -now destruct (E.eq_dec x y). -Qed. - -Lemma remove_eq_o m x y : - E.eq x y -> find y (remove x m) = None. -Proof. intros ->. apply remove_spec1. Qed. - -Lemma remove_neq_o m x y : - ~ E.eq x y -> find y (remove x m) = find y m. -Proof. apply remove_spec2. Qed. - -Hint Resolve remove_eq_o remove_neq_o : map. - -Lemma remove_o m x y : - find y (remove x m) = if E.eq_dec x y then None else find y m. -Proof. -destruct (E.eq_dec x y); auto with map. -Qed. - -Lemma remove_eq_b m x y : - E.eq x y -> mem y (remove x m) = false. -Proof. -intros <-. now rewrite mem_find_b, remove_eq_o. -Qed. - -Lemma remove_neq_b m x y : - ~ E.eq x y -> mem y (remove x m) = mem y m. -Proof. -intros. now rewrite !mem_find_b, remove_neq_o. -Qed. - -Lemma remove_b m x y : - mem y (remove x m) = negb (eqb x y) && mem y m. -Proof. -rewrite !mem_find_b, remove_o; unfold eqb. -now destruct (E.eq_dec x y). -Qed. - -Lemma map_o m x (f:elt->elt') : - find x (map f m) = option_map f (find x m). -Proof. apply map_spec. Qed. - -Lemma map_b m x (f:elt->elt') : - mem x (map f m) = mem x m. -Proof. -rewrite !mem_find_b, map_o. now destruct (find x m). -Qed. - -Lemma mapi_b m x (f:key->elt->elt') : - mem x (mapi f m) = mem x m. -Proof. -apply eq_bool_alt; rewrite !mem_spec. apply mapi_in_iff. -Qed. - -Lemma mapi_o m x (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - find x (mapi f m) = option_map (f x) (find x m). -Proof. intros; now apply mapi_spec'. Qed. - -Lemma merge_spec1' (f:key->option elt->option elt'->option elt'') : - Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f -> - forall (m:t elt)(m':t elt') x, - In x m \/ In x m' -> - find x (merge f m m') = f x (find x m) (find x m'). -Proof. - intros Hf m m' x H. - now destruct (merge_spec1 f H) as (y,(->,->)). -Qed. - -Lemma merge_spec1_none (f:key->option elt->option elt'->option elt'') : - (forall x, f x None None = None) -> - forall (m: t elt)(m': t elt') x, - exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). -Proof. -intros Hf m m' x. -destruct (find x m) as [e|] eqn:Hm. -- assert (H : In x m \/ In x m') by (left; exists e; now apply find_spec). - destruct (merge_spec1 f H) as (y,(Hy,->)). - exists y; split; trivial. now rewrite Hm. -- destruct (find x m') as [e|] eqn:Hm'. - + assert (H : In x m \/ In x m') by (right; exists e; now apply find_spec). - destruct (merge_spec1 f H) as (y,(Hy,->)). - exists y; split; trivial. now rewrite Hm, Hm'. - + exists x. split. reflexivity. rewrite Hf. - apply not_in_find. intro H. - apply merge_spec2 in H. apply not_in_find in Hm. apply not_in_find in Hm'. - intuition. -Qed. - -Lemma merge_spec1'_none (f:key->option elt->option elt'->option elt'') : - Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f -> - (forall x, f x None None = None) -> - forall (m: t elt)(m': t elt') x, - find x (merge f m m') = f x (find x m) (find x m'). -Proof. - intros Hf Hf' m m' x. - now destruct (merge_spec1_none Hf' m m' x) as (y,(->,->)). -Qed. - -Lemma bindings_o : forall m x, - find x m = findA (eqb x) (bindings m). -Proof. -intros. rewrite eq_option_alt. intro e. -rewrite <- find_mapsto_iff, bindings_mapsto_iff. -unfold eqb. -rewrite <- findA_NoDupA; dintuition; try apply bindings_3w; eauto. -Qed. - -Lemma bindings_b : forall m x, - mem x m = existsb (fun p => eqb x (fst p)) (bindings m). -Proof. -intros. -apply eq_bool_alt. -rewrite mem_spec, bindings_in_iff, existsb_exists. -split. -- intros (e,H). - rewrite InA_alt in H. - destruct H as ((k,e'),((H1,H2),H')); simpl in *; subst e'. - exists (k, e); split; trivial. simpl. now apply eqb_eq. -- intros ((k,e),(H,H')); simpl in *. apply eqb_eq in H'. - exists e. rewrite InA_alt. exists (k,e). now repeat split. -Qed. - -End BoolSpec. - -Section Equalities. -Variable elt:Type. - -(** A few basic equalities *) - -Lemma eq_empty (m: t elt) : m == empty <-> is_empty m = true. -Proof. - unfold Equal. rewrite is_empty_spec. now setoid_rewrite empty_spec. -Qed. - -Lemma add_id (m: t elt) x e : add x e m == m <-> find x m = Some e. -Proof. - split. - - intros H. rewrite <- (H x). apply add_spec1. - - intros H y. rewrite !add_o. now destruct E.eq_dec as [<-|E]. -Qed. - -Lemma add_add_1 (m: t elt) x e : - add x e (add x e m) == add x e m. -Proof. - intros y. rewrite !add_o. destruct E.eq_dec; auto. -Qed. - -Lemma add_add_2 (m: t elt) x x' e e' : - ~E.eq x x' -> add x e (add x' e' m) == add x' e' (add x e m). -Proof. - intros H y. rewrite !add_o. - do 2 destruct E.eq_dec; auto. - elim H. now transitivity y. -Qed. - -Lemma remove_id (m: t elt) x : remove x m == m <-> ~In x m. -Proof. - rewrite not_in_find. split. - - intros H. rewrite <- (H x). apply remove_spec1. - - intros H y. rewrite !remove_o. now destruct E.eq_dec as [<-|E]. -Qed. - -Lemma remove_remove_1 (m: t elt) x : - remove x (remove x m) == remove x m. -Proof. - intros y. rewrite !remove_o. destruct E.eq_dec; auto. -Qed. - -Lemma remove_remove_2 (m: t elt) x x' : - remove x (remove x' m) == remove x' (remove x m). -Proof. - intros y. rewrite !remove_o. do 2 destruct E.eq_dec; auto. -Qed. - -Lemma remove_add_1 (m: t elt) x e : - remove x (add x e m) == remove x m. -Proof. - intro y. rewrite !remove_o, !add_o. now destruct E.eq_dec. -Qed. - -Lemma remove_add_2 (m: t elt) x x' e : - ~E.eq x x' -> remove x' (add x e m) == add x e (remove x' m). -Proof. - intros H y. rewrite !remove_o, !add_o. - do 2 destruct E.eq_dec; auto. - - elim H; now transitivity y. - - symmetry. now apply remove_eq_o. - - symmetry. now apply remove_neq_o. -Qed. - -Lemma add_remove_1 (m: t elt) x e : - add x e (remove x m) == add x e m. -Proof. - intro y. rewrite !add_o, !remove_o. now destruct E.eq_dec. -Qed. - -(** Another characterisation of [Equal] *) - -Lemma Equal_mapsto_iff : forall m1 m2 : t elt, - m1 == m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2). -Proof. -intros m1 m2. split; [intros Heq k e|intros Hiff]. -rewrite 2 find_mapsto_iff, Heq. split; auto. -intro k. rewrite eq_option_alt. intro e. -rewrite <- 2 find_mapsto_iff; auto. -Qed. - -(** * Relations between [Equal], [Equiv] and [Equivb]. *) - -(** First, [Equal] is [Equiv] with Leibniz on elements. *) - -Lemma Equal_Equiv : forall (m m' : t elt), - m == m' <-> Equiv Logic.eq m m'. -Proof. -intros. rewrite Equal_mapsto_iff. split; intros. -- split. - + split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto. - + intros; apply mapsto_fun with m k; auto; rewrite H; auto. -- split; intros H'. - + destruct H. - assert (Hin : In k m') by (rewrite <- H; exists e; auto). - destruct Hin as (e',He'). - rewrite (H0 k e e'); auto. - + destruct H. - assert (Hin : In k m) by (rewrite H; exists e; auto). - destruct Hin as (e',He'). - rewrite <- (H0 k e' e); auto. -Qed. - -(** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp] - are related. *) - -Section Cmp. -Variable eq_elt : elt->elt->Prop. -Variable cmp : elt->elt->bool. - -Definition compat_cmp := - forall e e', cmp e e' = true <-> eq_elt e e'. - -Lemma Equiv_Equivb : compat_cmp -> - forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'. -Proof. - unfold Equivb, Equiv, Cmp; intuition. - red in H; rewrite H; eauto. - red in H; rewrite <-H; eauto. -Qed. -End Cmp. - -(** Composition of the two last results: relation between [Equal] - and [Equivb]. *) - -Lemma Equal_Equivb : forall cmp, - (forall e e', cmp e e' = true <-> e = e') -> - forall (m m':t elt), m == m' <-> Equivb cmp m m'. -Proof. - intros; rewrite Equal_Equiv. - apply Equiv_Equivb; auto. -Qed. - -Lemma Equal_Equivb_eqdec : - forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }), - let cmp := fun e e' => if eq_elt_dec e e' then true else false in - forall (m m':t elt), m == m' <-> Equivb cmp m m'. -Proof. -intros; apply Equal_Equivb. -unfold cmp; clear cmp; intros. -destruct eq_elt_dec; now intuition. -Qed. - -End Equalities. - -(** * Results about [fold], [bindings], induction principles... *) - -Section Elt. - Variable elt:Type. - - Definition Add x (e:elt) m m' := m' == (add x e m). - - Notation eqke := (@eq_key_elt elt). - Notation eqk := (@eq_key elt). - - Instance eqk_equiv : Equivalence eqk. - Proof. unfold eq_key. destruct E.eq_equiv. constructor; eauto. Qed. - - Instance eqke_equiv : Equivalence eqke. - Proof. - unfold eq_key_elt; split; repeat red; intuition; simpl in *; - etransitivity; eauto. - Qed. - - (** Complements about InA, NoDupA and findA *) - - Lemma InA_eqke_eqk k k' e e' l : - E.eq k k' -> InA eqke (k,e) l -> InA eqk (k',e') l. - Proof. - intros Hk. rewrite 2 InA_alt. - intros ((k'',e'') & (Hk'',He'') & H); simpl in *; subst e''. - exists (k'',e); split; auto. red; simpl. now transitivity k. - Qed. - - Lemma NoDupA_incl {A} (R R':relation A) : - (forall x y, R x y -> R' x y) -> - forall l, NoDupA R' l -> NoDupA R l. - Proof. - intros Incl. - induction 1 as [ | a l E _ IH ]; constructor; auto. - contradict E. revert E. rewrite 2 InA_alt. firstorder. - Qed. - - Lemma NoDupA_eqk_eqke l : NoDupA eqk l -> NoDupA eqke l. - Proof. - apply NoDupA_incl. now destruct 1. - Qed. - - Lemma findA_rev l k : NoDupA eqk l -> - findA (eqb k) l = findA (eqb k) (rev l). - Proof. - intros H. apply eq_option_alt. intros e. unfold eqb. - rewrite <- !findA_NoDupA, InA_rev; eauto with map. reflexivity. - change (NoDupA eqk (rev l)). apply NoDupA_rev; auto using eqk_equiv. - Qed. - - (** * Bindings *) - - Lemma bindings_Empty (m:t elt) : Empty m <-> bindings m = nil. - Proof. - unfold Empty. split; intros H. - - assert (H' : forall a, ~ List.In a (bindings m)). - { intros (k,e) H'. apply (H k e). - rewrite bindings_mapsto_iff, InA_alt. - exists (k,e); repeat split; auto with map. } - destruct (bindings m) as [|p l]; trivial. - destruct (H' p); simpl; auto. - - intros x e. rewrite bindings_mapsto_iff, InA_alt. - rewrite H. now intros (y,(E,H')). - Qed. - - Lemma bindings_empty : bindings (@empty elt) = nil. - Proof. - rewrite <-bindings_Empty; apply empty_1. - Qed. - - (** * Conversions between maps and association lists. *) - - Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W := - fun p => f (fst p) (snd p). - - Definition of_list := - List.fold_right (uncurry (@add _)) (@empty elt). - - Definition to_list := bindings. - - Lemma of_list_1 : forall l k e, - NoDupA eqk l -> - (MapsTo k e (of_list l) <-> InA eqke (k,e) l). - Proof. - induction l as [|(k',e') l IH]; simpl; intros k e Hnodup. - - rewrite empty_mapsto_iff, InA_nil; intuition. - - unfold uncurry; simpl. - inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. - specialize (IH k e Hnodup'); clear Hnodup'. - rewrite add_mapsto_iff, InA_cons, <- IH. - unfold eq_key_elt at 1; simpl. - split; destruct 1 as [H|H]; try (intuition;fail). - destruct (E.eq_dec k k'); [left|right]; split; auto with map. - contradict Hnotin. - apply InA_eqke_eqk with k e; intuition. - Qed. - - Lemma of_list_1b : forall l k, - NoDupA eqk l -> - find k (of_list l) = findA (eqb k) l. - Proof. - induction l as [|(k',e') l IH]; simpl; intros k Hnodup. - apply empty_o. - unfold uncurry; simpl. - inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. - specialize (IH k Hnodup'); clear Hnodup'. - rewrite add_o, IH, eqb_sym. unfold eqb; now destruct E.eq_dec. - Qed. - - Lemma of_list_2 : forall l, NoDupA eqk l -> - equivlistA eqke l (to_list (of_list l)). - Proof. - intros l Hnodup (k,e). - rewrite <- bindings_mapsto_iff, of_list_1; intuition. - Qed. - - Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s. - Proof. - intros s k. - rewrite of_list_1b, bindings_o; auto. - apply bindings_3w. - Qed. - - (** * Fold *) - - (** Alternative specification via [fold_right] *) - - Lemma fold_spec_right m (A:Type)(i:A)(f : key -> elt -> A -> A) : - fold f m i = List.fold_right (uncurry f) i (rev (bindings m)). - Proof. - rewrite fold_1. symmetry. apply fold_left_rev_right. - Qed. - - (** ** Induction principles about fold contributed by S. Lescuyer *) - - (** In the following lemma, the step hypothesis is deliberately restricted - to the precise map m we are considering. *) - - Lemma fold_rec : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), - forall (i:A)(m:t elt), - (forall m, Empty m -> P m i) -> - (forall k e a m' m'', MapsTo k e m -> ~In k m' -> - Add k e m' m'' -> P m' a -> P m'' (f k e a)) -> - P m (fold f m i). - Proof. - intros A P f i m Hempty Hstep. - rewrite fold_spec_right. - set (F:=uncurry f). - set (l:=rev (bindings m)). - assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> - Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). - { - intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. - revert H; unfold l; rewrite InA_rev, bindings_mapsto_iff; auto with *. } - assert (Hdup : NoDupA eqk l). - { unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *. - apply bindings_3w. } - assert (Hsame : forall k, find k m = findA (eqb k) l). - { intros k. unfold l. rewrite bindings_o, findA_rev; auto. - apply bindings_3w. } - clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l. - - (* empty *) - intros m Hsame; simpl. - apply Hempty. intros k e. - rewrite find_mapsto_iff, Hsame; simpl; discriminate. - - (* step *) - intros m Hsame; destruct a as (k,e); simpl. - apply Hstep' with (of_list l); auto. - + rewrite InA_cons; left; red; auto with map. - + inversion_clear Hdup. contradict H. destruct H as (e',He'). - apply InA_eqke_eqk with k e'; auto with map. - rewrite <- of_list_1; auto. - + intro k'. rewrite Hsame, add_o, of_list_1b. simpl. - rewrite eqb_sym. unfold eqb. now destruct E.eq_dec. - inversion_clear Hdup; auto with map. - + apply IHl. - * intros; eapply Hstep'; eauto. - * inversion_clear Hdup; auto. - * intros; apply of_list_1b. inversion_clear Hdup; auto. - Qed. - - (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this - case, [P] must be compatible with equality of sets *) - - Theorem fold_rec_bis : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), - forall (i:A)(m:t elt), - (forall m m' a, Equal m m' -> P m a -> P m' a) -> - (P empty i) -> - (forall k e a m', MapsTo k e m -> ~In k m' -> - P m' a -> P (add k e m') (f k e a)) -> - P m (fold f m i). - Proof. - intros A P f i m Pmorphism Pempty Pstep. - apply fold_rec; intros. - apply Pmorphism with empty; auto. intro k. rewrite empty_o. - case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff. - intro H'; elim (H k e'); auto. - apply Pmorphism with (add k e m'); try intro; auto. - Qed. - - Lemma fold_rec_nodep : - forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt), - P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) -> - P (fold f m i). - Proof. - intros; apply fold_rec_bis with (P:=fun _ => P); auto. - Qed. - - (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : - the step hypothesis must here be applicable anywhere. - At the same time, it looks more like an induction principle, - and hence can be easier to use. *) - - Lemma fold_rec_weak : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A)(i:A), - (forall m m' a, Equal m m' -> P m a -> P m' a) -> - P empty i -> - (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) -> - forall m, P m (fold f m i). - Proof. - intros; apply fold_rec_bis; auto. - Qed. - - Lemma fold_rel : - forall (A B:Type)(R : A -> B -> Type) - (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B) - (m : t elt), - R i j -> - (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) -> - R (fold f m i) (fold g m j). - Proof. - intros A B R f g i j m Rempty Rstep. - rewrite 2 fold_spec_right. set (l:=rev (bindings m)). - assert (Rstep' : forall k e a b, InA eqke (k,e) l -> - R a b -> R (f k e a) (g k e b)). - { intros; apply Rstep; auto. - rewrite bindings_mapsto_iff, <- InA_rev; auto with map. } - clearbody l; clear Rstep m. - induction l; simpl; auto. - apply Rstep'; auto. - destruct a; simpl; rewrite InA_cons; left; red; auto with map. - Qed. - - (** From the induction principle on [fold], we can deduce some general - induction principles on maps. *) - - Lemma map_induction : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. - Qed. - - Lemma map_induction_bis : - forall P : t elt -> Type, - (forall m m', Equal m m' -> P m -> P m') -> - P empty -> - (forall x e m, ~In x m -> P m -> P (add x e m)) -> - forall m, P m. - Proof. - intros. - apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. - Qed. - - (** [fold] can be used to reconstruct the same initial set. *) - - Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m empty) m. - Proof. - intros. - apply fold_rec with (P:=fun m acc => Equal acc m); auto with map. - intros m' Heq k'. - rewrite empty_o. - case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff. - intro; elim (Heq k' e'); auto. - intros k e a m' m'' _ _ Hadd Heq k'. - red in Heq. rewrite Hadd, 2 add_o, Heq; auto. - Qed. - - Section Fold_More. - - (** ** Additional properties of fold *) - - (** When a function [f] is compatible and allows transpositions, we can - compute [fold f] in any order. *) - - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). - - Lemma fold_Empty (f:key->elt->A->A) : - forall m i, Empty m -> eqA (fold f m i) i. - Proof. - intros. apply fold_rec_nodep with (P:=fun a => eqA a i). - reflexivity. - intros. elim (H k e); auto. - Qed. - - Lemma fold_init (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). - Proof. - intros Hf m i i' Hi. apply fold_rel with (R:=eqA); auto. - intros. now apply Hf. - Qed. - - (** Transpositions of f (a.k.a diamond property). - Could we swap two sequential calls to f, i.e. do we have: - - f k e (f k' e' a) == f k' e' (f k e a) - - First, we do no need this equation for all keys, but only - when k and k' aren't equal, as suggested by Pierre Castéran. - Think for instance of [f] being [M.add] : in general, we don't have - [M.add k e (M.add k e' m) == M.add k e' (M.add k e m)]. - Fortunately, we will never encounter this situation during a real - [fold], since the keys received by this [fold] are unique. - NB: without this condition, this condition would be - [SetoidList.transpose2]. - - Secondly, instead of the equation above, we now use a statement - with more basic equalities, allowing to prove [fold_commutes] even - when [f] isn't a morphism. - NB: When [f] is a morphism, [Diamond f] gives back the equation above. -*) - - Definition Diamond (f:key->elt->A->A) := - forall k k' e e' a b b', ~E.eq k k' -> - eqA (f k e a) b -> eqA (f k' e' a) b' -> eqA (f k e b') (f k' e' b). - - Lemma fold_commutes (f:key->elt->A->A) : - Diamond f -> - forall i m k e, ~In k m -> - eqA (fold f m (f k e i)) (f k e (fold f m i)). - Proof. - intros Hf i m k e H. - apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto. - - reflexivity. - - intros k' e' b a Hm E. - apply Hf with a; try easy. - contradict H; rewrite <- H. now exists e'. - Qed. - - Hint Resolve NoDupA_eqk_eqke NoDupA_rev bindings_3w : map. - - Lemma fold_Proper (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - Proper (Equal==>eqA==>eqA) (fold f). - Proof. - intros Hf Hf' m1 m2 Hm i j Hi. - rewrite 2 fold_spec_right. - assert (NoDupA eqk (rev (bindings m1))) by (auto with * ). - assert (NoDupA eqk (rev (bindings m2))) by (auto with * ). - apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke) - ; auto with *. - - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *. now apply Hf. - - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto with map. - - intros (k,e) (k',e') z z' h h'; unfold eq_key, uncurry;simpl; auto. - rewrite h'. eapply Hf'; now eauto. - - rewrite <- NoDupA_altdef; auto. - - intros (k,e). - rewrite 2 InA_rev, <- 2 bindings_mapsto_iff, 2 find_mapsto_iff, Hm; - auto with *. - Qed. - - Lemma fold_Equal (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - forall m1 m2 i, - Equal m1 m2 -> - eqA (fold f m1 i) (fold f m2 i). - Proof. - intros. now apply fold_Proper. - Qed. - - Lemma fold_Add (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 -> - eqA (fold f m2 i) (f k e (fold f m1 i)). - Proof. - intros Hf Hf' m1 m2 k e i Hm1 Hm2. - rewrite 2 fold_spec_right. - set (f':=uncurry f). - change (f k e (fold_right f' i (rev (bindings m1)))) - with (f' (k,e) (fold_right f' i (rev (bindings m1)))). - assert (NoDupA eqk (rev (bindings m1))) by (auto with * ). - assert (NoDupA eqk (rev (bindings m2))) by (auto with * ). - apply fold_right_add_restr with - (R:=complement eqk)(eqA:=eqke); auto with *. - - intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. now apply Hf. - - unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto with map. - - intros (k1,e1) (k2,e2) z1 z2; unfold eq_key, f', uncurry; simpl. - eapply Hf'; now eauto. - - rewrite <- NoDupA_altdef; auto. - - rewrite InA_rev, <- bindings_mapsto_iff by (auto with * ). firstorder. - - intros (a,b). - rewrite InA_cons, 2 InA_rev, <- 2 bindings_mapsto_iff, - 2 find_mapsto_iff by (auto with * ). - unfold eq_key_elt; simpl. - rewrite Hm2, !find_spec, add_mapsto_new; intuition. - Qed. - - Lemma fold_add (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - forall m k e i, ~In k m -> - eqA (fold f (add k e m) i) (f k e (fold f m i)). - Proof. - intros. now apply fold_Add. - Qed. - - End Fold_More. - - (** * Cardinal *) - - Lemma cardinal_fold (m : t elt) : - cardinal m = fold (fun _ _ => S) m 0. - Proof. - rewrite cardinal_1, fold_1. - symmetry; apply fold_left_length; auto. - Qed. - - Lemma cardinal_Empty : forall m : t elt, - Empty m <-> cardinal m = 0. - Proof. - intros. - rewrite cardinal_1, bindings_Empty. - destruct (bindings m); intuition; discriminate. - Qed. - - Lemma Equal_cardinal (m m' : t elt) : - Equal m m' -> cardinal m = cardinal m'. - Proof. - intro. rewrite 2 cardinal_fold. - apply fold_Equal with (eqA:=eq); try congruence; auto with map. - Qed. - - Lemma cardinal_0 (m : t elt) : Empty m -> cardinal m = 0. - Proof. - intros; rewrite <- cardinal_Empty; auto. - Qed. - - Lemma cardinal_S m m' x e : - ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m). - Proof. - intros. rewrite 2 cardinal_fold. - change S with ((fun _ _ => S) x e). - apply fold_Add with (eqA:=eq); try congruence; auto with map. - Qed. - - Lemma cardinal_inv_1 : forall m : t elt, - cardinal m = 0 -> Empty m. - Proof. - intros; rewrite cardinal_Empty; auto. - Qed. - Hint Resolve cardinal_inv_1 : map. - - Lemma cardinal_inv_2 : - forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. - intros; rewrite M.cardinal_spec in *. - generalize (bindings_mapsto_iff m). - destruct (bindings m); try discriminate. - exists p; auto. - rewrite H0; destruct p; simpl; auto. - constructor; red; auto with map. - Qed. - - Lemma cardinal_inv_2b : - forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. - intros. - generalize (@cardinal_inv_2 m); destruct cardinal. - elim H;auto. - eauto. - Qed. - - Lemma not_empty_mapsto (m : t elt) : - ~Empty m -> exists k e, MapsTo k e m. - Proof. - intro. - destruct (@cardinal_inv_2b m) as ((k,e),H'). - contradict H. now apply cardinal_inv_1. - exists k; now exists e. - Qed. - - Lemma not_empty_in (m:t elt) : - ~Empty m -> exists k, In k m. - Proof. - intro. destruct (not_empty_mapsto H) as (k,Hk). - now exists k. - Qed. - - (** * Additional notions over maps *) - - Definition Disjoint (m m' : t elt) := - forall k, ~(In k m /\ In k m'). - - Definition Partition (m m1 m2 : t elt) := - Disjoint m1 m2 /\ - (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2). - - (** * Emulation of some functions lacking in the interface *) - - Definition filter (f : key -> elt -> bool)(m : t elt) := - fold (fun k e m => if f k e then add k e m else m) m empty. - - Definition for_all (f : key -> elt -> bool)(m : t elt) := - fold (fun k e b => if f k e then b else false) m true. - - Definition exists_ (f : key -> elt -> bool)(m : t elt) := - fold (fun k e b => if f k e then true else b) m false. - - Definition partition (f : key -> elt -> bool)(m : t elt) := - (filter f m, filter (fun k e => negb (f k e)) m). - - (** [update] adds to [m1] all the bindings of [m2]. It can be seen as - an [union] operator which gives priority to its 2nd argument - in case of binding conflit. *) - - Definition update (m1 m2 : t elt) := fold (@add _) m2 m1. - - (** [restrict] keeps from [m1] only the bindings whose key is in [m2]. - It can be seen as an [inter] operator, with priority to its 1st argument - in case of binding conflit. *) - - Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1. - - (** [diff] erases from [m1] all bindings whose key is in [m2]. *) - - Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1. - - (** Properties of these abbreviations *) - - Lemma filter_iff (f : key -> elt -> bool) : - Proper (E.eq==>eq==>eq) f -> - forall m k e, - MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. - Proof. - unfold filter. - set (f':=fun k e m => if f k e then add k e m else m). - intros Hf m. pattern m, (fold f' m empty). apply fold_rec. - - - intros m' Hm' k e. rewrite empty_mapsto_iff. intuition. - elim (Hm' k e); auto. - - - intros k e acc m1 m2 Hke Hn Hadd IH k' e'. - change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd. - unfold f'; simpl. - rewrite add_mapsto_new by trivial. - case_eq (f k e); intros Hfke; simpl; - rewrite ?add_mapsto_iff, IH; clear IH; intuition. - + rewrite <- Hfke; apply Hf; auto with map. - + right. repeat split; trivial. contradict Hn. rewrite Hn. now exists e'. - + assert (f k e = f k' e') by (apply Hf; auto). congruence. - Qed. - - Lemma for_all_filter f m : - for_all f m = is_empty (filter (fun k e => negb (f k e)) m). - Proof. - unfold for_all, filter. - eapply fold_rel with (R:=fun x y => x = is_empty y). - - symmetry. apply is_empty_iff. apply empty_1. - - intros; subst. destruct (f k e); simpl; trivial. - symmetry. apply not_true_is_false. rewrite is_empty_spec. - intros H'. specialize (H' k). now rewrite add_spec1 in H'. - Qed. - - Lemma exists_filter f m : - exists_ f m = negb (is_empty (filter f m)). - Proof. - unfold for_all, filter. - eapply fold_rel with (R:=fun x y => x = negb (is_empty y)). - - symmetry. rewrite negb_false_iff. apply is_empty_iff. apply empty_1. - - intros; subst. destruct (f k e); simpl; trivial. - symmetry. rewrite negb_true_iff. apply not_true_is_false. - rewrite is_empty_spec. - intros H'. specialize (H' k). now rewrite add_spec1 in H'. - Qed. - - Lemma for_all_iff f m : - Proper (E.eq==>eq==>eq) f -> - (for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true)). - Proof. - intros Hf. - rewrite for_all_filter. - rewrite <- is_empty_iff. unfold Empty. - split; intros H k e; specialize (H k e); - rewrite filter_iff in * by solve_proper; intuition. - - destruct (f k e); auto. - - now rewrite H0 in H2. - Qed. - - Lemma exists_iff f m : - Proper (E.eq==>eq==>eq) f -> - (exists_ f m = true <-> - (exists k e, MapsTo k e m /\ f k e = true)). - Proof. - intros Hf. - rewrite exists_filter. rewrite negb_true_iff. - rewrite <- not_true_iff_false, <- is_empty_iff. - split. - - intros H. apply not_empty_mapsto in H. now setoid_rewrite filter_iff in H. - - unfold Empty. setoid_rewrite filter_iff; trivial. firstorder. - Qed. - - Lemma Disjoint_alt : forall m m', - Disjoint m m' <-> - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False). - Proof. - unfold Disjoint; split. - intros H k v v' H1 H2. - apply H with k; split. - exists v; trivial. - exists v'; trivial. - intros H k ((v,Hv),(v',Hv')). - eapply H; eauto. - Qed. - - Section Partition. - Variable f : key -> elt -> bool. - Hypothesis Hf : Proper (E.eq==>eq==>eq) f. - - Lemma partition_iff_1 : forall m m1 k e, - m1 = fst (partition f m) -> - (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true). - Proof. - unfold partition; simpl; intros. subst m1. - apply filter_iff; auto. - Qed. - - Lemma partition_iff_2 : forall m m2 k e, - m2 = snd (partition f m) -> - (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false). - Proof. - unfold partition; simpl; intros. subst m2. - rewrite filter_iff. - split; intros (H,H'); split; auto. - destruct (f k e); simpl in *; auto. - rewrite H'; auto. - repeat red; intros. f_equal. apply Hf; auto. - Qed. - - Lemma partition_Partition : forall m m1 m2, - partition f m = (m1,m2) -> Partition m m1 m2. - Proof. - intros. split. - rewrite Disjoint_alt. intros k e e'. - rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) - by (rewrite H; auto). - intros (U,V) (W,Z). rewrite <- (mapsto_fun U W) in Z; congruence. - intros k e. - rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) - by (rewrite H; auto). - destruct (f k e); intuition. - Qed. - - End Partition. - - Lemma Partition_In : forall m m1 m2 k, - Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}. - Proof. - intros m m1 m2 k Hm Hk. - destruct (In_dec m1 k) as [H|H]; [left|right]; auto. - destruct Hm as (Hm,Hm'). - destruct Hk as (e,He); rewrite Hm' in He; destruct He. - elim H; exists e; auto. - exists e; auto. - Defined. - - Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1. - Proof. - intros m1 m2 H k (H1,H2). elim (H k); auto. - Qed. - - Lemma Partition_sym : forall m m1 m2, - Partition m m1 m2 -> Partition m m2 m1. - Proof. - intros m m1 m2 (H,H'); split. - apply Disjoint_sym; auto. - intros; rewrite H'; intuition. - Qed. - - Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 -> - (Empty m <-> (Empty m1 /\ Empty m2)). - Proof. - intros m m1 m2 (Hdisj,Heq). split. - intro He. - split; intros k e Hke; elim (He k e); rewrite Heq; auto. - intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke. - elim (He1 k e); auto. - elim (He2 k e); auto. - Qed. - - Lemma Partition_Add : - forall m m' x e , ~In x m -> Add x e m m' -> - forall m1 m2, Partition m' m1 m2 -> - exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/ - Add x e m3 m2 /\ Partition m m1 m3). - Proof. - unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor). - assert (Heq : Equal m (remove x m')). - { change (Equal m' (add x e m)) in Hadd. rewrite Hadd. - intro k. rewrite remove_o, add_o. - destruct E.eq_dec as [He|Hne]; auto. - rewrite <- He, <- not_find_in_iff; auto. } - assert (H : MapsTo x e m'). - { change (Equal m' (add x e m)) in Hadd; rewrite Hadd. - apply add_1; auto with map. } - rewrite Hor in H; destruct H. - - - (* first case : x in m1 *) - exists (remove x m1); left. split; [|split]. - + (* add *) - change (Equal m1 (add x e (remove x m1))). - intro k. - rewrite add_o, remove_o. - destruct E.eq_dec as [He|Hne]; auto. - rewrite <- He; apply find_1; auto. - + (* disjoint *) - intros k (H1,H2). elim (Hdisj k). split; auto. - rewrite remove_in_iff in H1; destruct H1; auto. - + (* mapsto *) - intros k' e'. - rewrite Heq, 2 remove_mapsto_iff, Hor. - intuition. - elim (Hdisj x); split; [exists e|exists e']; auto. - apply MapsTo_1 with k'; auto with map. - - - (* second case : x in m2 *) - exists (remove x m2); right. split; [|split]. - + (* add *) - change (Equal m2 (add x e (remove x m2))). - intro k. - rewrite add_o, remove_o. - destruct E.eq_dec as [He|Hne]; auto. - rewrite <- He; apply find_1; auto. - + (* disjoint *) - intros k (H1,H2). elim (Hdisj k). split; auto. - rewrite remove_in_iff in H2; destruct H2; auto. - + (* mapsto *) - intros k' e'. - rewrite Heq, 2 remove_mapsto_iff, Hor. - intuition. - elim (Hdisj x); split; [exists e'|exists e]; auto. - apply MapsTo_1 with k'; auto with map. - Qed. - - Lemma Partition_fold : - forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond eqA f -> - forall m m1 m2 i, - Partition m m1 m2 -> - eqA (fold f m i) (fold f m1 (fold f m2 i)). - Proof. - intros A eqA st f Comp Tra. - induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction. - - - intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto. - rewrite (Partition_Empty Hp) in Hm. destruct Hm. - rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity. - - - intros m1 m2 i Hp. - destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]). - + (* fst case: m3 is (k,e)::m1 *) - assert (~In k m3). - { contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } - transitivity (f k e (fold f m i)). - apply fold_Add with (eqA:=eqA); auto. - symmetry. - transitivity (f k e (fold f m3 (fold f m2 i))). - apply fold_Add with (eqA:=eqA); auto. - apply Comp; auto with map. - symmetry; apply IH; auto. - + (* snd case: m3 is (k,e)::m2 *) - assert (~In k m3). - { contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } - assert (~In k m1). - { contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } - transitivity (f k e (fold f m i)). - apply fold_Add with (eqA:=eqA); auto. - transitivity (f k e (fold f m1 (fold f m3 i))). - apply Comp; auto using IH with map. - transitivity (fold f m1 (f k e (fold f m3 i))). - symmetry. - apply fold_commutes with (eqA:=eqA); auto. - apply fold_init with (eqA:=eqA); auto. - symmetry. - apply fold_Add with (eqA:=eqA); auto. - Qed. - - Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 -> - cardinal m = cardinal m1 + cardinal m2. - Proof. - intros. - rewrite (cardinal_fold m), (cardinal_fold m1). - set (f:=fun (_:key)(_:elt)=>S). - setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). - rewrite <- cardinal_fold. - apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. - apply Partition_fold with (eqA:=eq); compute; auto with map. congruence. - Qed. - - Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> - let f := fun k (_:elt) => mem k m1 in - Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). - Proof. - intros m m1 m2 Hm f. - assert (Hf : Proper (E.eq==>eq==>eq) f). - intros k k' Hk e e' _; unfold f; rewrite Hk; auto. - set (m1':= fst (partition f m)). - set (m2':= snd (partition f m)). - split; rewrite Equal_mapsto_iff; intros k e. - rewrite (@partition_iff_1 f Hf m m1') by auto. - unfold f. - rewrite <- mem_in_iff. - destruct Hm as (Hm,Hm'). - rewrite Hm'. - intuition. - exists e; auto. - elim (Hm k); split; auto; exists e; auto. - rewrite (@partition_iff_2 f Hf m m2') by auto. - unfold f. - rewrite <- not_mem_in_iff. - destruct Hm as (Hm,Hm'). - rewrite Hm'. - intuition. - elim (Hm k); split; auto; exists e; auto. - elim H1; exists e; auto. - Qed. - - Lemma update_mapsto_iff : forall m m' k e, - MapsTo k e (update m m') <-> - (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')). - Proof. - unfold update. - intros m m'. - pattern m', (fold (@add _) m' m). apply fold_rec. - - - intros m0 Hm0 k e. - assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto). - intuition. - elim (Hm0 k e); auto. - - - intros k e m0 m1 m2 _ Hn Hadd IH k' e'. - change (Equal m2 (add k e m1)) in Hadd. - rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition. - Qed. - - Lemma update_dec : forall m m' k e, MapsTo k e (update m m') -> - { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}. - Proof. - intros m m' k e H. rewrite update_mapsto_iff in H. - destruct (In_dec m' k) as [H'|H']; [left|right]; intuition. - elim H'; exists e; auto. - Defined. - - Lemma update_in_iff : forall m m' k, - In k (update m m') <-> In k m \/ In k m'. - Proof. - intros m m' k. split. - intros (e,H); rewrite update_mapsto_iff in H. - destruct H; [right|left]; exists e; intuition. - destruct (In_dec m' k) as [H|H]. - destruct H as (e,H). intros _; exists e. - rewrite update_mapsto_iff; left; auto. - destruct 1 as [H'|H']; [|elim H; auto]. - destruct H' as (e,H'). exists e. - rewrite update_mapsto_iff; right; auto. - Qed. - - Lemma diff_mapsto_iff : forall m m' k e, - MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'. - Proof. - intros m m' k e. - unfold diff. - rewrite filter_iff. - intuition. - rewrite mem_1 in *; auto; discriminate. - intros ? ? Hk _ _ _; rewrite Hk; auto. - Qed. - - Lemma diff_in_iff : forall m m' k, - In k (diff m m') <-> In k m /\ ~In k m'. - Proof. - intros m m' k. split. - intros (e,H); rewrite diff_mapsto_iff in H. - destruct H; split; auto. exists e; auto. - intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto. - Qed. - - Lemma restrict_mapsto_iff : forall m m' k e, - MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'. - Proof. - intros m m' k e. - unfold restrict. - rewrite filter_iff. - intuition. - intros ? ? Hk _ _ _; rewrite Hk; auto. - Qed. - - Lemma restrict_in_iff : forall m m' k, - In k (restrict m m') <-> In k m /\ In k m'. - Proof. - intros m m' k. split. - intros (e,H); rewrite restrict_mapsto_iff in H. - destruct H; split; auto. exists e; auto. - intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto. - Qed. - - (** specialized versions analyzing only keys (resp. bindings) *) - - Definition filter_dom (f : key -> bool) := filter (fun k _ => f k). - Definition filter_range (f : elt -> bool) := filter (fun _ => f). - Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k). - Definition for_all_range (f : elt -> bool) := for_all (fun _ => f). - Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k). - Definition exists_range (f : elt -> bool) := exists_ (fun _ => f). - Definition partition_dom (f : key -> bool) := partition (fun k _ => f k). - Definition partition_range (f : elt -> bool) := partition (fun _ => f). - - End Elt. - - Instance cardinal_m {elt} : Proper (Equal ==> Logic.eq) (@cardinal elt). - Proof. intros m m'. apply Equal_cardinal. Qed. - - Instance Disjoint_m {elt} : Proper (Equal ==> Equal ==> iff) (@Disjoint elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros. - rewrite <- Hm1, <- Hm2; auto. - rewrite Hm1, Hm2; auto. - Qed. - - Instance Partition_m {elt} : - Proper (Equal ==> Equal ==> Equal ==> iff) (@Partition elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition. - rewrite <- Hm2, <- Hm3. - split; intros (H,H'); split; auto; intros. - rewrite <- Hm1, <- Hm2, <- Hm3; auto. - rewrite Hm1, Hm2, Hm3; auto. - Qed. - -(* - Instance filter_m0 {elt} (f:key->elt->bool) : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - Proper (Equal==>Equal) (filter f). - Proof. - intros Hf m m' Hm. apply Equal_mapsto_iff. intros. - now rewrite !filter_iff, Hm. - Qed. -*) - - Instance filter_m {elt} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@filter elt). - Proof. - intros f f' Hf m m' Hm. unfold filter. - rewrite 2 fold_spec_right. - set (l := rev (bindings m)). - set (l' := rev (bindings m')). - set (op := fun (f:key->elt->bool) => - uncurry (fun k e acc => if f k e then add k e acc else acc)). - change (Equal (fold_right (op f) empty l) (fold_right (op f') empty l')). - assert (Hl : NoDupA eq_key l). - { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. } - assert (Hl' : NoDupA eq_key l'). - { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. } - assert (H : PermutationA eq_key_elt l l'). - { apply NoDupA_equivlistA_PermutationA. - - apply eqke_equiv. - - now apply NoDupA_eqk_eqke. - - now apply NoDupA_eqk_eqke. - - intros (k,e); unfold l, l'. rewrite 2 InA_rev, 2 bindings_spec1. - rewrite Equal_mapsto_iff in Hm. apply Hm. } - destruct (PermutationA_decompose (eqke_equiv _) H) as (l0,(P,E)). - transitivity (fold_right (op f) empty l0). - - apply fold_right_equivlistA_restr2 - with (eqA:=Logic.eq)(R:=complement eq_key); auto with *. - + intros p p' <- acc acc' Hacc. - destruct p as (k,e); unfold op, uncurry; simpl. - destruct (f k e); now rewrite Hacc. - + intros (k,e) (k',e') z z'. - unfold op, complement, uncurry, eq_key; simpl. - intros Hk Hz. - destruct (f k e), (f k' e'); rewrite <- Hz; try reflexivity. - now apply add_add_2. - + apply NoDupA_incl with eq_key; trivial. intros; subst; now red. - + apply PermutationA_preserves_NoDupA with l; auto with *. - apply Permutation_PermutationA; auto with *. - apply NoDupA_incl with eq_key; trivial. intros; subst; now red. - + apply NoDupA_altdef. apply NoDupA_rev. apply eqk_equiv. - apply bindings_spec2w. - + apply PermutationA_equivlistA; auto with *. - apply Permutation_PermutationA; auto with *. - - clearbody l'. clear l Hl Hl' H P m m' Hm. - induction E. - + reflexivity. - + simpl. destruct x as (k,e), x' as (k',e'). - unfold op, uncurry at 1 3; simpl. - destruct H; simpl in *. rewrite <- (Hf _ _ H _ _ H0). - destruct (f k e); trivial. now f_equiv. - Qed. - - Instance for_all_m {elt} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@for_all elt). - Proof. - intros f f' Hf m m' Hm. rewrite 2 for_all_filter. - (* Strange: we cannot rewrite Hm here... *) - f_equiv. f_equiv; trivial. - intros k k' Hk e e' He. f_equal. now apply Hf. - Qed. - - Instance exists_m {elt} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@exists_ elt). - Proof. - intros f f' Hf m m' Hm. rewrite 2 exists_filter. - f_equal. now apply is_empty_m, filter_m. - Qed. - - Fact diamond_add {elt} : Diamond Equal (@add elt). - Proof. - intros k k' e e' a b b' Hk <- <-. now apply add_add_2. - Qed. - - Instance update_m {elt} : Proper (Equal ==> Equal ==> Equal) (@update elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. - unfold update. - apply fold_Proper; auto using diamond_add with *. - Qed. - - Instance restrict_m {elt} : Proper (Equal==>Equal==>Equal) (@restrict elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2 y. - unfold restrict. - apply eq_option_alt. intros e. - rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity. - clear. intros x x' Hx e e' He. now rewrite Hx. - clear. intros x x' Hx e e' He. now rewrite Hx. - Qed. - - Instance diff_m {elt} : Proper (Equal==>Equal==>Equal) (@diff elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2 y. - unfold diff. - apply eq_option_alt. intros e. - rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity. - clear. intros x x' Hx e e' He. now rewrite Hx. - clear. intros x x' Hx e e' He. now rewrite Hx. - Qed. - -End WProperties_fun. - -(** * Same Properties for self-contained weak maps and for full maps *) - -Module WProperties (M:WS) := WProperties_fun M.E M. -Module Properties := WProperties. - -(** * Properties specific to maps with ordered keys *) - -Module OrdProperties (M:S). - Module Import ME := OrderedTypeFacts M.E. - Module Import O:=KeyOrderedType M.E. - Module Import P:=Properties M. - Import M. - - Section Elt. - Variable elt:Type. - - Definition Above x (m:t elt) := forall y, In y m -> E.lt y x. - Definition Below x (m:t elt) := forall y, In y m -> E.lt x y. - - Section Bindings. - - Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt), - sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'. - Proof. - apply SortA_equivlistA_eqlistA; eauto with *. - Qed. - - Ltac klean := unfold O.eqke, O.ltk, RelCompFun in *; simpl in *. - Ltac keauto := klean; intuition; eauto. - - Definition gtb (p p':key*elt) := - match E.compare (fst p) (fst p') with Gt => true | _ => false end. - Definition leb p := fun p' => negb (gtb p p'). - - Definition bindings_lt p m := List.filter (gtb p) (bindings m). - Definition bindings_ge p m := List.filter (leb p) (bindings m). - - Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p. - Proof. - intros (x,e) (y,e'); unfold gtb; klean. - case E.compare_spec; intuition; try discriminate; ME.order. - Qed. - - Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p. - Proof. - intros (x,e) (y,e'); unfold leb, gtb; klean. - case E.compare_spec; intuition; try discriminate; ME.order. - Qed. - - Instance gtb_compat : forall p, Proper (eqke==>eq) (gtb p). - Proof. - red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. - generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); - destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); klean; auto. - - intros. symmetry; rewrite H2. rewrite <-H, <-H1; auto. - - intros. rewrite H1. rewrite H, <- H2; auto. - Qed. - - Instance leb_compat : forall p, Proper (eqke==>eq) (leb p). - Proof. - intros x a b H. unfold leb; f_equal; apply gtb_compat; auto. - Qed. - - Hint Resolve gtb_compat leb_compat bindings_spec2 : map. - - Lemma bindings_split : forall p m, - bindings m = bindings_lt p m ++ bindings_ge p m. - Proof. - unfold bindings_lt, bindings_ge, leb; intros. - apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with *. - intros; destruct x; destruct y; destruct p. - rewrite gtb_1 in H; klean. - apply not_true_iff_false in H0. rewrite gtb_1 in H0. klean. ME.order. - Qed. - - Lemma bindings_Add : forall m m' x e, ~In x m -> Add x e m m' -> - eqlistA eqke (bindings m') - (bindings_lt (x,e) m ++ (x,e):: bindings_ge (x,e) m). - Proof. - intros; unfold bindings_lt, bindings_ge. - apply sort_equivlistA_eqlistA; auto with *. - - apply (@SortA_app _ eqke); auto with *. - + apply (@filter_sort _ eqke); auto with *; keauto. - + constructor; auto with map. - * apply (@filter_sort _ eqke); auto with *; keauto. - * rewrite (@InfA_alt _ eqke); auto with *; try (keauto; fail). - { intros. - rewrite filter_InA in H1; auto with *; destruct H1. - rewrite leb_1 in H2. - destruct y; klean. - rewrite <- bindings_mapsto_iff in H1. - assert (~E.eq x t0). - { contradict H. - exists e0; apply MapsTo_1 with t0; auto. - ME.order. } - ME.order. } - { apply (@filter_sort _ eqke); auto with *; keauto. } - + intros. - rewrite filter_InA in H1; auto with *; destruct H1. - rewrite gtb_1 in H3. - destruct y; destruct x0; klean. - inversion_clear H2. - * red in H4; klean; destruct H4; simpl in *. ME.order. - * rewrite filter_InA in H4; auto with *; destruct H4. - rewrite leb_1 in H4. klean; ME.order. - - intros (k,e'). - rewrite InA_app_iff, InA_cons, 2 filter_InA, - <-2 bindings_mapsto_iff, leb_1, gtb_1, - find_mapsto_iff, (H0 k), <- find_mapsto_iff, - add_mapsto_iff by (auto with * ). - change (eqke (k,e') (x,e)) with (E.eq k x /\ e' = e). - klean. - split. - + intros [(->,->)|(Hk,Hm)]. - * right; now left. - * destruct (lt_dec k x); intuition. - + intros [(Hm,LT)|[(->,->)|(Hm,EQ)]]. - * right; split; trivial; ME.order. - * now left. - * destruct (eq_dec x k) as [Hk|Hk]. - elim H. exists e'. now rewrite Hk. - right; auto. - Qed. - - Lemma bindings_Add_Above : forall m m' x e, - Above x m -> Add x e m m' -> - eqlistA eqke (bindings m') (bindings m ++ (x,e)::nil). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with *. - apply (@SortA_app _ eqke); auto with *. - intros. - inversion_clear H2. - destruct x0; destruct y. - rewrite <- bindings_mapsto_iff in H1. - destruct H3; klean. - rewrite H2. - apply H; firstorder. - inversion H3. - red; intros a; destruct a. - rewrite InA_app_iff, InA_cons, InA_nil, <- 2 bindings_mapsto_iff, - find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff by (auto with *). - change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e). - intuition. - destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. - exfalso. - assert (In t0 m) by (exists e0; auto). - generalize (H t0 H1). - ME.order. - Qed. - - Lemma bindings_Add_Below : forall m m' x e, - Below x m -> Add x e m m' -> - eqlistA eqke (bindings m') ((x,e)::bindings m). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with *. - change (sort ltk (((x,e)::nil) ++ bindings m)). - apply (@SortA_app _ eqke); auto with *. - intros. - inversion_clear H1. - destruct y; destruct x0. - rewrite <- bindings_mapsto_iff in H2. - destruct H3; klean. - rewrite H1. - apply H; firstorder. - inversion H3. - red; intros a; destruct a. - rewrite InA_cons, <- 2 bindings_mapsto_iff, - find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff by (auto with * ). - change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e). - intuition. - destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. - exfalso. - assert (In t0 m) by (exists e0; auto). - generalize (H t0 H1). - ME.order. - Qed. - - Lemma bindings_Equal_eqlistA : forall (m m': t elt), - Equal m m' -> eqlistA eqke (bindings m) (bindings m'). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with *. - red; intros. - destruct x; do 2 rewrite <- bindings_mapsto_iff. - do 2 rewrite find_mapsto_iff; rewrite H; split; auto. - Qed. - - End Bindings. - - Section Min_Max_Elt. - - (** We emulate two [max_elt] and [min_elt] functions. *) - - Fixpoint max_elt_aux (l:list (key*elt)) := match l with - | nil => None - | (x,e)::nil => Some (x,e) - | (x,e)::l => max_elt_aux l - end. - Definition max_elt m := max_elt_aux (bindings m). - - Lemma max_elt_Above : - forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). - Proof. - red; intros. - rewrite remove_in_iff in H0. - destruct H0. - rewrite bindings_in_iff in H1. - destruct H1. - unfold max_elt in *. - generalize (bindings_spec2 m). - revert x e H y x0 H0 H1. - induction (bindings m). - simpl; intros; try discriminate. - intros. - destruct a; destruct l; simpl in *. - injection H; clear H; intros; subst. - inversion_clear H1. - red in H; simpl in *; intuition. - now elim H0. - inversion H. - change (max_elt_aux (p::l) = Some (x,e)) in H. - generalize (IHl x e H); clear IHl; intros IHl. - inversion_clear H1; [ | inversion_clear H2; eauto ]. - red in H3; simpl in H3; destruct H3. - destruct p as (p1,p2). - destruct (E.eq_dec p1 x) as [Heq|Hneq]. - rewrite <- Heq; auto. - inversion_clear H2. - inversion_clear H5. - red in H2; simpl in H2; ME.order. - transitivity p1; auto. - inversion_clear H2. - inversion_clear H5. - red in H2; simpl in H2; ME.order. - eapply IHl; eauto with *. - econstructor; eauto. - red; eauto with *. - inversion H2; auto. - Qed. - - Lemma max_elt_MapsTo : - forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. - Proof. - intros. - unfold max_elt in *. - rewrite bindings_mapsto_iff. - induction (bindings m). - simpl; try discriminate. - destruct a; destruct l; simpl in *. - injection H; intros; subst; constructor; red; auto with *. - constructor 2; auto. - Qed. - - Lemma max_elt_Empty : - forall m, max_elt m = None -> Empty m. - Proof. - intros. - unfold max_elt in *. - rewrite bindings_Empty. - induction (bindings m); auto. - destruct a; destruct l; simpl in *; try discriminate. - assert (H':=IHl H); discriminate. - Qed. - - Definition min_elt m : option (key*elt) := match bindings m with - | nil => None - | (x,e)::_ => Some (x,e) - end. - - Lemma min_elt_Below : - forall m x e, min_elt m = Some (x,e) -> Below x (remove x m). - Proof. - unfold min_elt, Below; intros. - rewrite remove_in_iff in H0; destruct H0. - rewrite bindings_in_iff in H1. - destruct H1. - generalize (bindings_spec2 m). - destruct (bindings m). - try discriminate. - destruct p; injection H; intros; subst. - inversion_clear H1. - red in H2; destruct H2; simpl in *; ME.order. - inversion_clear H4. - rewrite (@InfA_alt _ eqke) in H3; eauto with *. - apply (H3 (y,x0)); auto. - Qed. - - Lemma min_elt_MapsTo : - forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. - Proof. - intros. - unfold min_elt in *. - rewrite bindings_mapsto_iff. - destruct (bindings m). - simpl; try discriminate. - destruct p; simpl in *. - injection H; intros; subst; constructor; red; auto with *. - Qed. - - Lemma min_elt_Empty : - forall m, min_elt m = None -> Empty m. - Proof. - intros. - unfold min_elt in *. - rewrite bindings_Empty. - destruct (bindings m); auto. - destruct p; simpl in *; discriminate. - Qed. - - End Min_Max_Elt. - - Section Induction_Principles. - - Lemma map_induction_max : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - apply X; apply cardinal_inv_1; auto. - - case_eq (max_elt m); intros. - destruct p. - assert (Add k e (remove k m) m). - { apply max_elt_MapsTo, find_spec, add_id in H. - unfold Add. symmetry. now rewrite add_remove_1. } - apply X0 with (remove k m) k e; auto with map. - apply IHn. - assert (S n = S (cardinal (remove k m))). - { rewrite Heqn. - eapply cardinal_S; eauto with map. } - inversion H1; auto. - eapply max_elt_Above; eauto. - - apply X; apply max_elt_Empty; auto. - Qed. - - Lemma map_induction_min : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - apply X; apply cardinal_inv_1; auto. - - case_eq (min_elt m); intros. - destruct p. - assert (Add k e (remove k m) m). - { apply min_elt_MapsTo, find_spec, add_id in H. - unfold Add. symmetry. now rewrite add_remove_1. } - apply X0 with (remove k m) k e; auto. - apply IHn. - assert (S n = S (cardinal (remove k m))). - { rewrite Heqn. - eapply cardinal_S; eauto with map. } - inversion H1; auto. - eapply min_elt_Below; eauto. - - apply X; apply min_elt_Empty; auto. - Qed. - - End Induction_Principles. - - Section Fold_properties. - - (** The following lemma has already been proved on Weak Maps, - but with one additionnal hypothesis (some [transpose] fact). *) - - Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A), - Proper (E.eq==>eq==>eqA==>eqA) f -> - Equal m1 m2 -> - eqA (fold f m1 i) (fold f m2 i). - Proof. - intros m1 m2 A eqA st f i Hf Heq. - rewrite 2 fold_spec_right. - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto. - apply eqlistA_rev. apply bindings_Equal_eqlistA. auto. - Qed. - - Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), - Above x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (f x e (fold f m1 i)). - Proof. - intros. rewrite 2 fold_spec_right. set (f':=uncurry f). - transitivity (fold_right f' i (rev (bindings m1 ++ (x,e)::nil))). - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto. - apply eqlistA_rev. - apply bindings_Add_Above; auto. - rewrite distr_rev; simpl. - reflexivity. - Qed. - - Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), - Below x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (fold f m1 (f x e i)). - Proof. - intros. rewrite 2 fold_spec_right. set (f':=uncurry f). - transitivity (fold_right f' i (rev (((x,e)::nil)++bindings m1))). - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto. - apply eqlistA_rev. - simpl; apply bindings_Add_Below; auto. - rewrite distr_rev; simpl. - rewrite fold_right_app. - reflexivity. - Qed. - - End Fold_properties. - - End Elt. - -End OrdProperties. diff --git a/theories/MMaps/MMapInterface.v b/theories/MMaps/MMapInterface.v deleted file mode 100644 index 05c5e5d8..00000000 --- a/theories/MMaps/MMapInterface.v +++ /dev/null @@ -1,292 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* elt->bool) e1 e2 := cmp e1 e2 = true. - -(** ** Weak signature for maps - - No requirements for an ordering on keys nor elements, only decidability - of equality on keys. First, a functorial signature: *) - -Module Type WSfun (E : DecidableType). - - Definition key := E.t. - Hint Transparent key. - - Definition eq_key {elt} (p p':key*elt) := E.eq (fst p) (fst p'). - - Definition eq_key_elt {elt} (p p':key*elt) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - - Parameter t : Type -> Type. - (** the abstract type of maps *) - - Section Ops. - - Parameter empty : forall {elt}, t elt. - (** The empty map. *) - - Variable elt:Type. - - Parameter is_empty : t elt -> bool. - (** Test whether a map is empty or not. *) - - Parameter add : key -> elt -> t elt -> t elt. - (** [add x y m] returns a map containing the same bindings as [m], - plus a binding of [x] to [y]. If [x] was already bound in [m], - its previous binding disappears. *) - - Parameter find : key -> t elt -> option elt. - (** [find x m] returns the current binding of [x] in [m], - or [None] if no such binding exists. *) - - Parameter remove : key -> t elt -> t elt. - (** [remove x m] returns a map containing the same bindings as [m], - except for [x] which is unbound in the returned map. *) - - Parameter mem : key -> t elt -> bool. - (** [mem x m] returns [true] if [m] contains a binding for [x], - and [false] otherwise. *) - - Parameter bindings : t elt -> list (key*elt). - (** [bindings m] returns an assoc list corresponding to the bindings - of [m], in any order. *) - - Parameter cardinal : t elt -> nat. - (** [cardinal m] returns the number of bindings in [m]. *) - - Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A. - (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1] ... [kN] are the keys of all bindings in [m] - (in any order), and [d1] ... [dN] are the associated data. *) - - Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. - (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, - that is, contain equal keys and associate them with equal data. - [cmp] is the equality predicate used to compare the data associated - with the keys. *) - - Variable elt' elt'' : Type. - - Parameter map : (elt -> elt') -> t elt -> t elt'. - (** [map f m] returns a map with same domain as [m], where the associated - value a of all bindings of [m] has been replaced by the result of the - application of [f] to [a]. Since Coq is purely functional, the order - in which the bindings are passed to [f] is irrelevant. *) - - Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. - (** Same as [map], but the function receives as arguments both the - key and the associated value for each binding of the map. *) - - Parameter merge : (key -> option elt -> option elt' -> option elt'') -> - t elt -> t elt' -> t elt''. - (** [merge f m m'] creates a new map whose bindings belong to the ones - of either [m] or [m']. The presence and value for a key [k] is - determined by [f k e e'] where [e] and [e'] are the (optional) - bindings of [k] in [m] and [m']. *) - - End Ops. - Section Specs. - - Variable elt:Type. - - Parameter MapsTo : key -> elt -> t elt -> Prop. - - Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. - - Global Declare Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - - Variable m m' : t elt. - Variable x y : key. - Variable e : elt. - - Parameter find_spec : find x m = Some e <-> MapsTo x e m. - Parameter mem_spec : mem x m = true <-> In x m. - Parameter empty_spec : find x (@empty elt) = None. - Parameter is_empty_spec : is_empty m = true <-> forall x, find x m = None. - Parameter add_spec1 : find x (add x e m) = Some e. - Parameter add_spec2 : ~E.eq x y -> find y (add x e m) = find y m. - Parameter remove_spec1 : find x (remove x m) = None. - Parameter remove_spec2 : ~E.eq x y -> find y (remove x m) = find y m. - - (** Specification of [bindings] *) - Parameter bindings_spec1 : - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - (** When compared with ordered maps, here comes the only - property that is really weaker: *) - Parameter bindings_spec2w : NoDupA eq_key (bindings m). - - (** Specification of [cardinal] *) - Parameter cardinal_spec : cardinal m = length (bindings m). - - (** Specification of [fold] *) - Parameter fold_spec : - forall {A} (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - - (** Equality of maps *) - - (** Caveat: there are at least three distinct equality predicates on maps. - - The simpliest (and maybe most natural) way is to consider keys up to - their equivalence [E.eq], but elements up to Leibniz equality, in - the spirit of [eq_key_elt] above. This leads to predicate [Equal]. - - Unfortunately, this [Equal] predicate can't be used to describe - the [equal] function, since this function (for compatibility with - ocaml) expects a boolean comparison [cmp] that may identify more - elements than Leibniz. So logical specification of [equal] is done - via another predicate [Equivb] - - This predicate [Equivb] is quite ad-hoc with its boolean [cmp], - it can be generalized in a [Equiv] expecting a more general - (possibly non-decidable) equality predicate on elements *) - - Definition Equal (m m':t elt) := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). - - (** Specification of [equal] *) - Parameter equal_spec : forall cmp : elt -> elt -> bool, - equal cmp m m' = true <-> Equivb cmp m m'. - - End Specs. - Section SpecMaps. - - Variables elt elt' elt'' : Type. - - Parameter map_spec : forall (f:elt->elt') m x, - find x (map f m) = option_map f (find x m). - - Parameter mapi_spec : forall (f:key->elt->elt') m x, - exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - - Parameter merge_spec1 : - forall (f:key->option elt->option elt'->option elt'') m m' x, - In x m \/ In x m' -> - exists y:key, E.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). - - Parameter merge_spec2 : - forall (f:key -> option elt->option elt'->option elt'') m m' x, - In x (merge f m m') -> In x m \/ In x m'. - - End SpecMaps. -End WSfun. - -(** ** Static signature for Weak Maps - - Similar to [WSfun] but expressed in a self-contained way. *) - -Module Type WS. - Declare Module E : DecidableType. - Include WSfun E. -End WS. - - - -(** ** Maps on ordered keys, functorial signature *) - -Module Type Sfun (E : OrderedType). - Include WSfun E. - - Definition lt_key {elt} (p p':key*elt) := E.lt (fst p) (fst p'). - - (** Additional specification of [bindings] *) - - Parameter bindings_spec2 : forall {elt}(m : t elt), sort lt_key (bindings m). - - (** Remark: since [fold] is specified via [bindings], this stronger - specification of [bindings] has an indirect impact on [fold], - which can now be proved to receive bindings in increasing order. *) - -End Sfun. - - -(** ** Maps on ordered keys, self-contained signature *) - -Module Type S. - Declare Module E : OrderedType. - Include Sfun E. -End S. - - - -(** ** Maps with ordering both on keys and datas *) - -Module Type Sord. - - Declare Module Data : OrderedType. - Declare Module MapS : S. - Import MapS. - - Definition t := MapS.t Data.t. - - Include HasEq <+ HasLt <+ IsEq <+ IsStrOrder. - - Definition cmp e e' := - match Data.compare e e' with Eq => true | _ => false end. - - Parameter eq_spec : forall m m', eq m m' <-> Equivb cmp m m'. - - Parameter compare : t -> t -> comparison. - - Parameter compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2). - -End Sord. - - -(* TODO: provides filter + partition *) - -(* TODO: provide split - Parameter split : key -> t elt -> t elt * option elt * t elt. - - Parameter split_spec k m : - split k m = (filter (fun x -> E.compare x k) m, find k m, filter ...) - - min_binding, max_binding, choose ? -*) diff --git a/theories/MMaps/MMapList.v b/theories/MMaps/MMapList.v deleted file mode 100644 index c521178c..00000000 --- a/theories/MMaps/MMapList.v +++ /dev/null @@ -1,1144 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - assert (X.lt k' k); - [let e := fresh "e" in destruct H3 as (e,H3); - change (ltk (k',e') (k,e)); - apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] - | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:MapsTo ?k ?e ?m |- _ => - assert (X.lt k' k); - [change (ltk (k',e') (k,e)); - apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] - | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:InA eqke (?k,?e) ?m |- _ => - assert (X.lt k' k); - [change (ltk (k',e') (k,e)); - apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] - end. - -(** * [find] *) - -Fixpoint find (k:key) (m: t elt) : option elt := - match m with - | nil => None - | (k',x)::m' => - match X.compare k k' with - | Lt => None - | Eq => Some x - | Gt => find k m' - end - end. - -Lemma find_spec m (Hm:Sort m) x e : - find x m = Some e <-> MapsTo x e m. -Proof. - induction m as [|(k,e') m IH]; simpl. - - split. discriminate. inversion 1. - - inversion_clear Hm. - unfold MapsTo in *. rewrite InA_cons, eqke_def. - case X.compare_spec; intros. - + split. injection 1 as ->; auto. - intros [(_,<-)|IN]; trivial. SortLt. MX.order. - + split. discriminate. - intros [(E,<-)|IN]; trivial; try SortLt; MX.order. - + rewrite IH; trivial. split; auto. - intros [(E,<-)|IN]; trivial. MX.order. -Qed. - -(** * [mem] *) - -Fixpoint mem (k : key) (m : t elt) : bool := - match m with - | nil => false - | (k',_) :: l => - match X.compare k k' with - | Lt => false - | Eq => true - | Gt => mem k l - end - end. - -Lemma mem_spec m (Hm:Sort m) x : mem x m = true <-> In x m. -Proof. - induction m as [|(k,e') m IH]; simpl. - - split. discriminate. inversion 1. inversion_clear H0. - - inversion_clear Hm. - rewrite In_cons; simpl. - case X.compare_spec; intros. - + intuition. - + split. discriminate. intros [E|(e,IN)]. MX.order. - SortLt. MX.order. - + rewrite IH; trivial. split; auto. intros [E|IN]; trivial. - MX.order. -Qed. - -(** * [empty] *) - -Definition empty : t elt := nil. - -Lemma empty_spec x : find x empty = None. -Proof. - reflexivity. -Qed. - -Lemma empty_sorted : Sort empty. -Proof. - unfold empty; auto. -Qed. - -(** * [is_empty] *) - -Definition is_empty (l : t elt) : bool := if l then true else false. - -Lemma is_empty_spec m : - is_empty m = true <-> forall x, find x m = None. -Proof. - destruct m as [|(k,e) m]; simpl; split; trivial; try discriminate. - intros H. specialize (H k). now rewrite compare_refl in H. -Qed. - -(** * [add] *) - -Fixpoint add (k : key) (x : elt) (s : t elt) : t elt := - match s with - | nil => (k,x) :: nil - | (k',y) :: l => - match X.compare k k' with - | Lt => (k,x)::s - | Eq => (k,x)::l - | Gt => (k',y) :: add k x l - end - end. - -Lemma add_spec1 m x e : find x (add x e m) = Some e. -Proof. - induction m as [|(k,e') m IH]; simpl. - - now rewrite compare_refl. - - case X.compare_spec; simpl; rewrite ?compare_refl; trivial. - rewrite <- compare_gt_iff. now intros ->. -Qed. - -Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m. -Proof. - induction m as [|(k,e') m IH]; simpl. - - case X.compare_spec; trivial; MX.order. - - case X.compare_spec; simpl; intros; trivial. - + rewrite <-H. case X.compare_spec; trivial; MX.order. - + do 2 (case X.compare_spec; trivial; try MX.order). - + now rewrite IH. -Qed. - -Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), - Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x'',e''). - inversion_clear H. - compute in H0,H1. - simpl; case X.compare; intuition. -Qed. -Hint Resolve add_Inf. - -Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x',e'). - simpl; case (X.compare_spec x x'); intuition; inversion_clear Hm; auto. - constructor; auto. - apply Inf_eq with (x',e'); auto. -Qed. - -(** * [remove] *) - -Fixpoint remove (k : key) (s : t elt) : t elt := - match s with - | nil => nil - | (k',x) :: l => - match X.compare k k' with - | Lt => s - | Eq => l - | Gt => (k',x) :: remove k l - end - end. - -Lemma remove_spec1 m (Hm:Sort m) x : find x (remove x m) = None. -Proof. - induction m as [|(k,e') m IH]; simpl; trivial. - inversion_clear Hm. - case X.compare_spec; simpl. - - intros E. rewrite <- E in H0. - apply Sort_Inf_NotIn in H0; trivial. unfold In in H0. - setoid_rewrite <- find_spec in H0; trivial. - destruct (find x m); trivial. - elim H0; now exists e. - - rewrite <- compare_lt_iff. now intros ->. - - rewrite <- compare_gt_iff. intros ->; auto. -Qed. - -Lemma remove_spec2 m (Hm:Sort m) x y : - ~X.eq x y -> find y (remove x m) = find y m. -Proof. - induction m as [|(k,e') m IH]; simpl; trivial. - inversion_clear Hm. - case X.compare_spec; simpl; intros E E'; try rewrite IH; auto. - case X.compare_spec; simpl; trivial; try MX.order. - intros. rewrite <- E in H0,H1. clear E E'. - destruct (find y m) eqn:F; trivial. - apply find_spec in F; trivial. - SortLt. MX.order. -Qed. - -Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), - Inf (x',e') m -> Inf (x',e') (remove x m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x'',e''). - inversion_clear H. - compute in H0. - simpl; case X.compare; intuition. - inversion_clear Hm. - apply Inf_lt with (x'',e''); auto. -Qed. -Hint Resolve remove_Inf. - -Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x',e'). - simpl; case X.compare_spec; intuition; inversion_clear Hm; auto. -Qed. - -(** * [bindings] *) - -Definition bindings (m: t elt) := m. - -Lemma bindings_spec1 m x e : - InA eqke (x,e) (bindings m) <-> MapsTo x e m. -Proof. - reflexivity. -Qed. - -Lemma bindings_spec2 m (Hm:Sort m) : sort ltk (bindings m). -Proof. - auto. -Qed. - -Lemma bindings_spec2w m (Hm:Sort m) : NoDupA eqk (bindings m). -Proof. - now apply Sort_NoDupA. -Qed. - -(** * [fold] *) - -Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) : A := - match m with - | nil => acc - | (k,e)::m' => fold f m' (f k e acc) - end. - -Lemma fold_spec m : forall (A:Type)(i:A)(f:key->elt->A->A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. -Proof. - induction m as [|(k,e) m IH]; simpl; auto. -Qed. - -(** * [equal] *) - -Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) : bool := - match m, m' with - | nil, nil => true - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | Eq => cmp e e' && equal cmp l l' - | _ => false - end - | _, _ => false - end. - -Definition Equivb (cmp:elt->elt->bool) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. - induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl. - - trivial. - - intros _ cmp (H,_). - exfalso. apply (@In_nil elt k'). rewrite H, In_cons. now left. - - intros _ cmp (H,_). - exfalso. apply (@In_nil elt k). rewrite <- H, In_cons. now left. - - intros Hm' cmp E. - inversion_clear Hm; inversion_clear Hm'. - case X.compare_spec; intros E'. - + apply andb_true_intro; split. - * eapply E; eauto. apply InA_cons; now left. - * apply IH; clear IH; trivial. - destruct E as (E1,E2). split. - { intros x. clear E2. - split; intros; SortLt. - specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1. - destruct E1 as ([E1|E1],_); eauto. MX.order. - specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1. - destruct E1 as (_,[E1|E1]); eauto. MX.order. } - { intros x xe xe' Hx HX'. eapply E2; eauto. } - + assert (IN : In k ((k',e')::m')). - { apply E. apply In_cons; now left. } - apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order. - SortLt. MX.order. - + assert (IN : In k' ((k,e)::m)). - { apply E. apply In_cons; now left. } - apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order. - SortLt. MX.order. -Qed. - -Lemma equal_2 m (Hm:Sort m) m' (Hm':Sort m') cmp : - equal cmp m m' = true -> Equivb cmp m m'. -Proof. - revert m' Hm'. - induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl; - try discriminate. - - split. reflexivity. inversion 1. - - intros Hm'. case X.compare_spec; try discriminate. - rewrite andb_true_iff. intros E (C,EQ). - inversion_clear Hm; inversion_clear Hm'. - apply IH in EQ; trivial. - destruct EQ as (E1,E2). - split. - + intros x. rewrite 2 In_cons; simpl. rewrite <- E1. - intuition; now left; MX.order. - + intros x ex ex'. unfold MapsTo in *. rewrite 2 InA_cons, 2 eqke_def. - intuition; subst. - * trivial. - * SortLt. MX.order. - * SortLt. MX.order. - * eapply E2; eauto. -Qed. - -Lemma equal_spec m (Hm:Sort m) m' (Hm':Sort m') cmp : - equal cmp m m' = true <-> Equivb cmp m m'. -Proof. - split. now apply equal_2. now apply equal_1. -Qed. - -(** This lemma isn't part of the spec of [Equivb], but is used in [MMapAVL] *) - -Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> - eqk x y -> cmp (snd x) (snd y) = true -> - (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). -Proof. - intros. - inversion H; subst. - inversion H0; subst. - destruct x; destruct y; compute in H1, H2. - split; intros. - apply equal_2; auto. - simpl. - case X.compare_spec; intros; try MX.order. - rewrite H2; simpl. - apply equal_1; auto. - apply equal_2; auto. - generalize (equal_1 H H0 H3). - simpl. - case X.compare_spec; try discriminate. - rewrite andb_true_iff. intuition. -Qed. - -Variable elt':Type. - -(** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f e) :: map f m' - end. - -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f k e) :: mapi f m' - end. - -End Elt. -Arguments find {elt} k m. -Section Elt2. -Variable elt elt' : Type. - -(** Specification of [map] *) - -Lemma map_spec (f:elt->elt') m x : - find x (map f m) = option_map f (find x m). -Proof. - induction m as [|(k,e) m IH]; simpl; trivial. - now case X.compare_spec. -Qed. - -Lemma map_Inf (f:elt->elt') m x e e' : - Inf (x,e) m -> Inf (x,e') (map f m). -Proof. - induction m as [|(x0,e0) m IH]; simpl; auto. - inversion_clear 1; auto. -Qed. -Hint Resolve map_Inf. - -Lemma map_sorted (f:elt->elt')(m: t elt)(Hm : Sort m) : - Sort (map f m). -Proof. - induction m as [|(x,e) m IH]; simpl; auto. - inversion_clear Hm. constructor; eauto. -Qed. - -(** Specification of [mapi] *) - -Lemma mapi_spec (f:key->elt->elt') m x : - exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). -Proof. - induction m as [|(k,e) m IH]; simpl. - - now exists x. - - elim X.compare_spec; intros; simpl. - + now exists k. - + now exists x. - + apply IH. -Qed. - -Lemma mapi_Inf (f:key->elt->elt') m x e : - Inf (x,e) m -> Inf (x,f x e) (mapi f m). -Proof. - induction m as [|(x0,e0) m IH]; simpl; auto. - inversion_clear 1; auto. -Qed. -Hint Resolve mapi_Inf. - -Lemma mapi_sorted (f:key->elt->elt') m (Hm : Sort m) : - Sort (mapi f m). -Proof. - induction m as [|(x,e) m IH]; simpl; auto. - inversion_clear Hm; auto. -Qed. - -End Elt2. -Section Elt3. - -(** * [merge] *) - -Variable elt elt' elt'' : Type. -Variable f : key -> option elt -> option elt' -> option elt''. - -Definition option_cons {A}(k:key)(o:option A)(l:list (key*A)) := - match o with - | Some e => (k,e)::l - | None => l - end. - -Fixpoint merge_l (m : t elt) : t elt'' := - match m with - | nil => nil - | (k,e)::l => option_cons k (f k (Some e) None) (merge_l l) - end. - -Fixpoint merge_r (m' : t elt') : t elt'' := - match m' with - | nil => nil - | (k,e')::l' => option_cons k (f k None (Some e')) (merge_r l') - end. - -Fixpoint merge (m : t elt) : t elt' -> t elt'' := - match m with - | nil => merge_r - | (k,e) :: l => - fix merge_aux (m' : t elt') : t elt'' := - match m' with - | nil => merge_l m - | (k',e') :: l' => - match X.compare k k' with - | Lt => option_cons k (f k (Some e) None) (merge l m') - | Eq => option_cons k (f k (Some e) (Some e')) (merge l l') - | Gt => option_cons k' (f k' None (Some e')) (merge_aux l') - end - end - end. - -Notation oee' := (option elt * option elt')%type. - -Fixpoint combine (m : t elt) : t elt' -> t oee' := - match m with - | nil => map (fun e' => (None,Some e')) - | (k,e) :: l => - fix combine_aux (m':t elt') : list (key * oee') := - match m' with - | nil => map (fun e => (Some e,None)) m - | (k',e') :: l' => - match X.compare k k' with - | Lt => (k,(Some e, None))::combine l m' - | Eq => (k,(Some e, Some e'))::combine l l' - | Gt => (k',(None,Some e'))::combine_aux l' - end - end - end. - -Definition fold_right_pair {A B C}(f: A->B->C->C)(l:list (A*B))(i:C) := - List.fold_right (fun p => f (fst p) (snd p)) i l. - -Definition merge' m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := mapi (fun k p => f k (fst p) (snd p)) m0 in - fold_right_pair (option_cons (A:=elt'')) m1 nil. - -Lemma merge_equiv : forall m m', merge' m m' = merge m m'. -Proof. - unfold merge'. - induction m as [|(k,e) m IHm]; intros. - - (* merge_r *) - simpl. - induction m' as [|(k',e') m' IHm']; simpl; rewrite ?IHm'; auto. - - induction m' as [|(k',e') m' IHm']; simpl. - + f_equal. - (* merge_l *) - clear k e IHm. - induction m as [|(k,e) m IHm]; simpl; rewrite ?IHm; auto. - + elim X.compare_spec; intros; simpl; f_equal. - * apply IHm. - * apply IHm. - * apply IHm'. -Qed. - -Lemma combine_Inf : - forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), - Inf (x,e) m -> - Inf (x,e') m' -> - Inf (x,e'') (combine m m'). -Proof. - induction m. - - intros. simpl. eapply map_Inf; eauto. - - induction m'; intros. - + destruct a. - replace (combine ((t0, e0) :: m) nil) with - (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. - eapply map_Inf; eauto. - + simpl. - destruct a as (k,e0); destruct a0 as (k',e0'). - elim X.compare_spec. - * inversion_clear H; auto. - * inversion_clear H; auto. - * inversion_clear H0; auto. -Qed. -Hint Resolve combine_Inf. - -Lemma combine_sorted m (Hm : Sort m) m' (Hm' : Sort m') : - Sort (combine m m'). -Proof. - revert m' Hm'. - induction m. - - intros; clear Hm. simpl. apply map_sorted; auto. - - induction m'; intros. - + clear Hm'. - destruct a. - replace (combine ((t0, e) :: m) nil) with - (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. - apply map_sorted; auto. - + simpl. - destruct a as (k,e); destruct a0 as (k',e'). - inversion_clear Hm; inversion_clear Hm'. - case X.compare_spec; [intros Heq| intros Hlt| intros Hlt]; - constructor; auto. - * assert (Inf (k, e') m') by (apply Inf_eq with (k',e'); auto). - exact (combine_Inf _ H0 H3). - * assert (Inf (k, e') ((k',e')::m')) by auto. - exact (combine_Inf _ H0 H3). - * assert (Inf (k', e) ((k,e)::m)) by auto. - exact (combine_Inf _ H3 H2). -Qed. - -Lemma merge_sorted m (Hm : Sort m) m' (Hm' : Sort m') : - Sort (merge m m'). -Proof. - intros. - rewrite <- merge_equiv. - unfold merge'. - assert (Hmm':=combine_sorted Hm Hm'). - set (l0:=combine m m') in *; clearbody l0. - set (f':= fun k p => f k (fst p) (snd p)). - assert (H1:=mapi_sorted f' Hmm'). - set (l1:=mapi f' l0) in *; clearbody l1. - clear f' f Hmm' l0 Hm Hm' m m'. - (* Sort fold_right_pair *) - induction l1. - - simpl; auto. - - inversion_clear H1. - destruct a; destruct o; auto. - simpl. - constructor; auto. - clear IHl1. - (* Inf fold_right_pair *) - induction l1. - + simpl; auto. - + destruct a; destruct o; simpl; auto. - * inversion_clear H0; auto. - * inversion_clear H0. inversion_clear H. - compute in H1. - apply IHl1; auto. - apply Inf_lt with (t1, None); auto. -Qed. - -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => Some (o,o') - end. - -Lemma combine_spec m (Hm : Sort m) m' (Hm' : Sort m') (x:key) : - find x (combine m m') = at_least_one (find x m) (find x m'). -Proof. - revert m' Hm'. - induction m. - intros. - simpl. - induction m'. - intros; simpl; auto. - simpl; destruct a. - simpl; destruct (X.compare x t0); simpl; auto. - inversion_clear Hm'; auto. - induction m'. - (* m' = nil *) - intros; destruct a; simpl. - destruct (X.compare_spec x t0) as [ |Hlt|Hlt]; simpl; auto. - inversion_clear Hm; clear H0 Hlt Hm' IHm t0. - induction m; simpl; auto. - inversion_clear H. - destruct a. - simpl; destruct (X.compare x t0); simpl; auto. - (* m' <> nil *) - intros. - destruct a as (k,e); destruct a0 as (k',e'); simpl. - inversion Hm; inversion Hm'; subst. - destruct (X.compare_spec k k'); simpl; - destruct (X.compare_spec x k); - MX.order || destruct (X.compare_spec x k'); - simpl; try MX.order; auto. - - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. - - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. - - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. - - change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). - rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. - - change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). - rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. - - change (find x (combine ((k, e) :: m) m') = - at_least_one (find x m) (find x m')). - rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. -Qed. - -Definition at_least_one_then_f k (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => f k o o' - end. - -Lemma merge_spec0 m (Hm : Sort m) m' (Hm' : Sort m') (x:key) : - exists y, X.eq y x /\ - find x (merge m m') = at_least_one_then_f y (find x m) (find x m'). -Proof. - intros. - rewrite <- merge_equiv. - unfold merge'. - assert (H:=combine_spec Hm Hm' x). - assert (H2:=combine_sorted Hm Hm'). - set (f':= fun k p => f k (fst p) (snd p)). - set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. - set (o':=find x m') in *; clearbody o'. - clear Hm Hm' m m'. revert H. - match goal with |- ?G => - assert (G/\(find x m0 = None -> - find x (fold_right_pair option_cons (mapi f' m0) nil) = None)); - [|intuition] end. - induction m0; simpl in *; intuition. - - exists x; split; [easy|]. - destruct o; destruct o'; simpl in *; try discriminate; auto. - - destruct a as (k,(oo,oo')); simpl in *. - inversion_clear H2. - destruct (X.compare_spec x k) as [Heq|Hlt|Hlt]; simpl in *. - + (* x = k *) - exists k; split; [easy|]. - assert (at_least_one_then_f k o o' = f k oo oo'). - { destruct o; destruct o'; simpl in *; inversion_clear H; auto. } - rewrite H2. - unfold f'; simpl. - destruct (f k oo oo'); simpl. - * elim X.compare_spec; trivial; try MX.order. - * destruct (IHm0 H0) as (_,H4); apply H4; auto. - case_eq (find x m0); intros; auto. - assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). - now compute. - symmetry in H5. - destruct (Sort_Inf_NotIn H0 (Inf_eq H5 H1)). - exists p; apply find_spec; auto. - + (* x < k *) - destruct (f' k (oo,oo')); simpl. - * elim X.compare_spec; trivial; try MX.order. - destruct o; destruct o'; simpl in *; try discriminate; auto. - now exists x. - * apply IHm0; trivial. - rewrite <- H. - case_eq (find x m0); intros; auto. - assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). - red; auto. - destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). - exists p; apply find_spec; auto. - + (* k < x *) - unfold f'; simpl. - destruct (f k oo oo'); simpl. - * elim X.compare_spec; trivial; try MX.order. - intros. apply IHm0; auto. - * apply IHm0; auto. - - - (* None -> None *) - destruct a as (k,(oo,oo')). - simpl. - inversion_clear H2. - destruct (X.compare_spec x k) as [Hlt|Heq|Hlt]; try discriminate. - + (* x < k *) - unfold f'; simpl. - destruct (f k oo oo'); simpl. - elim X.compare_spec; trivial; try MX.order. intros. - apply IHm0; auto. - case_eq (find x m0); intros; auto. - assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). - now compute. - destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). - exists p; apply find_spec; auto. - + (* k < x *) - unfold f'; simpl. - destruct (f k oo oo'); simpl. - elim X.compare_spec; trivial; try MX.order. intros. - apply IHm0; auto. - apply IHm0; auto. -Qed. - -(** Specification of [merge] *) - -Lemma merge_spec1 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) : - In x m \/ In x m' -> - exists y, X.eq y x /\ - find x (merge m m') = f y (find x m) (find x m'). -Proof. - intros. - destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')). - exists y; split; [easy|]. rewrite H'. - destruct H as [(e,H)|(e,H)]; - apply find_spec in H; trivial; rewrite H; simpl; auto. - now destruct (find x m). -Qed. - -Lemma merge_spec2 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) : - In x (merge m m') -> In x m \/ In x m'. -Proof. - intros. - destruct H as (e,H). - apply find_spec in H; auto using merge_sorted. - destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')). - rewrite H in H'. - destruct (find x m) eqn:F. - - apply find_spec in F; eauto. - - destruct (find x m') eqn:F'. - + apply find_spec in F'; eauto. - + simpl in H'. discriminate. -Qed. - -End Elt3. -End Raw. - -Module Make (X: OrderedType) <: S with Module E := X. -Module Raw := Raw X. -Module E := X. - -Definition key := E.t. -Definition eq_key {elt} := @Raw.PX.eqk elt. -Definition eq_key_elt {elt} := @Raw.PX.eqke elt. -Definition lt_key {elt} := @Raw.PX.ltk elt. - -Record t_ (elt:Type) := Mk - {this :> Raw.t elt; - sorted : sort Raw.PX.ltk this}. -Definition t := t_. - -Definition empty {elt} := Mk (Raw.empty_sorted elt). - -Section Elt. - Variable elt elt' elt'':Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Mk (Raw.add_sorted m.(sorted) x e). - Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Mk (Raw.remove_sorted m.(sorted) x). - Definition mem x m : bool := Raw.mem x m.(this). - Definition map f m : t elt' := Mk (Raw.map_sorted f m.(sorted)). - Definition mapi (f:key->elt->elt') m : t elt' := - Mk (Raw.mapi_sorted f m.(sorted)). - Definition merge f m (m':t elt') : t elt'' := - Mk (Raw.merge_sorted f m.(sorted) m'.(sorted)). - Definition bindings m : list (key*elt) := Raw.bindings m.(this). - Definition cardinal m := length m.(this). - Definition fold {A:Type}(f:key->elt->A->A) m (i:A) : A := - Raw.fold f m.(this) i. - Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). - - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). - Definition In x m : Prop := Raw.PX.In x m.(this). - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). - - Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - Proof. - intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx. - Qed. - - Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m. - Proof. exact (Raw.find_spec m.(sorted)). Qed. - - Lemma mem_spec m : forall x, mem x m = true <-> In x m. - Proof. exact (Raw.mem_spec m.(sorted)). Qed. - - Lemma empty_spec : forall x, find x empty = None. - Proof. exact (Raw.empty_spec _). Qed. - - Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None). - Proof. exact (Raw.is_empty_spec m.(this)). Qed. - - Lemma add_spec1 m : forall x e, find x (add x e m) = Some e. - Proof. exact (Raw.add_spec1 m.(this)). Qed. - Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m. - Proof. exact (Raw.add_spec2 m.(this)). Qed. - - Lemma remove_spec1 m : forall x, find x (remove x m) = None. - Proof. exact (Raw.remove_spec1 m.(sorted)). Qed. - Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m. - Proof. exact (Raw.remove_spec2 m.(sorted)). Qed. - - Lemma bindings_spec1 m : forall x e, - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - Proof. exact (Raw.bindings_spec1 m.(this)). Qed. - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. exact (Raw.bindings_spec2w m.(sorted)). Qed. - Lemma bindings_spec2 m : sort lt_key (bindings m). - Proof. exact (Raw.bindings_spec2 m.(sorted)). Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. reflexivity. Qed. - - Lemma fold_spec m : forall (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. exact (Raw.fold_spec m.(this)). Qed. - - Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'. - Proof. exact (Raw.equal_spec m.(sorted) m'.(sorted)). Qed. - -End Elt. - - Lemma map_spec {elt elt'} (f:elt->elt') m : - forall x, find x (map f m) = option_map f (find x m). - Proof. exact (Raw.map_spec f m.(this)). Qed. - - Lemma mapi_spec {elt elt'} (f:key->elt->elt') m : - forall x, exists y, - E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - Proof. exact (Raw.mapi_spec f m.(this)). Qed. - - Lemma merge_spec1 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x m \/ In x m' -> - exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). - Proof. exact (Raw.merge_spec1 f m.(sorted) m'.(sorted)). Qed. - - Lemma merge_spec2 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x (merge f m m') -> In x m \/ In x m'. - Proof. exact (Raw.merge_spec2 m.(sorted) m'.(sorted)). Qed. - -End Make. - -Module Make_ord (X: OrderedType)(D : OrderedType) <: -Sord with Module Data := D - with Module MapS.E := X. - -Module Data := D. -Module MapS := Make(X). -Import MapS. - -Module MD := OrderedTypeFacts(D). -Import MD. - -Definition t := MapS.t D.t. - -Definition cmp e e' := - match D.compare e e' with Eq => true | _ => false end. - -Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop := - match m, m' with - | nil, nil => True - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | Eq => D.eq e e' /\ eq_list l l' - | _ => False - end - | _, _ => False - end. - -Definition eq m m' := eq_list m.(this) m'.(this). - -Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := - match m, m' with - | nil, nil => False - | nil, _ => True - | _, nil => False - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | Lt => True - | Gt => False - | Eq => D.lt e e' \/ (D.eq e e' /\ lt_list l l') - end - end. - -Definition lt m m' := lt_list m.(this) m'.(this). - -Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. -Proof. - intros (l,Hl); induction l. - intros (l',Hl'); unfold eq; simpl. - destruct l'; unfold equal; simpl; intuition. - intros (l',Hl'); unfold eq. - destruct l'. - destruct a; unfold equal; simpl; intuition. - destruct a as (x,e). - destruct p as (x',e'). - unfold equal; simpl. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; simpl; intuition. - unfold cmp at 1. - elim D.compare_spec; try MD.order; simpl. - inversion_clear Hl. - inversion_clear Hl'. - destruct (IHl H (Mk H3)). - unfold equal, eq in H5; simpl in H5; auto. - destruct (andb_prop _ _ H); clear H. - generalize H0; unfold cmp. - elim D.compare_spec; try MD.order; simpl; try discriminate. - destruct (andb_prop _ _ H); clear H. - inversion_clear Hl. - inversion_clear Hl'. - destruct (IHl H (Mk H3)). - unfold equal, eq in H6; simpl in H6; auto. -Qed. - -Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'. -Proof. - now rewrite eq_equal, equal_spec. -Qed. - -Lemma eq_refl : forall m : t, eq m m. -Proof. - intros (m,Hm); induction m; unfold eq; simpl; auto. - destruct a. - destruct (X.compare_spec t0 t0) as [Hlt|Heq|Hlt]; auto. - - split. reflexivity. inversion_clear Hm. apply (IHm H). - - MapS.Raw.MX.order. - - MapS.Raw.MX.order. -Qed. - -Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. -Proof. - intros (m,Hm); induction m; - intros (m', Hm'); destruct m'; unfold eq; simpl; - try destruct a as (x,e); try destruct p as (x',e'); auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - inversion_clear Hm; inversion_clear Hm'. - apply (IHm H0 (Mk H4)); auto. -Qed. - -Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold eq; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - now transitivity e'. - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. - apply (IHm1 H1 (Mk H6) (Mk H8)); intuition. -Qed. - -Instance eq_equiv : Equivalence eq. -Proof. split; [exact eq_refl|exact eq_sym|exact eq_trans]. Qed. - -Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold lt; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - left; transitivity e'; auto. - left; MD.order. - left; MD.order. - right. - split. - transitivity e'; auto. - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. - apply (IHm1 H2 (Mk H6) (Mk H8)); intuition. -Qed. - -Lemma lt_irrefl : forall m, ~ lt m m. -Proof. - intros (m,Hm); induction m; unfold lt; simpl; auto. - destruct a. - destruct (X.compare_spec t0 t0) as [Hlt|Heq|Hlt]; auto. - - intuition. MD.order. inversion_clear Hm. now apply (IHm H0). - - MapS.Raw.MX.order. -Qed. - -Instance lt_strorder : StrictOrder lt. -Proof. split; [exact lt_irrefl|exact lt_trans]. Qed. - -Lemma lt_compat1 : forall m1 m1' m2, eq m1 m1' -> lt m1 m2 -> lt m1' m2. -Proof. - intros (m1,Hm1); induction m1; - intros (m1',Hm1'); destruct m1'; - intros (m2,Hm2); destruct m2; unfold eq, lt; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; simpl; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - left; MD.order. - right. - split. - MD.order. - inversion_clear Hm1; inversion_clear Hm1'; inversion_clear Hm2. - apply (IHm1 H0 (Mk H6) (Mk H8)); intuition. -Qed. - -Lemma lt_compat2 : forall m1 m2 m2', eq m2 m2' -> lt m1 m2 -> lt m1 m2'. -Proof. - intros (m1,Hm1); induction m1; - intros (m2,Hm2); destruct m2; - intros (m2',Hm2'); destruct m2'; unfold eq, lt; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; simpl; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - left; MD.order. - right. - split. - MD.order. - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm2'. - apply (IHm1 H0 (Mk H6) (Mk H8)); intuition. -Qed. - -Instance lt_compat : Proper (eq==>eq==>iff) lt. -Proof. - intros m1 m1' H1 m2 m2' H2. split; intros. - now apply (lt_compat2 H2), (lt_compat1 H1). - symmetry in H1, H2. - now apply (lt_compat2 H2), (lt_compat1 H1). -Qed. - -Ltac cmp_solve := - unfold eq, lt; simpl; elim X.compare_spec; try Raw.MX.order; auto. - -Fixpoint compare_list m1 m2 := match m1, m2 with -| nil, nil => Eq -| nil, _ => Lt -| _, nil => Gt -| (k1,e1)::m1, (k2,e2)::m2 => - match X.compare k1 k2 with - | Lt => Lt - | Gt => Gt - | Eq => match D.compare e1 e2 with - | Lt => Lt - | Gt => Gt - | Eq => compare_list m1 m2 - end - end -end. - -Definition compare m1 m2 := compare_list m1.(this) m2.(this). - -Lemma compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2). -Proof. - unfold CompSpec. - intros (m1,Hm1)(m2,Hm2). unfold compare, eq, lt; simpl. - revert m2 Hm2. - induction m1 as [|(k1,e1) m1 IH1]; destruct m2 as [|(k2,e2) m2]; - try constructor; simpl; intros; auto. - elim X.compare_spec; simpl; try constructor; auto; intros. - elim D.compare_spec; simpl; try constructor; auto; intros. - inversion_clear Hm1; inversion_clear Hm2. - destruct (IH1 H1 _ H3); simpl; try constructor; auto. - elim X.compare_spec; try Raw.MX.order. right. now split. - elim X.compare_spec; try Raw.MX.order. now left. - elim X.compare_spec; try Raw.MX.order; auto. -Qed. - -End Make_ord. diff --git a/theories/MMaps/MMapPositive.v b/theories/MMaps/MMapPositive.v deleted file mode 100644 index d3aab238..00000000 --- a/theories/MMaps/MMapPositive.v +++ /dev/null @@ -1,698 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* x - | y~1 => rev_append y x~1 - | y~0 => rev_append y x~0 - end. -Local Infix "@" := rev_append (at level 60). -Definition rev x := x@1. - -(** The module of maps over positive keys *) - -Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. - - Module E:=PositiveOrderedTypeBits. - Module ME:=KeyOrderedType E. - - Definition key := positive : Type. - - Definition eq_key {A} (p p':key*A) := E.eq (fst p) (fst p'). - - Definition eq_key_elt {A} (p p':key*A) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - - Definition lt_key {A} (p p':key*A) := E.lt (fst p) (fst p'). - - Instance eqk_equiv {A} : Equivalence (@eq_key A) := _. - Instance eqke_equiv {A} : Equivalence (@eq_key_elt A) := _. - Instance ltk_strorder {A} : StrictOrder (@lt_key A) := _. - - Inductive tree (A : Type) := - | Leaf : tree A - | Node : tree A -> option A -> tree A -> tree A. - - Arguments Leaf {A}. - - Scheme tree_ind := Induction for tree Sort Prop. - - Definition t := tree. - - Definition empty {A} : t A := Leaf. - - Section A. - Variable A:Type. - - Fixpoint is_empty (m : t A) : bool := - match m with - | Leaf => true - | Node l None r => (is_empty l) &&& (is_empty r) - | _ => false - end. - - Fixpoint find (i : key) (m : t A) : option A := - match m with - | Leaf => None - | Node l o r => - match i with - | xH => o - | xO ii => find ii l - | xI ii => find ii r - end - end. - - Fixpoint mem (i : key) (m : t A) : bool := - match m with - | Leaf => false - | Node l o r => - match i with - | xH => match o with None => false | _ => true end - | xO ii => mem ii l - | xI ii => mem ii r - end - end. - - Fixpoint add (i : key) (v : A) (m : t A) : t A := - match m with - | Leaf => - match i with - | xH => Node Leaf (Some v) Leaf - | xO ii => Node (add ii v Leaf) None Leaf - | xI ii => Node Leaf None (add ii v Leaf) - end - | Node l o r => - match i with - | xH => Node l (Some v) r - | xO ii => Node (add ii v l) o r - | xI ii => Node l o (add ii v r) - end - end. - - (** helper function to avoid creating empty trees that are not leaves *) - - Definition node (l : t A) (o: option A) (r : t A) : t A := - match o,l,r with - | None,Leaf,Leaf => Leaf - | _,_,_ => Node l o r - end. - - Fixpoint remove (i : key) (m : t A) : t A := - match m with - | Leaf => Leaf - | Node l o r => - match i with - | xH => node l None r - | xO ii => node (remove ii l) o r - | xI ii => node l o (remove ii r) - end - end. - - (** [bindings] *) - - Fixpoint xbindings (m : t A) (i : positive) (a: list (key*A)) := - match m with - | Leaf => a - | Node l None r => xbindings l i~0 (xbindings r i~1 a) - | Node l (Some e) r => xbindings l i~0 ((rev i,e) :: xbindings r i~1 a) - end. - - Definition bindings (m : t A) := xbindings m 1 nil. - - (** [cardinal] *) - - Fixpoint cardinal (m : t A) : nat := - match m with - | Leaf => 0%nat - | Node l None r => (cardinal l + cardinal r)%nat - | Node l (Some _) r => S (cardinal l + cardinal r) - end. - - (** Specification proofs *) - - Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v. - Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m. - - Lemma MapsTo_compat : Proper (E.eq==>eq==>eq==>iff) MapsTo. - Proof. - intros k k' Hk e e' He m m' Hm. red in Hk. now subst. - Qed. - - Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m. - Proof. reflexivity. Qed. - - Lemma mem_find : - forall m x, mem x m = match find x m with None => false | _ => true end. - Proof. - induction m; destruct x; simpl; auto. - Qed. - - Lemma mem_spec : forall m x, mem x m = true <-> In x m. - Proof. - unfold In, MapsTo; intros m x; rewrite mem_find. - split. - - destruct (find x m). - exists a; auto. - intros; discriminate. - - destruct 1 as (e0,H0); rewrite H0; auto. - Qed. - - Lemma gleaf : forall (i : key), find i Leaf = None. - Proof. destruct i; simpl; auto. Qed. - - Theorem empty_spec: - forall (i: key), find i empty = None. - Proof. exact gleaf. Qed. - - Lemma is_empty_spec m : - is_empty m = true <-> forall k, find k m = None. - Proof. - induction m; simpl. - - intuition. apply empty_spec. - - destruct o. split; try discriminate. - intros H. now specialize (H xH). - rewrite <- andb_lazy_alt, andb_true_iff, IHm1, IHm2. - clear IHm1 IHm2. - split. - + intros (H1,H2) k. destruct k; simpl; auto. - + intros H; split; intros k. apply (H (xO k)). apply (H (xI k)). - Qed. - - Theorem add_spec1: - forall (m: t A) (i: key) (x: A), find i (add i x m) = Some x. - Proof. - intros m i; revert m. - induction i; destruct m; simpl; auto. - Qed. - - Theorem add_spec2: - forall (m: t A) (i j: key) (x: A), - i <> j -> find j (add i x m) = find j m. - Proof. - intros m i j; revert m i. - induction j; destruct i, m; simpl; intros; - rewrite ?IHj, ?gleaf; auto; try congruence. - Qed. - - Lemma rleaf : forall (i : key), remove i Leaf = Leaf. - Proof. destruct i; simpl; auto. Qed. - - Lemma gnode l o r i : find i (node l o r) = find i (Node l o r). - Proof. - destruct o,l,r; simpl; trivial. - destruct i; simpl; now rewrite ?gleaf. - Qed. - - Opaque node. - - Theorem remove_spec1: - forall (m: t A)(i: key), find i (remove i m) = None. - Proof. - induction m; simpl. - - intros; rewrite rleaf. apply gleaf. - - destruct i; simpl remove; rewrite gnode; simpl; auto. - Qed. - - Theorem remove_spec2: - forall (m: t A)(i j: key), - i <> j -> find j (remove i m) = find j m. - Proof. - induction m; simpl; intros. - - now rewrite rleaf. - - destruct i; simpl; rewrite gnode; destruct j; simpl; trivial; - try apply IHm1; try apply IHm2; congruence. - Qed. - - Local Notation InL := (InA eq_key_elt). - - Lemma xbindings_spec: forall m j acc k e, - InL (k,e) (xbindings m j acc) <-> - InL (k,e) acc \/ exists x, k=(j@x) /\ find x m = Some e. - Proof. - induction m as [|l IHl o r IHr]; simpl. - - intros. split; intro H. - + now left. - + destruct H as [H|[x [_ H]]]. assumption. - now rewrite gleaf in H. - - intros j acc k e. case o as [e'|]; - rewrite IHl, ?InA_cons, IHr; clear IHl IHr; split. - + intros [[H|[H|H]]|H]; auto. - * unfold eq_key_elt, E.eq, fst, snd in H. destruct H as (->,<-). - right. now exists 1. - * destruct H as (x,(->,H)). right. now exists x~1. - * destruct H as (x,(->,H)). right. now exists x~0. - + intros [H|H]; auto. - destruct H as (x,(->,H)). - destruct x; simpl in *. - * left. right. right. now exists x. - * right. now exists x. - * left. left. injection H as ->. reflexivity. - + intros [[H|H]|H]; auto. - * destruct H as (x,(->,H)). right. now exists x~1. - * destruct H as (x,(->,H)). right. now exists x~0. - + intros [H|H]; auto. - destruct H as (x,(->,H)). - destruct x; simpl in *. - * left. right. now exists x. - * right. now exists x. - * discriminate. - Qed. - - Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). - Proof. induction j; intros; simpl; auto. Qed. - - Lemma xbindings_sort m j acc : - sort lt_key acc -> - (forall x p, In x m -> InL p acc -> E.lt (j@x) (fst p)) -> - sort lt_key (xbindings m j acc). - Proof. - revert j acc. - induction m as [|l IHl o r IHr]; simpl; trivial. - intros j acc Hacc Hsacc. destruct o as [e|]. - - apply IHl;[constructor;[apply IHr; [apply Hacc|]|]|]. - + intros. now apply Hsacc. - + case_eq (xbindings r j~1 acc); [constructor|]. - intros (z,e') q H. constructor. - assert (H': InL (z,e') (xbindings r j~1 acc)). - { rewrite H. now constructor. } - clear H q. rewrite xbindings_spec in H'. - destruct H' as [H'|H']. - * apply (Hsacc 1 (z,e')); trivial. now exists e. - * destruct H' as (x,(->,H)). - red. simpl. now apply lt_rev_append. - + intros x (y,e') Hx Hy. inversion_clear Hy. - rewrite H. simpl. now apply lt_rev_append. - rewrite xbindings_spec in H. - destruct H as [H|H]. - * now apply Hsacc. - * destruct H as (z,(->,H)). simpl. - now apply lt_rev_append. - - apply IHl; [apply IHr; [apply Hacc|]|]. - + intros. now apply Hsacc. - + intros x (y,e') Hx H. rewrite xbindings_spec in H. - destruct H as [H|H]. - * now apply Hsacc. - * destruct H as (z,(->,H)). simpl. - now apply lt_rev_append. - Qed. - - Lemma bindings_spec1 m k e : - InA eq_key_elt (k,e) (bindings m) <-> MapsTo k e m. - Proof. - unfold bindings, MapsTo. rewrite xbindings_spec. - split; [ intros [H|(y & H & H')] | intros IN ]. - - inversion H. - - simpl in *. now subst. - - right. now exists k. - Qed. - - Lemma bindings_spec2 m : sort lt_key (bindings m). - Proof. - unfold bindings. - apply xbindings_sort. constructor. inversion 2. - Qed. - - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. - apply ME.Sort_NoDupA. - apply bindings_spec2. - Qed. - - Lemma xbindings_length m j acc : - length (xbindings m j acc) = (cardinal m + length acc)%nat. - Proof. - revert j acc. - induction m; simpl; trivial; intros. - destruct o; simpl; rewrite IHm1; simpl; rewrite IHm2; - now rewrite ?Nat.add_succ_r, Nat.add_assoc. - Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. - unfold bindings. rewrite xbindings_length. simpl. - symmetry. apply Nat.add_0_r. - Qed. - - (** [map] and [mapi] *) - - Variable B : Type. - - Section Mapi. - - Variable f : key -> option A -> option B. - - Fixpoint xmapi (m : t A) (i : key) : t B := - match m with - | Leaf => Leaf - | Node l o r => Node (xmapi l (i~0)) - (f (rev i) o) - (xmapi r (i~1)) - end. - - End Mapi. - - Definition mapi (f : key -> A -> B) m := - xmapi (fun k => option_map (f k)) m 1. - - Definition map (f : A -> B) m := mapi (fun _ => f) m. - - End A. - - Lemma xgmapi: - forall (A B: Type) (f: key -> option A -> option B) (i j : key) (m: t A), - (forall k, f k None = None) -> - find i (xmapi f m j) = f (j@i) (find i m). - Proof. - induction i; intros; destruct m; simpl; rewrite ?IHi; auto. - Qed. - - Theorem mapi_spec0 : - forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A), - find i (mapi f m) = option_map (f i) (find i m). - Proof. - intros. unfold mapi. rewrite xgmapi; simpl; auto. - Qed. - - Lemma mapi_spec : - forall (A B: Type) (f: key -> A -> B) (m: t A) (i:key), - exists j, E.eq j i /\ - find i (mapi f m) = option_map (f j) (find i m). - Proof. - intros. - exists i. split. reflexivity. apply mapi_spec0. - Qed. - - Lemma map_spec : - forall (elt elt':Type)(f:elt->elt')(m: t elt)(x:key), - find x (map f m) = option_map f (find x m). - Proof. - intros; unfold map. apply mapi_spec0. - Qed. - - Section merge. - Variable A B C : Type. - Variable f : key -> option A -> option B -> option C. - - Fixpoint xmerge (m1 : t A)(m2 : t B)(i:positive) : t C := - match m1 with - | Leaf => xmapi (fun k => f k None) m2 i - | Node l1 o1 r1 => - match m2 with - | Leaf => xmapi (fun k o => f k o None) m1 i - | Node l2 o2 r2 => - Node (xmerge l1 l2 (i~0)) - (f (rev i) o1 o2) - (xmerge r1 r2 (i~1)) - end - end. - - Lemma xgmerge: forall (i j: key)(m1:t A)(m2: t B), - (forall i, f i None None = None) -> - find i (xmerge m1 m2 j) = f (j@i) (find i m1) (find i m2). - Proof. - induction i; intros; destruct m1; destruct m2; simpl; auto; - rewrite ?xgmapi, ?IHi; simpl; auto. - Qed. - - End merge. - - Definition merge {A B C}(f:key->option A->option B->option C) m1 m2 := - xmerge - (fun k o1 o2 => match o1,o2 with - | None,None => None - | _, _ => f k o1 o2 - end) - m1 m2 xH. - - Lemma merge_spec1 {A B C}(f:key->option A->option B->option C) : - forall m m' x, - In x m \/ In x m' -> - exists y, E.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). - Proof. - intros. exists x. split. reflexivity. - unfold merge. - rewrite xgmerge; simpl; auto. - rewrite <- 2 mem_spec, 2 mem_find in H. - destruct (find x m); simpl; auto. - destruct (find x m'); simpl; auto. intuition discriminate. - Qed. - - Lemma merge_spec2 {A B C}(f:key->option A->option B->option C) : - forall m m' x, In x (merge f m m') -> In x m \/ In x m'. - Proof. - intros. - rewrite <-mem_spec, mem_find in H. - unfold merge in H. - rewrite xgmerge in H; simpl; auto. - rewrite <- 2 mem_spec, 2 mem_find. - destruct (find x m); simpl in *; auto. - destruct (find x m'); simpl in *; auto. - Qed. - - Section Fold. - - Variables A B : Type. - Variable f : key -> A -> B -> B. - - (** the additional argument, [i], records the current path, in - reverse order (this should be more efficient: we reverse this argument - only at present nodes only, rather than at each node of the tree). - we also use this convention in all functions below - *) - - Fixpoint xfold (m : t A) (v : B) (i : key) := - match m with - | Leaf => v - | Node l (Some x) r => - xfold r (f (rev i) x (xfold l v i~0)) i~1 - | Node l None r => - xfold r (xfold l v i~0) i~1 - end. - Definition fold m i := xfold m i 1. - - End Fold. - - Lemma fold_spec : - forall {A}(m:t A){B}(i : B) (f : key -> A -> B -> B), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. - unfold fold, bindings. intros A m B i f. revert m i. - set (f' := fun a p => f (fst p) (snd p) a). - assert (H: forall m i j acc, - fold_left f' acc (xfold f m i j) = - fold_left f' (xbindings m j acc) i). - { induction m as [|l IHl o r IHr]; intros; trivial. - destruct o; simpl; now rewrite IHr, <- IHl. } - intros. exact (H m i 1 nil). - Qed. - - Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool := - match m1, m2 with - | Leaf, _ => is_empty m2 - | _, Leaf => is_empty m1 - | Node l1 o1 r1, Node l2 o2 r2 => - (match o1, o2 with - | None, None => true - | Some v1, Some v2 => cmp v1 v2 - | _, _ => false - end) - &&& equal cmp l1 l2 &&& equal cmp r1 r2 - end. - - Definition Equal (A:Type)(m m':t A) := - forall y, find y m = find y m'. - Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp). - - Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - induction m. - - (* m = Leaf *) - destruct 1 as (E,_); simpl. - apply is_empty_spec; intros k. - destruct (find k m') eqn:F; trivial. - assert (H : In k m') by now exists a. - rewrite <- E in H. - destruct H as (x,H). red in H. now rewrite gleaf in H. - - (* m = Node *) - destruct m'. - + (* m' = Leaf *) - destruct 1 as (E,_); simpl. - destruct o. - * assert (H : In xH (@Leaf A)). - { rewrite <- E. now exists a. } - destruct H as (e,H). now red in H. - * apply andb_true_intro; split; apply is_empty_spec; intros k. - destruct (find k m1) eqn:F; trivial. - assert (H : In (xO k) (@Leaf A)). - { rewrite <- E. exists a; auto. } - destruct H as (x,H). red in H. now rewrite gleaf in H. - destruct (find k m2) eqn:F; trivial. - assert (H : In (xI k) (@Leaf A)). - { rewrite <- E. exists a; auto. } - destruct H as (x,H). red in H. now rewrite gleaf in H. - + (* m' = Node *) - destruct 1. - assert (Equivb cmp m1 m'1). - { split. - intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto. - intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto. } - assert (Equivb cmp m2 m'2). - { split. - intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto. - intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto. } - simpl. - destruct o; destruct o0; simpl. - repeat (apply andb_true_intro; split); auto. - apply (H0 xH); red; auto. - generalize (H xH); unfold In, MapsTo; simpl; intuition. - destruct H4; try discriminate; eauto. - generalize (H xH); unfold In, MapsTo; simpl; intuition. - destruct H5; try discriminate; eauto. - apply andb_true_intro; split; auto. - Qed. - - Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - equal cmp m m' = true -> Equivb cmp m m'. - Proof. - induction m. - (* m = Leaf *) - simpl. - split; intros. - split. - destruct 1; red in H0; destruct k; discriminate. - rewrite is_empty_spec in H. - intros (e,H'). red in H'. now rewrite H in H'. - red in H0; destruct k; discriminate. - (* m = Node *) - destruct m'. - (* m' = Leaf *) - simpl. - destruct o; intros; try discriminate. - destruct (andb_prop _ _ H); clear H. - split; intros. - split; unfold In, MapsTo; destruct 1. - destruct k; simpl in *; try discriminate. - rewrite is_empty_spec in H1. - now rewrite H1 in H. - rewrite is_empty_spec in H0. - now rewrite H0 in H. - destruct k; simpl in *; discriminate. - unfold In, MapsTo; destruct k; simpl in *; discriminate. - (* m' = Node *) - destruct o; destruct o0; simpl; intros; try discriminate. - destruct (andb_prop _ _ H); clear H. - destruct (andb_prop _ _ H0); clear H0. - destruct (IHm1 _ _ H2); clear H2 IHm1. - destruct (IHm2 _ _ H1); clear H1 IHm2. - split; intros. - destruct k; unfold In, MapsTo in *; simpl; auto. - split; eauto. - destruct k; unfold In, MapsTo in *; simpl in *. - eapply H4; eauto. - eapply H3; eauto. - congruence. - destruct (andb_prop _ _ H); clear H. - destruct (IHm1 _ _ H0); clear H0 IHm1. - destruct (IHm2 _ _ H1); clear H1 IHm2. - split; intros. - destruct k; unfold In, MapsTo in *; simpl; auto. - split; eauto. - destruct k; unfold In, MapsTo in *; simpl in *. - eapply H3; eauto. - eapply H2; eauto. - try discriminate. - Qed. - - Lemma equal_spec : forall (A:Type)(m m':t A)(cmp:A->A->bool), - equal cmp m m' = true <-> Equivb cmp m m'. - Proof. - split. apply equal_2. apply equal_1. - Qed. - -End PositiveMap. - -(** Here come some additionnal facts about this implementation. - Most are facts that cannot be derivable from the general interface. *) - -Module PositiveMapAdditionalFacts. - Import PositiveMap. - - (* Derivable from the Map interface *) - Theorem gsspec {A} i j x (m: t A) : - find i (add j x m) = if E.eq_dec i j then Some x else find i m. - Proof. - destruct (E.eq_dec i j) as [->|]; - [ apply add_spec1 | apply add_spec2; auto ]. - Qed. - - (* Not derivable from the Map interface *) - Theorem gsident {A} i (m:t A) v : - find i m = Some v -> add i v m = m. - Proof. - revert m. - induction i; destruct m; simpl in *; try congruence. - - intro H; now rewrite (IHi m2 H). - - intro H; now rewrite (IHi m1 H). - Qed. - - Lemma xmapi_ext {A B}(f g: key -> option A -> option B) : - (forall k (o : option A), f k o = g k o) -> - forall m i, xmapi f m i = xmapi g m i. - Proof. - induction m; intros; simpl; auto. now f_equal. - Qed. - - Theorem xmerge_commut{A B C} - (f: key -> option A -> option B -> option C) - (g: key -> option B -> option A -> option C) : - (forall k o1 o2, f k o1 o2 = g k o2 o1) -> - forall m1 m2 i, xmerge f m1 m2 i = xmerge g m2 m1 i. - Proof. - intros E. - induction m1; destruct m2; intros i; simpl; trivial; f_equal; - try apply IHm1_1; try apply IHm1_2; try apply xmapi_ext; - intros; apply E. - Qed. - - Theorem merge_commut{A B C} - (f: key -> option A -> option B -> option C) - (g: key -> option B -> option A -> option C) : - (forall k o1 o2, f k o1 o2 = g k o2 o1) -> - forall m1 m2, merge f m1 m2 = merge g m2 m1. - Proof. - intros E m1 m2. - unfold merge. apply xmerge_commut. - intros k [x1|] [x2|]; trivial. - Qed. - -End PositiveMapAdditionalFacts. diff --git a/theories/MMaps/MMapWeakList.v b/theories/MMaps/MMapWeakList.v deleted file mode 100644 index 656c61e1..00000000 --- a/theories/MMaps/MMapWeakList.v +++ /dev/null @@ -1,687 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* a = a'. -Proof. split; congruence. Qed. - -Module Raw (X:DecidableType). - -Module Import PX := KeyDecidableType X. - -Definition key := X.t. -Definition t (elt:Type) := list (X.t * elt). - -Ltac dec := match goal with - | |- context [ X.eq_dec ?x ?x ] => - let E := fresh "E" in destruct (X.eq_dec x x) as [E|E]; [ | now elim E] - | H : X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] => - let E := fresh "E" in destruct (X.eq_dec x y) as [_|E]; [ | now elim E] - | H : ~X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] => - let E := fresh "E" in destruct (X.eq_dec x y) as [E|_]; [ now elim H | ] - | |- context [ X.eq_dec ?x ?y ] => - let E := fresh "E" in destruct (X.eq_dec x y) as [E|E] -end. - -Section Elt. - -Variable elt : Type. -Notation NoDupA := (@NoDupA _ eqk). - -(** * [find] *) - -Fixpoint find (k:key) (s: t elt) : option elt := - match s with - | nil => None - | (k',x)::s' => if X.eq_dec k k' then Some x else find k s' - end. - -Lemma find_spec : forall m (Hm:NoDupA m) x e, - find x m = Some e <-> MapsTo x e m. -Proof. - unfold PX.MapsTo. - induction m as [ | (k,e) m IH]; simpl. - - split; inversion 1. - - intros Hm k' e'. rewrite InA_cons. - change (eqke (k',e') (k,e)) with (X.eq k' k /\ e' = e). - inversion_clear Hm. dec. - + rewrite Some_iff; intuition. - elim H. apply InA_eqk with (k',e'); auto. - + rewrite IH; intuition. -Qed. - -(** * [mem] *) - -Fixpoint mem (k : key) (s : t elt) : bool := - match s with - | nil => false - | (k',_) :: l => if X.eq_dec k k' then true else mem k l - end. - -Lemma mem_spec : forall m (Hm:NoDupA m) x, mem x m = true <-> In x m. -Proof. - induction m as [ | (k,e) m IH]; simpl; intros Hm x. - - split. discriminate. inversion_clear 1. inversion H0. - - inversion_clear Hm. rewrite PX.In_cons; simpl. - rewrite <- IH by trivial. - dec; intuition. -Qed. - -(** * [empty] *) - -Definition empty : t elt := nil. - -Lemma empty_spec x : find x empty = None. -Proof. - reflexivity. -Qed. - -Lemma empty_NoDup : NoDupA empty. -Proof. - unfold empty; auto. -Qed. - -(** * [is_empty] *) - -Definition is_empty (l : t elt) : bool := if l then true else false. - -Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. -Proof. - destruct m; simpl; intuition; try discriminate. - specialize (H a). - revert H. now dec. -Qed. - -(* Not part of the exported specifications, used later for [merge]. *) - -Lemma find_eq : forall m (Hm:NoDupA m) x x', - X.eq x x' -> find x m = find x' m. -Proof. - induction m; simpl; auto; destruct a; intros. - inversion_clear Hm. - rewrite (IHm H1 x x'); auto. - dec; dec; trivial. - elim E0. now transitivity x. - elim E. now transitivity x'. -Qed. - -(** * [add] *) - -Fixpoint add (k : key) (x : elt) (s : t elt) : t elt := - match s with - | nil => (k,x) :: nil - | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l - end. - -Lemma add_spec1 m x e : find x (add x e m) = Some e. -Proof. - induction m as [ | (k,e') m IH]; simpl. - - now dec. - - dec; simpl; now dec. -Qed. - -Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m. -Proof. - intros N. - assert (N' : ~X.eq y x) by now contradict N. - induction m as [ | (k,e') m IH]; simpl. - - dec; trivial. - - repeat (dec; simpl); trivial. elim N. now transitivity k. -Qed. - -Lemma add_InA : forall m x y e e', - ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. -Proof. - induction m as [ | (k,e') m IH]; simpl; intros. - - inversion_clear H0. elim H. symmetry; apply H1. inversion_clear H1. - - revert H0; dec; rewrite !InA_cons. - + rewrite E. intuition. - + intuition. right; eapply IH; eauto. -Qed. - -Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m). -Proof. - induction m as [ | (k,e') m IH]; simpl; intros Hm x e. - - constructor; auto. now inversion 1. - - inversion_clear Hm. dec; constructor; auto. - + contradict H. apply InA_eqk with (x,e); auto. - + contradict H; apply add_InA with x e; auto. -Qed. - -(** * [remove] *) - -Fixpoint remove (k : key) (s : t elt) : t elt := - match s with - | nil => nil - | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l - end. - -Lemma remove_spec1 m (Hm: NoDupA m) x : find x (remove x m) = None. -Proof. - induction m as [ | (k,e') m IH]; simpl; trivial. - inversion_clear Hm. - repeat (dec; simpl); auto. - destruct (find x m) eqn:F; trivial. - apply find_spec in F; trivial. - elim H. apply InA_eqk with (x,e); auto. -Qed. - -Lemma remove_spec2 m (Hm: NoDupA m) x y : ~X.eq x y -> - find y (remove x m) = find y m. -Proof. - induction m as [ | (k,e') m IH]; simpl; trivial; intros E. - inversion_clear Hm. - repeat (dec; simpl); auto. - elim E. now transitivity k. -Qed. - -Lemma remove_InA : forall m (Hm:NoDupA m) x y e, - InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. -Proof. - induction m as [ | (k,e') m IH]; simpl; trivial; intros. - inversion_clear Hm. - revert H; dec; rewrite !InA_cons; intuition. - right; eapply H; eauto. -Qed. - -Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m). -Proof. - induction m. - simpl; intuition. - intros. - inversion_clear Hm. - destruct a as (x',e'). - simpl; case (X.eq_dec x x'); auto. - constructor; auto. - contradict H; apply remove_InA with x; auto. -Qed. - -(** * [bindings] *) - -Definition bindings (m: t elt) := m. - -Lemma bindings_spec1 m x e : InA eqke (x,e) (bindings m) <-> MapsTo x e m. -Proof. - reflexivity. -Qed. - -Lemma bindings_spec2w m (Hm:NoDupA m) : NoDupA (bindings m). -Proof. - trivial. -Qed. - -(** * [fold] *) - -Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) : A := - match m with - | nil => acc - | (k,e)::m' => fold f m' (f k e acc) - end. - -Lemma fold_spec : forall m (A:Type)(i:A)(f:key->elt->A->A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. -Proof. - induction m as [ | (k,e) m IH]; simpl; auto. -Qed. - -(** * [equal] *) - -Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := - match find k m' with - | None => false - | Some e' => cmp e e' - end. - -Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - fold (fun k e b => andb (check cmp k e m') b) m true. - -Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). - -Definition Submap (cmp:elt->elt->bool) m m' := - (forall k, In k m -> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Definition Equivb (cmp:elt->elt->bool) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Submap cmp m m' -> submap cmp m m' = true. -Proof. - unfold Submap, submap. - induction m. - simpl; auto. - destruct a; simpl; intros. - destruct H. - inversion_clear Hm. - assert (H3 : In t0 m'). - { apply H; exists e; auto with *. } - destruct H3 as (e', H3). - assert (H4 : find t0 m' = Some e') by now apply find_spec. - unfold check at 2. rewrite H4. - rewrite (H0 t0); simpl; auto with *. - eapply IHm; auto. - split; intuition. - apply H. - destruct H6 as (e'',H6); exists e''; auto. - apply H0 with k; auto. -Qed. - -Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - submap cmp m m' = true -> Submap cmp m m'. -Proof. - unfold Submap, submap. - induction m. - simpl; auto. - intuition. - destruct H0; inversion H0. - inversion H0. - - destruct a; simpl; intros. - inversion_clear Hm. - rewrite andb_b_true in H. - assert (check cmp t0 e m' = true). - clear H1 H0 Hm' IHm. - set (b:=check cmp t0 e m') in *. - generalize H; clear H; generalize b; clear b. - induction m; simpl; auto; intros. - destruct a; simpl in *. - destruct (andb_prop _ _ (IHm _ H)); auto. - rewrite H2 in H. - destruct (IHm H1 m' Hm' cmp H); auto. - unfold check in H2. - case_eq (find t0 m'); [intros e' H5 | intros H5]; - rewrite H5 in H2; try discriminate. - split; intros. - destruct H6 as (e0,H6); inversion_clear H6. - compute in H7; destruct H7; subst. - exists e'. - apply PX.MapsTo_eq with t0; auto with *. - apply find_spec; auto. - apply H3. - exists e0; auto. - inversion_clear H6. - compute in H8; destruct H8; subst. - assert (H8 : MapsTo t0 e'0 m'). { eapply PX.MapsTo_eq; eauto. } - apply find_spec in H8; trivial. congruence. - apply H4 with k; auto. -Qed. - -(** Specification of [equal] *) - -Lemma equal_spec : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - equal cmp m m' = true <-> Equivb cmp m m'. -Proof. - unfold Equivb, equal. - split. - - intros. - destruct (andb_prop _ _ H); clear H. - generalize (submap_2 Hm Hm' H0). - generalize (submap_2 Hm' Hm H1). - firstorder. - - intuition. - apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. -Qed. -End Elt. -Section Elt2. -Variable elt elt' : Type. - -(** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f e) :: map f m' - end. - -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f k e) :: mapi f m' - end. - -(** Specification of [map] *) - -Lemma map_spec (f:elt->elt')(m:t elt)(x:key) : - find x (map f m) = option_map f (find x m). -Proof. - induction m as [ | (k,e) m IH]; simpl; trivial. - dec; simpl; trivial. -Qed. - -Lemma map_NoDup m (Hm : NoDupA (@eqk elt) m)(f:elt->elt') : - NoDupA (@eqk elt') (map f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm. - constructor; auto. - contradict H. - clear IHm H0. - induction m; simpl in *; auto. - inversion H. - destruct a; inversion H; auto. -Qed. - -(** Specification of [mapi] *) - -Lemma mapi_spec (f:key->elt->elt')(m:t elt)(x:key) : - exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). -Proof. - induction m as [ | (k,e) m IH]; simpl; trivial. - - now exists x. - - dec; simpl. - + now exists k. - + destruct IH as (y,(Hy,H)). now exists y. -Qed. - -Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), - NoDupA (@eqk elt') (mapi f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm; auto. - constructor; auto. - contradict H. - clear IHm H0. - induction m; simpl in *; auto. - inversion_clear H. - destruct a; inversion_clear H; auto. -Qed. - -End Elt2. - -Lemma mapfst_InA {elt}(m:t elt) x : - InA X.eq x (List.map fst m) <-> In x m. -Proof. - induction m as [| (k,e) m IH]; simpl; auto. - - split; inversion 1. inversion H0. - - rewrite InA_cons, In_cons. simpl. now rewrite IH. -Qed. - -Lemma mapfst_NoDup {elt}(m:t elt) : - NoDupA X.eq (List.map fst m) <-> NoDupA eqk m. -Proof. - induction m as [| (k,e) m IH]; simpl. - - split; constructor. - - split; inversion_clear 1; constructor; try apply IH; trivial. - + contradict H0. rewrite mapfst_InA. eapply In_alt'; eauto. - + rewrite mapfst_InA. contradict H0. now apply In_alt'. -Qed. - -Lemma filter_NoDup f (m:list key) : - NoDupA X.eq m -> NoDupA X.eq (List.filter f m). -Proof. - induction 1; simpl. - - constructor. - - destruct (f x); trivial. constructor; trivial. - contradict H. rewrite InA_alt in *. destruct H as (y,(Hy,H)). - exists y; split; trivial. now rewrite filter_In in H. -Qed. - -Lemma NoDupA_unique_repr (l:list key) x y : - NoDupA X.eq l -> X.eq x y -> List.In x l -> List.In y l -> x = y. -Proof. - intros H E Hx Hy. - induction H; simpl in *. - - inversion Hx. - - intuition; subst; trivial. - elim H. apply InA_alt. now exists y. - elim H. apply InA_alt. now exists x. -Qed. - -Section Elt3. - -Variable elt elt' elt'' : Type. - -Definition restrict (m:t elt)(k:key) := - match find k m with - | None => true - | Some _ => false - end. - -Definition domains (m:t elt)(m':t elt') := - List.map fst m ++ List.filter (restrict m) (List.map fst m'). - -Lemma domains_InA m m' (Hm : NoDupA eqk m) x : - InA X.eq x (domains m m') <-> In x m \/ In x m'. -Proof. - unfold domains. - assert (Proper (X.eq==>eq) (restrict m)). - { intros k k' Hk. unfold restrict. now rewrite (find_eq Hm Hk). } - rewrite InA_app_iff, filter_InA, !mapfst_InA; intuition. - unfold restrict. - destruct (find x m) eqn:F. - - left. apply find_spec in F; trivial. now exists e. - - now right. -Qed. - -Lemma domains_NoDup m m' : NoDupA eqk m -> NoDupA eqk m' -> - NoDupA X.eq (domains m m'). -Proof. - intros Hm Hm'. unfold domains. - apply NoDupA_app; auto with *. - - now apply mapfst_NoDup. - - now apply filter_NoDup, mapfst_NoDup. - - intros x. - rewrite mapfst_InA. intros (e,H). - apply find_spec in H; trivial. - rewrite InA_alt. intros (y,(Hy,H')). - rewrite (find_eq Hm Hy) in H. - rewrite filter_In in H'. destruct H' as (_,H'). - unfold restrict in H'. now rewrite H in H'. -Qed. - -Fixpoint fold_keys (f:key->option elt'') l := - match l with - | nil => nil - | k::l => - match f k with - | Some e => (k,e)::fold_keys f l - | None => fold_keys f l - end - end. - -Lemma fold_keys_In f l x e : - List.In (x,e) (fold_keys f l) <-> List.In x l /\ f x = Some e. -Proof. - induction l as [|k l IH]; simpl. - - intuition. - - destruct (f k) eqn:F; simpl; rewrite IH; clear IH; intuition; - try left; congruence. -Qed. - -Lemma fold_keys_NoDup f l : - NoDupA X.eq l -> NoDupA eqk (fold_keys f l). -Proof. - induction 1; simpl. - - constructor. - - destruct (f x); trivial. - constructor; trivial. contradict H. - apply InA_alt in H. destruct H as ((k,e'),(E,H)). - rewrite fold_keys_In in H. - apply InA_alt. exists k. now split. -Qed. - -Variable f : key -> option elt -> option elt' -> option elt''. - -Definition merge m m' : t elt'' := - fold_keys (fun k => f k (find k m) (find k m')) (domains m m'). - -Lemma merge_NoDup m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m') : - NoDupA (@eqk elt'') (merge m m'). -Proof. - now apply fold_keys_NoDup, domains_NoDup. -Qed. - -Lemma merge_spec1 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x : - In x m \/ In x m' -> - exists y:key, X.eq y x /\ - find x (merge m m') = f y (find x m) (find x m'). -Proof. - assert (Hmm' : NoDupA eqk (merge m m')) by now apply merge_NoDup. - rewrite <- domains_InA; trivial. - rewrite InA_alt. intros (y,(Hy,H)). - exists y; split; [easy|]. - rewrite (find_eq Hm Hy), (find_eq Hm' Hy). - destruct (f y (find y m) (find y m')) eqn:F. - - apply find_spec; trivial. - red. apply InA_alt. exists (y,e). split. now split. - unfold merge. apply fold_keys_In. now split. - - destruct (find x (merge m m')) eqn:F'; trivial. - rewrite <- F; clear F. symmetry. - apply find_spec in F'; trivial. - red in F'. rewrite InA_alt in F'. - destruct F' as ((y',e'),(E,F')). - unfold merge in F'; rewrite fold_keys_In in F'. - destruct F' as (H',F'). - compute in E; destruct E as (Hy',<-). - replace y with y'; trivial. - apply (@NoDupA_unique_repr (domains m m')); auto. - now apply domains_NoDup. - now transitivity x. -Qed. - -Lemma merge_spec2 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x : - In x (merge m m') -> In x m \/ In x m'. -Proof. - rewrite <- domains_InA; trivial. - intros (e,H). red in H. rewrite InA_alt in H. destruct H as ((k,e'),(E,H)). - unfold merge in H; rewrite fold_keys_In in H. destruct H as (H,_). - apply InA_alt. exists k. split; trivial. now destruct E. -Qed. - -End Elt3. -End Raw. - - -Module Make (X: DecidableType) <: WS with Module E:=X. - Module Raw := Raw X. - - Module E := X. - Definition key := E.t. - Definition eq_key {elt} := @Raw.PX.eqk elt. - Definition eq_key_elt {elt} := @Raw.PX.eqke elt. - - Record t_ (elt:Type) := Mk - {this :> Raw.t elt; - nodup : NoDupA Raw.PX.eqk this}. - Definition t := t_. - - Definition empty {elt} : t elt := Mk (Raw.empty_NoDup elt). - -Section Elt. - Variable elt elt' elt'':Type. - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition find x m : option elt := Raw.find x m.(this). - Definition mem x m : bool := Raw.mem x m.(this). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Mk (Raw.add_NoDup m.(nodup) x e). - Definition remove x m : t elt := Mk (Raw.remove_NoDup m.(nodup) x). - Definition map f m : t elt' := Mk (Raw.map_NoDup m.(nodup) f). - Definition mapi (f:key->elt->elt') m : t elt' := - Mk (Raw.mapi_NoDup m.(nodup) f). - Definition merge f m (m':t elt') : t elt'' := - Mk (Raw.merge_NoDup f m.(nodup) m'.(nodup)). - Definition bindings m : list (key*elt) := Raw.bindings m.(this). - Definition cardinal m := length m.(this). - Definition fold {A}(f:key->elt->A->A) m (i:A) : A := Raw.fold f m.(this) i. - Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). - Definition In x m : Prop := Raw.PX.In x m.(this). - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := Raw.Equivb cmp m.(this) m'.(this). - - Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - Proof. - intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx. - Qed. - - Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m. - Proof. exact (Raw.find_spec m.(nodup)). Qed. - - Lemma mem_spec m : forall x, mem x m = true <-> In x m. - Proof. exact (Raw.mem_spec m.(nodup)). Qed. - - Lemma empty_spec : forall x, find x empty = None. - Proof. exact (Raw.empty_spec _). Qed. - - Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None). - Proof. exact (Raw.is_empty_spec m.(this)). Qed. - - Lemma add_spec1 m : forall x e, find x (add x e m) = Some e. - Proof. exact (Raw.add_spec1 m.(this)). Qed. - Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m. - Proof. exact (Raw.add_spec2 m.(this)). Qed. - - Lemma remove_spec1 m : forall x, find x (remove x m) = None. - Proof. exact (Raw.remove_spec1 m.(nodup)). Qed. - Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m. - Proof. exact (Raw.remove_spec2 m.(nodup)). Qed. - - Lemma bindings_spec1 m : forall x e, - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - Proof. exact (Raw.bindings_spec1 m.(this)). Qed. - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. exact (Raw.bindings_spec2w m.(nodup)). Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. reflexivity. Qed. - - Lemma fold_spec m : forall (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. exact (Raw.fold_spec m.(this)). Qed. - - Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'. - Proof. exact (Raw.equal_spec m.(nodup) m'.(nodup)). Qed. - -End Elt. - - Lemma map_spec {elt elt'} (f:elt->elt') m : - forall x, find x (map f m) = option_map f (find x m). - Proof. exact (Raw.map_spec f m.(this)). Qed. - - Lemma mapi_spec {elt elt'} (f:key->elt->elt') m : - forall x, exists y, - E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - Proof. exact (Raw.mapi_spec f m.(this)). Qed. - - Lemma merge_spec1 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x m \/ In x m' -> - exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). - Proof. exact (Raw.merge_spec1 f m.(nodup) m'.(nodup)). Qed. - - Lemma merge_spec2 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x (merge f m m') -> In x m \/ In x m'. - Proof. exact (Raw.merge_spec2 m.(nodup) m'.(nodup)). Qed. - -End Make. diff --git a/theories/MMaps/MMaps.v b/theories/MMaps/MMaps.v deleted file mode 100644 index 054d0722..00000000 --- a/theories/MMaps/MMaps.v +++ /dev/null @@ -1,16 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* a < b*q -> a/b < q. diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v index d5f3f4ad..310748dd 100644 --- a/theories/Numbers/Integer/Abstract/ZDivFloor.v +++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* a < b*q -> a/b < q. diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v index de2e99ec..04301077 100644 --- a/theories/Numbers/Integer/Abstract/ZDivTrunc.v +++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 a < b*q -> a÷b < q. diff --git a/theories/Numbers/Integer/Abstract/ZGcd.v b/theories/Numbers/Integer/Abstract/ZGcd.v index cf6ff79e..30adaeb4 100644 --- a/theories/Numbers/Integer/Abstract/ZGcd.v +++ b/theories/Numbers/Integer/Abstract/ZGcd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 a < b*q -> a/b < q. diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v index ffb04f08..3881a27f 100644 --- a/theories/Numbers/NatInt/NZDomain.v +++ b/theories/Numbers/NatInt/NZDomain.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (a == b*(a/b) <-> a mod b == 0). Proof. intros. apply div_exact; auto'. Qed. -(** Some additionnal inequalities about div. *) +(** Some additional inequalities about div. *) Theorem div_lt_upper_bound: forall a b q, b~=0 -> a < b*q -> a/b < q. diff --git a/theories/Numbers/Natural/Abstract/NGcd.v b/theories/Numbers/Natural/Abstract/NGcd.v index a1f4ddf8..1eac134d 100644 --- a/theories/Numbers/Natural/Abstract/NGcd.v +++ b/theories/Numbers/Natural/Abstract/NGcd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* B) : B := fn (exist _ x eq_refl). -(* This is what we want to be able to do: replace the originaly matched object by a new, +(* This is what we want to be able to do: replace the originally matched object by a new, propositionally equal one. If [fn] works on [x] it should work on any [y | y = x]. *) Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : {y : A | y = x} -> B) diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v index 892305b4..2fccf624 100644 --- a/theories/Program/Syntax.v +++ b/theories/Program/Syntax.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* InA eqk p m. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index cc8c2261..93ca383b 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -342,7 +342,7 @@ Module KeyOrderedType(O:OrderedType). compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. Qed. - (* Additionnal facts *) + (* Additional facts *) Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. Proof. diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v index b484257b..89c56388 100644 --- a/theories/Structures/OrdersEx.v +++ b/theories/Structures/OrdersEx.v @@ -87,7 +87,7 @@ End PairOrderedType. (** Even if [positive] can be seen as an ordered type with respect to the usual order (see above), we can also use a lexicographic order over bits (lower bits are considered first). This is more natural when using - [positive] as indexes for sets or maps (see MSetPositive and MMapPositive. *) + [positive] as indexes for sets or maps (see MSetPositive). *) Local Open Scope positive. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 88fbd8c1..954d3df2 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -90,7 +90,7 @@ Module Type OrderedTypeFullFacts (Import O:OrderedTypeFull'). Instance le_order : PartialOrder eq le. Proof. compute; iorder. Qed. - Instance le_antisym : Antisymmetric eq le. + Instance le_antisym : Antisymmetric _ eq le. Proof. apply partial_order_antisym; auto with *. Qed. Lemma le_not_gt_iff : forall x y, x<=y <-> ~yeqke==>iff) (@ltk elt). Proof. eapply subrelation_proper; eauto with *. Qed. - (* Additionnal facts *) + (* Additional facts *) Instance pair_compat {elt} : Proper (O.eq==>Logic.eq==>eqke) (@pair key elt). Proof. apply pair_compat. Qed. diff --git a/theories/Unicode/Utf8.v b/theories/Unicode/Utf8.v index 3b4beda9..d5c2fa73 100644 --- a/theories/Unicode/Utf8.v +++ b/theories/Unicode/Utf8.v @@ -1,7 +1,7 @@ (* -*- coding:utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 <= a -> a mod b <= a. Proof. intros. apply Z.mod_le; auto. Qed. -(** Some additionnal inequalities about Z.div. *) +(** Some additional inequalities about Z.div. *) Theorem Zdiv_lt_upper_bound: forall a b q, 0 < b -> a < q*b -> a/b < q. diff --git a/theories/ZArith/Zeuclid.v b/theories/ZArith/Zeuclid.v index f5cacc7e..38a824cd 100644 --- a/theories/ZArith/Zeuclid.v +++ b/theories/ZArith/Zeuclid.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 <= b -> Z.rem a b <= a. Proof. intros. zero_or_not b. apply Z.rem_le; auto with zarith. Qed. -(** Some additionnal inequalities about Zdiv. *) +(** Some additional inequalities about Zdiv. *) Theorem Zquot_le_upper_bound: forall a b q, 0 < b -> a <= q*b -> a÷b <= q. diff --git a/theories/ZArith/Zsqrt_compat.v b/theories/ZArith/Zsqrt_compat.v index 65959a69..b80eb445 100644 --- a/theories/ZArith/Zsqrt_compat.v +++ b/theories/ZArith/Zsqrt_compat.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* +\n"; - eprintf " extra options:\n"; - eprintf " -coqlib dir : set the coq standard library directory\n"; - eprintf " -exclude-dir f : skip subdirectories named 'f' during -R search\n"; + eprintf " usage: coqdep [options] +\n"; + eprintf " options:\n"; + eprintf " -c : Also print the dependencies of caml modules (=ocamldep).\n"; + (* Does not work anymore *) + (* eprintf " -w : Print informations on missing or wrong \"Declare + ML Module\" commands in coq files.\n"; *) + (* Does not work anymore: *) + (* eprintf " -D : Prints the missing ocmal module names. No dependency computed.\n"; *) + eprintf " -boot : For coq developpers, prints dependencies over coq library files (omitted by default).\n"; + eprintf " -sort : output the given file name ordered by dependencies\n"; + eprintf " -noglob | -no-glob : \n"; + eprintf " -I dir -as logname : add (non recursively) dir to coq load path under logical name logname\n"; + eprintf " -I dir : add (non recursively) dir to ocaml path\n"; + eprintf " -R dir -as logname : add and import dir recursively to coq load path under logical name logname\n"; (* deprecate? *) + eprintf " -R dir logname : add and import dir recursively to coq load path under logical name logname\n"; + eprintf " -Q dir logname : add (recusively) and open (non recursively) dir to coq load path under logical name logname\n"; eprintf " -dumpgraph f : print a dot dependency graph in file 'f'\n"; + eprintf " -dumpgraphbox f : print a dot dependency graph box in file 'f'\n"; + eprintf " -exclude-dir dir : skip subdirectories named 'dir' during -R/-Q search\n"; + eprintf " -coqlib dir : set the coq standard library directory\n"; + eprintf " -suffix s : \n"; + eprintf " -slash : deprecated, no effect\n"; exit 1 let split_period = Str.split (Str.regexp (Str.quote ".")) @@ -442,16 +459,17 @@ let rec parse = function | "-boot" :: ll -> option_boot := true; parse ll | "-sort" :: ll -> option_sort := true; parse ll | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll - | "-I" :: r :: "-as" :: ln :: ll -> add_dir add_known r []; - add_dir add_known r (split_period ln); - parse ll + | "-I" :: r :: "-as" :: ln :: ll -> + add_rec_dir_no_import add_known r []; + add_rec_dir_no_import add_known r (split_period ln); + parse ll | "-I" :: r :: "-as" :: [] -> usage () | "-I" :: r :: ll -> add_caml_dir r; parse ll | "-I" :: [] -> usage () - | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir add_known r (split_period ln); parse ll + | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll | "-R" :: r :: "-as" :: [] -> usage () - | "-R" :: r :: ln :: ll -> add_rec_dir add_known r (split_period ln); parse ll - | "-Q" :: r :: ln :: ll -> add_dir add_known r (split_period ln); parse ll + | "-R" :: r :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll + | "-Q" :: r :: ln :: ll -> add_rec_dir_no_import add_known r (split_period ln); parse ll | "-R" :: ([] | [_]) -> usage () | "-dumpgraph" :: f :: ll -> option_dump := Some (false, f); parse ll | "-dumpgraphbox" :: f :: ll -> option_dump := Some (true, f); parse ll @@ -471,23 +489,26 @@ let rec parse = function let coqdep () = if Array.length Sys.argv < 2 then usage (); parse (List.tl (Array.to_list Sys.argv)); + (* Add current dir with empty logical path if not set by options above. *) + (try ignore (Coqdep_common.find_dir_logpath (Sys.getcwd())) + with Not_found -> add_norec_dir_import add_known "." []); if not Coq_config.has_natdynlink then option_natdynlk := false; (* NOTE: These directories are searched from last to first *) if !option_boot then begin - add_rec_dir add_known "theories" ["Coq"]; - add_rec_dir add_known "plugins" ["Coq"]; - add_rec_dir (fun _ -> add_caml_known) "theories" ["Coq"]; - add_rec_dir (fun _ -> add_caml_known) "plugins" ["Coq"]; + add_rec_dir_import add_known "theories" ["Coq"]; + add_rec_dir_import add_known "plugins" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end else begin Envars.set_coqlib ~fail:Errors.error; let coqlib = Envars.coqlib () in - add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"]; - add_rec_dir add_coqlib_known (coqlib//"plugins") ["Coq"]; + add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; + add_rec_dir_import add_coqlib_known (coqlib//"plugins") ["Coq"]; let user = coqlib//"user-contrib" in - if Sys.file_exists user then add_dir add_coqlib_known user []; - List.iter (fun s -> add_dir add_coqlib_known s []) + if Sys.file_exists user then add_rec_dir_no_import add_coqlib_known user []; + List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) (Envars.xdg_dirs (fun x -> Pp.msg_warning (Pp.str x))); - List.iter (fun s -> add_dir add_coqlib_known s []) Envars.coqpath; + List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) Envars.coqpath; end; List.iter (fun (f,d) -> add_mli_known f d ".mli") !mliAccu; List.iter (fun (f,d) -> add_mllib_known f d ".mllib") !mllibAccu; diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml index 64ce66d2..6fc82683 100644 --- a/tools/coqdep_boot.ml +++ b/tools/coqdep_boot.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* add_caml_known) "." ["Coq"]; + add_rec_dir_import add_known "." []; + add_rec_dir_import (fun _ -> add_caml_known) "." ["Coq"]; end else begin - add_rec_dir add_known "theories" ["Coq"]; - add_rec_dir add_known "plugins" ["Coq"]; + add_rec_dir_import add_known "theories" ["Coq"]; + add_rec_dir_import add_known "plugins" ["Coq"]; add_caml_dir "tactics"; - add_rec_dir (fun _ -> add_caml_known) "theories" ["Coq"]; - add_rec_dir (fun _ -> add_caml_known) "plugins" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end; if !option_c then mL_dependencies (); coq_dependencies () diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index c1111375..58c8e884 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* dir | None -> "." in absolute_dir dir // basename +(** [find_dir_logpath dir] Return the logical path of directory [dir] + if it has been given one. Raise [Not_found] otherwise. In + particular we can check if "." has been attributed a logical path + after processing all options and silently give the default one if + it hasn't. We may also use this to warn if ap hysical path is met + twice.*) +let register_dir_logpath,find_dir_logpath = + let tbl: (string, string list) Hashtbl.t = Hashtbl.create 19 in + let reg physdir logpath = Hashtbl.add tbl (absolute_dir physdir) logpath in + let fnd physdir = Hashtbl.find tbl (absolute_dir physdir) in + reg,fnd + let file_name s = function | None -> s | Some "." -> s @@ -339,7 +351,8 @@ let escape = Buffer.contents s' let compare_file f1 f2 = - absolute_dir (Filename.dirname f1) = absolute_dir (Filename.dirname f2) + absolute_file_name (Filename.basename f1) (Some (Filename.dirname f1)) + = absolute_file_name (Filename.basename f2) (Some (Filename.dirname f2)) let canonize f = let f' = absolute_dir (Filename.dirname f) // Filename.basename f in @@ -514,11 +527,13 @@ let add_known recur phys_dir log_dir f = List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths | _ -> () -(* Visits all the directories under [dir], including [dir], - or just [dir] if [recur=false] *) - +(** Visit directory [phys_dir] (recursively unless [recur=false]) and + apply function add_file to each regular file encountered. + [log_dir] is the logical name of the [phys_dir]. + [add_file] takes both directory names and the file. *) let rec add_directory recur add_file phys_dir log_dir = let dirh = opendir phys_dir in + register_dir_logpath phys_dir log_dir; try while true do let f = readdir dirh in @@ -531,24 +546,29 @@ let rec add_directory recur add_file phys_dir log_dir = if StrSet.mem f !norec_dirnames then () else if StrSet.mem phys_f !norec_dirs then () - else + else (* TODO: warn if already seen this physycal dir? *) add_directory recur add_file phys_f (log_dir@[f]) | S_REG -> add_file phys_dir log_dir f | _ -> () done with End_of_file -> closedir dirh +(** Simply add this directory and imports it, no subdirs. This is used + by the implicit adding of the current path (which is not recursive). *) +let add_norec_dir_import add_file phys_dir log_dir = + try add_directory false (add_file true) phys_dir log_dir with Unix_error _ -> () + (** -Q semantic: go in subdirs but only full logical paths are known. *) -let add_dir add_file phys_dir log_dir = +let add_rec_dir_no_import add_file phys_dir log_dir = try add_directory true (add_file false) phys_dir log_dir with Unix_error _ -> () (** -R semantic: go in subdirs and suffixes of logical paths are known. *) -let add_rec_dir add_file phys_dir log_dir = +let add_rec_dir_import add_file phys_dir log_dir = handle_unix_error (add_directory true (add_file true) phys_dir) log_dir (** -I semantic: do not go in subdirs. *) let add_caml_dir phys_dir = - handle_unix_error (add_directory true add_caml_known phys_dir) [] + handle_unix_error (add_directory false add_caml_known phys_dir) [] let rec treat_file old_dirname old_name = diff --git a/tools/coqdep_common.mli b/tools/coqdep_common.mli index d610a055..97bdfaef 100644 --- a/tools/coqdep_common.mli +++ b/tools/coqdep_common.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* string list + val option_c : bool ref val option_noglob : bool ref val option_boot : bool ref @@ -47,9 +55,19 @@ val add_directory : bool -> (string -> string list -> string -> unit) -> string -> string list -> unit val add_caml_dir : string -> unit -val add_dir : + +(** Simply add this directory and imports it, no subdirs. This is used + by the implicit adding of the current path. *) +val add_norec_dir_import : + (bool -> string -> string list -> string -> unit) -> string -> string list -> unit + +(** -Q semantic: go in subdirs but only full logical paths are known. *) +val add_rec_dir_no_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit -val add_rec_dir : + +(** -R semantic: go in subdirs and suffixes of logical paths are known. *) +val add_rec_dir_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit + val treat_file : dir -> string -> unit val error_cannot_parse : string -> int * int -> 'a diff --git a/tools/coqdep_lexer.mli b/tools/coqdep_lexer.mli index 84c9ba79..bb17fdf9 100644 --- a/tools/coqdep_lexer.mli +++ b/tools/coqdep_lexer.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (* non dependent match on an inductive with no constructors *) begin match Constr.(kind oty, kind c) with - | Lambda(Anonymous,_,oty), Const (kn, _) + | Lambda(_,_,oty), Const (kn, _) when Vars.noccurn 1 oty && not (Declareops.constant_has_body (lookup_constant kn)) -> let body () = Global.body_of_constant_body (lookup_constant kn) in diff --git a/toplevel/assumptions.mli b/toplevel/assumptions.mli index 9c9f81bd..666218fe 100644 --- a/toplevel/assumptions.mli +++ b/toplevel/assumptions.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* kn | _ -> assert false in Impargs.declare_manual_implicits false gr ~enriching:false [imps]; Typeclasses.declare_instance pri (not global) (ConstRef cst) diff --git a/toplevel/classes.mli b/toplevel/classes.mli index 2b7e9e4f..24c51b31 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Lemmas.call_hook (fun exn -> exn) hook l r) in ignore(Obligations.add_definition ident ~term:c cty ctx ~implicits:imps ~kind:k ~hook obls) else let ce = check_definition def in @@ -1010,7 +1011,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let hook, recname, typ = if List.length binders_rel > 1 then let name = add_suffix recname "_func" in - let hook l gr = + let hook l gr _ = let body = it_mkLambda_or_LetIn (mkApp (Universes.constr_of_global gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in let pl, univs = Evd.universe_context !evdref in @@ -1026,7 +1027,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = hook, name, typ else let typ = it_mkProd_or_LetIn top_arity binders_rel in - let hook l gr = + let hook l gr _ = if Impargs.is_implicit_args () || not (List.is_empty impls) then Impargs.declare_manual_implicits false gr [impls] in hook, recname, typ @@ -1127,7 +1128,8 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in + List.map3 (fun id t (len,imps,_) -> ((id,pl),(t,(len,imps)))) + fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in @@ -1163,7 +1165,8 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in + List.map3 (fun id t (len,imps,_) -> ((id,pl),(t,(len,imps)))) + fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in diff --git a/toplevel/command.mli b/toplevel/command.mli index 8e2d9c6f..b97cb487 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* add_require "Coq.Compat.Coq84" + | _ -> () + let compile_list = ref ([] : (bool * string) list) let glob_opt = ref false @@ -475,7 +480,7 @@ let parse_args arglist = |"-async-proofs-private-flags" -> Flags.async_proofs_private_flags := Some (next ()); |"-worker-id" -> set_worker_id opt (next ()) - |"-compat" -> Flags.compat_version := get_compat_version (next ()) + |"-compat" -> let v = get_compat_version (next ()) in Flags.compat_version := v; add_compat_require v |"-compile" -> add_compile false (next ()) |"-compile-verbose" -> add_compile true (next ()) |"-dump-glob" -> Dumpglob.dump_into_file (next ()); glob_opt := true @@ -541,6 +546,7 @@ let parse_args arglist = |"-v"|"--version" -> Usage.version (exitcode ()) |"-verbose-compat-notations" -> verb_compat_ntn := true |"-where" -> print_where := true + |"-xml" -> Flags.xml_export := true (* Deprecated options *) |"-byte" -> warning "option -byte deprecated, call with .byte suffix" @@ -556,7 +562,6 @@ let parse_args arglist = |"-force-load-proofs" -> warning "Obsolete option \"-force-load-proofs\"." |"-unsafe" -> warning "Obsolete option \"-unsafe\"."; ignore (next ()) |"-quality" -> warning "Obsolete option \"-quality\"." - |"-xml" -> warning "Obsolete option \"-xml\"." (* Unknown option *) | s -> extras := s :: !extras diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 67044745..c9d1ba45 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* explain_signature_mismatch l spec err | LabelAlreadyDeclared l -> explain_label_already_declared l @@ -940,6 +946,7 @@ let explain_module_error = function | IncorrectWithConstraint l -> explain_incorrect_label_constraint l | GenerativeModuleExpected l -> explain_generative_module_expected l | LabelMissing (l,s) -> explain_label_missing l s + | IncludeRestrictedFunctor mp -> explain_include_restricted_functor mp (* Module internalization errors *) diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli index 3d5442bb..3ef98380 100644 --- a/toplevel/himsg.mli +++ b/toplevel/himsg.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* f) lnamedepindsort and env0 = Global.env() in - let sigma, lrecspec = + let sigma, lrecspec, _ = List.fold_right - (fun (_,dep,ind,sort) (evd, l) -> - let evd, indu = Evd.fresh_inductive_instance env0 evd ind in - (evd, (indu,dep,interp_elimination_sort sort) :: l)) - lnamedepindsort (Evd.from_env env0,[]) + (fun (_,dep,ind,sort) (evd, l, inst) -> + let evd, indu, inst = + match inst with + | None -> + let _, ctx = Global.type_of_global_in_context env0 (IndRef ind) in + let ctxs = Univ.ContextSet.of_context ctx in + let evd = Evd.from_ctx (Evd.evar_universe_context_of ctxs) in + let u = Univ.UContext.instance ctx in + evd, (ind,u), Some u + | Some ui -> evd, (ind, ui), inst + in + (evd, (indu,dep,interp_elimination_sort sort) :: l, inst)) + lnamedepindsort (Evd.from_env env0,[],None) in let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in let declare decl fi lrecref = diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli index 98746107..e5d79fd5 100644 --- a/toplevel/indschemes.mli +++ b/toplevel/indschemes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr; - prg_hook : unit Lemmas.declaration_hook; + prg_hook : (Evd.evar_universe_context -> unit) Lemmas.declaration_hook; prg_opaque : bool; + prg_sign: named_context_val; } type program_info = program_info_aux Ephemeron.key @@ -517,7 +518,7 @@ let declare_definition prg = progmap_remove prg; !declare_definition_ref prg.prg_name prg.prg_kind ce prg.prg_implicits - (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r; r)) + (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r)) open Pp @@ -582,6 +583,7 @@ let declare_mutual_definition l = in (* Declare the recursive definitions *) let ctx = Evd.evar_context_universe_context first.prg_ctx in + let fix_exn = Stm.get_fix_exn () in let kns = List.map4 (!declare_fix_ref ~opaque (local, poly, kind) ctx) fixnames fixdecls fixtypes fiximps in (* Declare notations *) @@ -589,8 +591,8 @@ let declare_mutual_definition l = Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; let gr = List.hd kns in let kn = match gr with ConstRef kn -> kn | _ -> assert false in - Lemmas.call_hook (fun exn -> exn) first.prg_hook local gr; - List.iter progmap_remove l; kn + Lemmas.call_hook fix_exn first.prg_hook local gr first.prg_ctx; + List.iter progmap_remove l; kn let shrink_body c = let ctx, b = decompose_lam c in @@ -642,7 +644,7 @@ let declare_obligation prg obl body ty uctx = else Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) } -let init_prog_info ?(opaque = false) n b t ctx deps fixkind notations obls impls kind reduce hook = +let init_prog_info ?(opaque = false) sign n b t ctx deps fixkind notations obls impls kind reduce hook = let obls', b = match b with | None -> @@ -666,8 +668,8 @@ let init_prog_info ?(opaque = false) n b t ctx deps fixkind notations obls impls prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; - prg_hook = hook; - prg_opaque = opaque; } + prg_hook = hook; prg_opaque = opaque; + prg_sign = sign } let map_cardinal m = let i = ref 0 in @@ -822,7 +824,9 @@ let obligation_hook prg obl num auto ctx' _ gr = if not (pi2 prg.prg_kind) (* Not polymorphic *) then (* The universe context was declared globally, we continue from the new global environment. *) - Evd.evar_universe_context (Evd.from_env (Global.env ())) + let evd = Evd.from_env (Global.env ()) in + let ctx' = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx')) in + Evd.evar_universe_context ctx' else ctx' in let prg = { prg with prg_ctx = ctx' } in @@ -853,9 +857,10 @@ let rec solve_obligation prg num tac = let obl = subst_deps_obl obls obl in let kind = kind_of_obligation (pi2 prg.prg_kind) obl.obl_status in let evd = Evd.from_ctx prg.prg_ctx in + let evd = Evd.update_sigma_env evd (Global.env ()) in let auto n tac oblset = auto_solve_obligations n ~oblset tac in let hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in - let () = Lemmas.start_proof_univs obl.obl_name kind evd obl.obl_type hook in + let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd obl.obl_type hook in let () = trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ Printer.pr_constr_env (Global.env ()) Evd.empty obl.obl_type) in let _ = Pfedit.by (snd (get_default_tactic ())) in @@ -889,17 +894,21 @@ and solve_obligation_by_tac prg obls i tac = | Some t -> t | None -> snd (get_default_tactic ()) in + let evd = Evd.from_ctx !prg.prg_ctx in + let evd = Evd.update_sigma_env evd (Global.env ()) in let t, ty, ctx = solve_by_tac obl.obl_name (evar_of_obligation obl) tac - (pi2 !prg.prg_kind) !prg.prg_ctx + (pi2 !prg.prg_kind) (Evd.evar_universe_context evd) in let uctx = Evd.evar_context_universe_context ctx in let () = prg := {!prg with prg_ctx = ctx} in let def, obl' = declare_obligation !prg obl t ty uctx in obls.(i) <- obl'; if def && not (pi2 !prg.prg_kind) then ( - (* Declare the term constraints with the first obligation only *) - let ctx' = Evd.evar_universe_context (Evd.from_env (Global.env ())) in + (* Declare the term constraints with the first obligation only *) + let evd = Evd.from_env (Global.env ()) in + let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in + let ctx' = Evd.evar_universe_context evd in prg := {!prg with prg_ctx = ctx'}); true else false @@ -987,9 +996,10 @@ let show_term n = ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic - ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ -> ())) ?(opaque = false) obls = + ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = + let sign = Decls.initialize_named_context_for_proof () in let info = str (Id.to_string n) ++ str " has type-checked" in - let prg = init_prog_info ~opaque n term t ctx [] None [] obls implicits kind reduce hook in + let prg = init_prog_info sign ~opaque n term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose msg_info (info ++ str "."); @@ -1005,11 +1015,12 @@ let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) | _ -> res) let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) - ?(hook=Lemmas.mk_hook (fun _ _ -> ())) ?(opaque = false) notations fixkind = + ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = + let sign = Decls.initialize_named_context_for_proof () in let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> - let prg = init_prog_info ~opaque n (Some b) t ctx deps (Some fixkind) + let prg = init_prog_info sign ~opaque n (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook in progmap_add n (Ephemeron.create prg)) l; let _defined = diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index 61a8ee52..b2320a57 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ?term:Term.constr -> Term.types -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> ?reduce:(Term.constr -> Term.constr) -> - ?hook:unit Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress + ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list @@ -84,7 +84,7 @@ val add_mutual_definitions : ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(Term.constr -> Term.constr) -> - ?hook:unit Lemmas.declaration_hook -> ?opaque:bool -> + ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool -> notations -> fixpoint_kind -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml index dc2c9264..04da628c 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let long_f_dot_v = ensure_v f in diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index affc2171..008d7a31 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit +(** Set XML hooks *) +val xml_start_library : (unit -> unit) Hook.t +val xml_end_library : (unit -> unit) Hook.t + (** Load a vernac file, verbosely or not. Errors are annotated with file and location *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index b6a1a53f..72dd967b 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt)) | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ()) - | PrintUniverses (b, None) -> + | PrintUniverses (b, dst) -> let univ = Global.universes () in let univ = if b then Univ.sort_universes univ else univ in let pr_remaining = if Global.is_joined_environment () then mt () else str"There may remain asynchronous universe constraints" in - msg_notice (Univ.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) - | PrintUniverses (b, Some s) -> dump_universes b s + begin match dst with + | None -> msg_notice (Univ.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) + | Some s -> dump_universes_gen univ s + end | PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r)) | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ()) | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name s) @@ -2051,7 +2048,7 @@ let check_vernac_supports_polymorphism c p = let enforce_polymorphism = function | None -> Flags.is_universe_polymorphism () - | Some b -> b + | Some b -> Flags.make_polymorphic_flag b; b (** A global default timeout, controled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -2152,7 +2149,8 @@ let interp ?(verbosely=true) ?proof (loc,c) = then Flags.verbosely (interp ?proof ~loc locality poly) c else Flags.silently (interp ?proof ~loc locality poly) c; if orig_program_mode || not !Flags.program_mode || isprogcmd then - Flags.program_mode := orig_program_mode + Flags.program_mode := orig_program_mode; + ignore (Flags.use_polymorphic_flag ()) end with | reraise when @@ -2164,6 +2162,7 @@ let interp ?(verbosely=true) ?proof (loc,c) = let e = locate_if_not_already loc e in let () = restore_timeout () in Flags.program_mode := orig_program_mode; + ignore (Flags.use_polymorphic_flag ()); iraise e and aux_list ?locality ?polymorphism isprogcmd l = List.iter (aux false) (List.map snd l) diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index c6d87596..451ccdb4 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(*