coq-8.6/0000755000175000017500000000000013022274260011133 5ustar garesgarescoq-8.6/INSTALL.doc0000644000175000017500000000334613022274260012736 0ustar garesgares The Coq documentation ===================== The Coq documentation includes - A Reference Manual - A Tutorial - A document presenting the Coq standard library - A list of questions/answers in the FAQ style The sources of the documents are mainly made of LaTeX code from which user-readable PostScript or PDF files, or a user-browsable bunch of html files are generated. Prerequisite ------------ To produce all the documents, the following tools are needed: - latex (latex2e) - pdflatex - dvips - bibtex - makeindex - fig2dev (transfig) - convert (ImageMagick) - hevea - hacha Under Debian based operating systems (Debian, Ubuntu, ...) a working set of packages for compiling the documentation for Coq is: texlive texlive-latex-extra texlive-math-extra texlive-fonts-extra texlive-humanities texlive-pictures latex-xcolor hevea transfig imagemagick Compilation ----------- To produce all documentation about Coq, just run: make doc Alternatively, you can use some specific targets: make doc-ps to produce all PostScript documents make doc-pdf to produce all PDF documents make doc-html to produce all html documents make refman to produce all formats of the reference manual make tutorial to produce all formats of the tutorial make rectutorial to produce all formats of the tutorial on recursive types make faq to produce all formats of the FAQ make stdlib to produce all formats of the Coq standard library Installation ------------ To install all produced documents, do: make DOCDIR=/some/directory/for/documentation install-doc DOCDIR defauts to /usr/share/doc/coq coq-8.6/.gitattributes0000644000175000017500000000017513022274260014031 0ustar garesgares.dir-locals.el export-ignore .gitattributes export-ignore .gitignore export-ignore .mailmap export-ignore TODO export-ignore coq-8.6/COMPATIBILITY0000644000175000017500000001723213022274260013074 0ustar garesgaresPotential sources of incompatibilities between Coq V8.5 and V8.6 ---------------------------------------------------------------- Symptom: An obligation generated by Program or an abstracted subproof has different arguments. Cause: Set Shrink Abstract and Set Shrink Obligations are on by default and the subproof does not use the argument. Remedy: - Adapt the script. - Write an explicit lemma to prove the obligation/subproof and use it instead (compatible with 8.4). - Unset the option for the program/proof the obligation/subproof originates from. Symptom: In a goal, order of hypotheses, or absence of an equality of the form "x = t" or "t = x", or no unfolding of a local definition. Cause: This might be connected to a number of fixes in the tactic "subst". The former behavior can be reactivated by issuing "Unset Regular Subst Tactic". Potential sources of incompatibilities between Coq V8.4 and V8.5 ---------------------------------------------------------------- * List of typical changes to be done to adapt files from Coq 8.4 * * to Coq 8.5 when not using compatibility option "-compat 8.4". * Symptom: "The reference omega was not found in the current environment". Cause: "Require Omega" does not import the tactic "omega" any more Possible solutions: - use "Require Import OmegaTactic" (not compatible with 8.4) - use "Require Import Omega" (compatible with 8.4) - add definition "Ltac omega := Coq.omega.Omega.omega." Symptom: "intuition" cannot solve a goal (not working anymore on non standard connective) Cause: "intuition" had an accidental non uniform behavior fixed on non standard connectives Possible solutions: - use "dintuition" instead; it is stronger than "intuition" and works uniformly on non standard connectives, such as n-ary conjunctions or disjunctions (not compatible with 8.4) - do the script differently Symptom: The constructor foo (in type bar) expects n arguments. Cause: parameters must now be given in patterns Possible solutions: - use option "Set Asymmetric Patterns" (compatible with 8.4) - add "_" for the parameters (not compatible with 8.4) - turn the parameters into implicit arguments (compatible with 8.4) Symptom: "NPeano.Nat.foo" not existing anymore Possible solutions: - use "Nat.foo" instead Symptom: typing problems with proj1_sig or similar Cause: coercion from sig to sigT and similar coercions have been removed so as to make the initial state easier to understand for beginners Solution: change proj1_sig into projT1 and similarly (compatible with 8.4) * Other detailed changes * (see also file CHANGES) - options for *coq* compilation (see below for ocaml). ** [-I foo] is now deprecated and will not add directory foo to the coq load path (only for ocaml, see below). Just replace [-I foo] by [-Q foo ""] in your project file and re-generate makefile. Or perform the same operation directly in your makefile if you edit it by hand. ** Option -R Foo bar is the same in v8.5 than in v8.4 concerning coq load path. ** Option [-I foo -as bar] is unchanged but discouraged unless you compile ocaml code. Use -Q foo bar instead. for more details: file CHANGES or section "Customization at launch time" of the reference manual. - Command line options for ocaml Compilation of ocaml code (plugins) ** [-I foo] is *not* deprecated to add foo to the ocaml load path. ** [-I foo -as bar] adds foo to the ocaml load path *and* adds foo to the coq load path with logical name bar (shortcut for -I foo -Q foo bar). for more details: file CHANGES or section "Customization at launch time" of the reference manual. - Universe Polymorphism. - Refinement, unification and tactics are now aware of universes, resulting in more localized errors. Universe inconsistencies should no more get raised at Qed time but during the proof. Unification *always* produces well-typed substitutions, hence some rare cases of unifications that succeeded while producing ill-typed terms before will now fail. - The [change p with c] tactic semantics changed, now typechecking [c] at each matching occurrence [t] of the pattern [p], and converting [t] with [c]. - Template polymorphic inductive types: the partial application of a template polymorphic type (e.g. list) is not polymorphic. An explicit parameter application (e.g [fun A => list A]) or [apply (list _)] will result in a polymorphic instance. - The type inference algorithm now takes opacity of constants into account. This may have effects on tactics using type inference (e.g. induction). Extra "Transparent" might have to be added to revert opacity of constants. Type classes. - When writing an Instance foo : Class A := {| proj := t |} (note the vertical bars), support for typechecking the projections using the type information and switching to proof mode is no longer available. Use { } (without the vertical bars) instead. Tactic abstract. - Auxiliary lemmas generated by the abstract tactic are removed from the global environment and inlined in the proof term when a proof is ended with Qed. The behavior of 8.4 can be obtained by ending proofs with "Qed exporting" or "Qed exporting ident, .., ident". Potential sources of incompatibilities between Coq V8.3 and V8.4 ---------------------------------------------------------------- (see also file CHANGES) The main known incompatibilities between 8.3 and 8.4 are consequences of the following changes: - The reorganization of the library of numbers: Several definitions have new names or are defined in modules of different names, but a special care has been taken to have this renaming transparent for the user thanks to compatibility notations. However some definitions have changed, what might require some adaptations. The most noticeable examples are: - The "?=" notation which now bind to Pos.compare rather than former Pcompare (now Pos.compare_cont). - Changes in names may induce different automatically generated names in proof scripts (e.g. when issuing "destruct Z_le_gt_dec"). - Z.add has a new definition, hence, applying "simpl" on subterms of its body might give different results than before. - BigN.shiftl and BigN.shiftr have reversed arguments order, the power function in BigN now takes two BigN. - Other changes in libraries: - The definition of functions over "vectors" (list of fixed length) have changed. - TheoryList.v has been removed. - Slight changes in tactics: - Less unfolding of fixpoints when applying destruct or inversion on a fixpoint hiding an inductive type (add an extra call to simpl to preserve compatibility). - Less unexpected local definitions when applying "destruct" (incompatibilities solvable by adapting name hypotheses). - Tactic "apply" might succeed more often, e.g. by now solving pattern-matching of the form ?f x y = g(x,y) (compatibility ensured by using "Unset Tactic Pattern Unification"), but also because it supports (full) betaiota (using "simple apply" might then help). - Tactic autorewrite does no longer instantiate pre-existing existential variables. - Tactic "info" is now available only for auto, eauto and trivial. - Miscellaneous changes: - The command "Load" is now atomic for backtracking (use "Unset Atomic Load" for compatibility). Incompatibilities beyond 8.4... - Syntax: "x -> y" has now lower priority than "<->" "A -> B <-> C" is now "A -> (B <-> C)" - Tactics: tauto and intuition no longer accidentally destruct binary connectives or records other than and, or, prod, sum, iff. In most of cases, dtauto or dintuition, though stronger than 8.3 tauto and 8.3 intuition will provide compatibility. - "Solve Obligations using" is now "Solve Obligations with". coq-8.6/Makefile.install0000644000175000017500000001216713022274260014247 0ustar garesgares####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # /dev/null install-latex: $(MKDIR) $(FULLCOQDOCDIR) $(INSTALLLIB) tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR) # -$(UPDATETEX) install-meta: META.coq $(INSTALLLIB) META.coq $(FULLCOQLIB)/META # For emacs: # Local Variables: # mode: makefile # End: coq-8.6/Makefile.build0000644000175000017500000005532113022274260013677 0ustar garesgares####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # timings.csv TIMED ?= # When $(TIMED) is set, the time command used by default is $(STDTIME) # (see below), unless the following variable is non-empty. For instance, # it could be set to "'/usr/bin/time -p'". TIMECMD ?= # Non-empty skips the update of all dependency .d files: NO_RECALC_DEPS ?= # Non-empty runs the checker on all produced .vo files: VALIDATE ?= # Is "-xml" when building XML library: COQ_XML ?= ########################################################################### # Default starting rule ########################################################################### # build the different subsystems: world: coq coqide documentation revision coq: coqlib coqbinaries tools printers .PHONY: world coq ########################################################################### # Includes ########################################################################### # This list of ml files used to be in the main Makefile, we moved it here # to avoid exhausting the variable env in Win32 MLFILES := $(MLSTATICFILES) $(GENMLFILES) $(ML4FILES:.ml4=.ml) include Makefile.common include Makefile.doc ## provides the 'documentation' rule include Makefile.checker include Makefile.ide ## provides the 'coqide' rule include Makefile.install include Makefile.dev ## provides the 'printers' and 'revision' rules # This include below will lauch the build of all .d. # The - at front is for disabling warnings about currently missing ones. # For creating the missing .d, make will recursively build things like # coqdep_boot (for the .v.d files) or grammar.cma (for .ml4 -> .ml -> .ml.d). DEPENDENCIES := \ $(addsuffix .d, $(MLFILES) $(MLIFILES) $(MLLIBFILES) $(CFILES) $(VFILES)) -include $(DEPENDENCIES) # All dependency includes must be declared secondary, otherwise make will # delete them if it decided to build them by dependency instead of because # of include, and they will then be automatically deleted, leading to an # infinite loop. .SECONDARY: $(DEPENDENCIES) $(GENFILES) $(ML4FILES:.ml4=.ml) ########################################################################### # Compilation options ########################################################################### # Default timing command STDTIME=/usr/bin/time -f "$* (user: %U mem: %M ko)" TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) # NB: do not use a variable named TIME, since this variable controls # the output format of the unix command time. For instance: # TIME="%C (%U user, %S sys, %e total, %M maxres)" COQOPTS=$(COQ_XML) $(NATIVECOMPUTE) BOOTCOQC=$(TIMER) $(COQTOPEXE) -boot $(COQOPTS) -compile LOCALINCLUDES=$(addprefix -I , $(SRCDIRS) ) MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB) OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) BYTEFLAGS=-thread $(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=-thread $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) DEPFLAGS= $(LOCALINCLUDES) -I ide -I ide/utils # On MacOS, the binaries are signed, except our private ones ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin) LINKMETADATA=$(if $(filter $(PRIVATEBINARIES),$@),,-ccopt "-sectcreate __TEXT __info_plist config/Info-$(notdir $@).plist") CODESIGN=$(if $(filter $(PRIVATEBINARIES),$@),true,codesign -s -) else LINKMETADATA= CODESIGN=true endif # Best OCaml compiler, used in a generic way ifeq ($(BEST),opt) OPT:=opt BESTOBJ:=.cmx BESTLIB:=.cmxa BESTDYN:=.cmxs else OPT:= BESTOBJ:=.cmo BESTLIB:=.cma BESTDYN:=.cma endif define bestobj $(patsubst %.cma,%$(BESTLIB),$(patsubst %.cmo,%$(BESTOBJ),$(1))) endef define bestocaml $(if $(OPT),\ $(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@ && $(CODESIGN) $@,\ $(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ $(1) $(addsuffix .cma,$(2)) $^) endef # Camlp4 / Camlp5 settings CAMLP4DEPS:=grammar/compat5.cmo grammar/grammar.cma ifeq ($(CAMLP4),camlp5) CAMLP4USE=pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) else CAMLP4USE=-D$(CAMLVERSION) endif PR_O := $(if $(READABLE_ML4),pr_o.cmo,pr_dump.cmo) 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:=camlp4lib.cma endif ########################################################################### # Infrastructure for the rest of the Makefile ########################################################################### # The SHOW and HIDE variables control whether make will echo complete commands # or only abbreviated versions. # Quiet mode is ON by default except if VERBOSE=1 option is given to make SHOW := $(if $(VERBOSE),@true "",@echo "") HIDE := $(if $(VERBOSE),,@) define order-only-template ifeq "order-only" "$(1)" ORDER_ONLY_SEP:=| endif endef $(foreach f,$(.FEATURES),$(eval $(call order-only-template,$(f)))) ifndef ORDER_ONLY_SEP $(error This Makefile needs GNU Make 3.81 or later (that is a version that supports the order-only dependency feature without major bugs.)) endif VO_TOOLS_DEP := $(COQTOPEXE) ifdef COQ_XML VO_TOOLS_DEP += $(COQDOC) endif ifdef VALIDATE VO_TOOLS_DEP += $(CHICKEN) endif D_DEPEND_BEFORE_SRC := $(if $(NO_RECALC_DEPS),|,) D_DEPEND_AFTER_SRC := $(if $(NO_RECALC_DEPS),,|) ## When a rule redirects stdout of a command to the target file : cmd > $@ ## then the target file will be created even if cmd has failed. ## Hence relaunching make will go further, as make thinks the target has been ## done ok. To avoid this, we use the following macro: TOTARGET = > "$@" || (RV=$$?; rm -f "$@"; exit $${RV}) ########################################################################### # Compilation of .c files ########################################################################### CINCLUDES= -I $(CAMLHLIB) # NB: We used to do a ranlib after ocamlmklib, but it seems that # ocamlmklib is already doing it $(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN) cd $(dir $(LIBCOQRUN)) && \ $(OCAMLFIND) ocamlmklib -oc $(COQRUN) $(foreach u,$(BYTERUN),$(notdir $(u))) kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' \ -e '/^}/q' $< $(TOTARGET) kernel/copcodes.ml: kernel/byterun/coq_instruct.h sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' $< | \ awk -f kernel/make-opcodes $(TOTARGET) %.o: %.c $(SHOW)'OCAMLC $<' $(HIDE)cd $(dir $<) && $(OCAMLC) -ccopt "$(CFLAGS)" -c $(notdir $<) %_stubs.c.d: $(D_DEPEND_BEFORE_SRC) %_stubs.c $(D_DEPEND_AFTER_SRC) $(SHOW)'CCDEP $<' $(HIDE)echo "$@ $(@:.c.d=.o): $(@:.c.d=.c)" > $@ %.c.d: $(D_DEPEND_BEFORE_SRC) %.c $(D_DEPEND_AFTER_SRC) $(GENHFILES) $(SHOW)'CCDEP $<' $(HIDE)$(OCAMLC) -ccopt "-MM -MQ $@ -MQ $(<:.c=.o) -isystem $(CAMLHLIB)" $< $(TOTARGET) ########################################################################### ### Special rules (Camlp5 / Camlp4) ########################################################################### # Special rule for the compatibility-with-camlp5 extension for camlp4 # # - grammar/compat5.cmo changes 'GEXTEND' into 'EXTEND'. Safe, always loaded # - grammar/compat5b.cmo changes 'EXTEND' into 'EXTEND Gram'. Interact badly with # syntax such that 'VERNAC EXTEND', we only load it in grammar/ ifeq ($(CAMLP4),camlp4) grammar/compat5.cmo: grammar/compat5.mlp $(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) -impl' -impl $< grammar/compat5b.cmo: grammar/compat5b.mlp $(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) -impl' -impl $< else grammar/compat5.cmo: grammar/compat5.ml $(OCAMLC) -c $< endif ########################################################################### # grammar/grammar.cma ########################################################################### ## In this part, we compile grammar/grammar.cma ## without relying on .d dependency files, for bootstraping the creation ## and inclusion of these .d files ## Explicit dependencies for grammar stuff GRAMBASEDEPS := grammar/gramCompat.cmo grammar/q_util.cmi GRAMCMO := grammar/gramCompat.cmo grammar/q_util.cmo \ grammar/argextend.cmo grammar/tacextend.cmo grammar/vernacextend.cmo grammar/q_util.cmi : grammar/gramCompat.cmo grammar/argextend.cmo : $(GRAMBASEDEPS) grammar/q_util.cmo : $(GRAMBASEDEPS) grammar/tacextend.cmo : $(GRAMBASEDEPS) grammar/argextend.cmo grammar/vernacextend.cmo : $(GRAMBASEDEPS) grammar/tacextend.cmo \ grammar/argextend.cmo ## Ocaml compiler with the right options and -I for grammar GRAMC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) $(CAMLDEBUG) $(USERFLAGS) \ -I $(MYCAMLP4LIB) -I grammar ## Specific rules for grammar.cma grammar/grammar.cma : $(GRAMCMO) $(SHOW)'Testing $@' @touch grammar/test.mlp $(HIDE)$(GRAMC) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) $^ -impl' -impl grammar/test.mlp -o grammar/test @rm -f grammar/test.* grammar/test $(SHOW)'OCAMLC -a $@' $(HIDE)$(GRAMC) $^ -linkall -a -o $@ ## Support of Camlp5 and Camlp5 ifeq ($(CAMLP4),camlp4) COMPATCMO:=grammar/compat5.cmo grammar/compat5b.cmo GRAMP4USE:=$(COMPATCMO) -D$(CAMLVERSION) GRAMPP:=$(CAMLP4O) -I $(MYCAMLP4LIB) $(GRAMP4USE) $(CAMLP4COMPAT) -impl else COMPATCMO:= GRAMP4USE:=$(COMPATCMO) pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) GRAMPP:=$(CAMLP4O) -I $(MYCAMLP4LIB) $(GRAMP4USE) $(CAMLP4COMPAT) -impl endif ## Rules for standard .mlp and .mli files in grammar/ grammar/%.cmo: grammar/%.mlp | $(COMPATCMO) $(SHOW)'OCAMLC -c -pp $<' $(HIDE)$(GRAMC) -c -pp '$(GRAMPP)' -impl $< grammar/%.cmi: grammar/%.mli $(SHOW)'OCAMLC -c $<' $(HIDE)$(GRAMC) -c $< ########################################################################### # Main targets (coqmktop, coqtop.opt, coqtop.byte) ########################################################################### .PHONY: coqbinaries coqbinaries: $(COQMKTOP) $(COQTOPEXE) $(COQTOPBYTE) \ $(CHICKEN) $(CHICKENBYTE) $(CSDPCERT) $(FAKEIDE) ifeq ($(BEST),opt) $(COQTOPEXE): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(TOPLOOPCMA:.cma=.cmxs) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) $(LINKMETADATA) -o $@ $(STRIP) $@ $(CODESIGN) $@ else $(COQTOPEXE): $(COQTOPBYTE) cp $< $@ endif $(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@ # coqmktop COQMKTOPCMO:=lib/clib.cma lib/cErrors.cmo tools/tolink.cmo tools/coqmktop.cmo $(COQMKTOP): $(call bestobj, $(COQMKTOPCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) tools/tolink.ml: Makefile.build Makefile.common $(SHOW)"ECHO... >" $@ $(HIDE)echo "let copts = \"-cclib -lcoqrun\"" > $@ $(HIDE)echo "let core_libs = \""$(LINKCMO)"\"" >> $@ $(HIDE)echo "let core_objs = \""$(OBJSMOD)"\"" >> $@ # coqc COQCCMO:=lib/clib.cma lib/cErrors.cmo toplevel/usage.cmo tools/coqc.cmo $(COQC): $(call bestobj, $(COQCCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) ########################################################################### # other tools ########################################################################### .PHONY: tools tools: $(TOOLS) $(OCAMLLIBDEP) $(COQDEPBOOT) # coqdep_boot : a basic version of coqdep, with almost no dependencies. # We state these dependencies here explicitly, since some .ml.d files # may still be missing or not taken in account yet by make when coqdep_boot # is being built. COQDEPBOOTSRC := lib/minisys.cmo \ tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep_boot.cmo tools/coqdep_lexer.cmo : tools/coqdep_lexer.cmi tools/coqdep_lexer.cmx : tools/coqdep_lexer.cmi tools/coqdep_common.cmo : lib/minisys.cmo tools/coqdep_lexer.cmi tools/coqdep_common.cmi tools/coqdep_common.cmx : lib/minisys.cmx tools/coqdep_lexer.cmx tools/coqdep_common.cmi tools/coqdep_boot.cmo : tools/coqdep_common.cmi tools/coqdep_boot.cmx : tools/coqdep_common.cmx $(COQDEPBOOT): $(call bestobj, $(COQDEPBOOTSRC)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I tools, unix) $(OCAMLLIBDEP): $(call bestobj, tools/ocamllibdep.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I tools, unix) # The full coqdep (unused by this build, but distributed by make install) COQDEPCMO:=lib/clib.cma lib/cErrors.cmo lib/cWarnings.cmo lib/minisys.cmo \ lib/system.cmo tools/coqdep_lexer.cmo tools/coqdep_common.cmo \ tools/coqdep.cmo $(COQDEP): $(call bestobj, $(COQDEPCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) $(GALLINA): $(call bestobj, tools/gallina_lexer.cmo tools/gallina.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,) COQMAKEFILECMO:=lib/clib.cma ide/project_file.cmo tools/coq_makefile.cmo $(COQMAKEFILE): $(call bestobj,$(COQMAKEFILECMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str unix threads) $(COQTEX): $(call bestobj, tools/coq_tex.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str) $(COQWC): $(call bestobj, tools/coqwc.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,) COQDOCCMO:=lib/clib.cma $(addprefix tools/coqdoc/, \ cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo ) $(COQDOC): $(call bestobj, $(COQDOCCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str unix) $(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkmgr.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,, $(SYSMOD)) # fake_ide : for debugging or test-suite purpose, a fake ide simulating # a connection to coqtop -ideslave FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo ide/document.cmo \ ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo ide/xml_printer.cmo \ ide/xmlprotocol.cmo tools/fake_ide.cmo $(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPLOOPCMA:.cma=$(BESTDYN)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,-I ide,str unix threads) # votour: a small vo explorer (based on the checker) bin/votour: $(call bestobj, lib/cObj.cmo checker/analyze.cmo checker/values.cmo checker/votour.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I checker,) ########################################################################### # Csdp to micromega special targets ########################################################################### CSDPCERTCMO:=lib/clib.cma $(addprefix plugins/micromega/, \ mutils.cmo micromega.cmo \ sos_types.cmo sos_lib.cmo sos.cmo csdpcert.cmo ) $(CSDPCERT): $(call bestobj, $(CSDPCERTCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,nums unix) ########################################################################### # tests ########################################################################### .PHONY: validate check test-suite $(ALLSTDLIB).v VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m validate: $(CHICKEN) | $(ALLVO) $(SHOW)'COQCHK ' $(HIDE)$(CHICKEN) -boot $(VALIDOPTS) $(ALLMODS) $(ALLSTDLIB).v: $(SHOW)'MAKE $(notdir $@)' $(HIDE)echo "Require $(ALLMODS)." > $@ MAKE_TSOPTS=-C test-suite -s VERBOSE=$(VERBOSE) check: validate test-suite test-suite: world $(ALLSTDLIB).v $(MAKE) $(MAKE_TSOPTS) clean $(MAKE) $(MAKE_TSOPTS) all $(MAKE) $(MAKE_TSOPTS) report ########################################################################### # Default rules for compiling ML code ########################################################################### # Target for libraries .cma and .cmxa # The dependency over the .mllib is somewhat artificial, since # ocamlc -a won't use this file, hence the $(filter-out ...) below. # But this ensures that the .cm(x)a is rebuilt when needed, # (especially when removing a module in the .mllib). # We used to have a "order-only" dependency over .mllib.d here, # but the -include mechanism should already ensure that we have # up-to-date dependencies. %.cma: %.mllib $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) %.cmxa: %.mllib $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^) # For plugin packs # Note: both ocamlc -pack and ocamlopt -pack will create the same .cmi, and there's # apparently no way to avoid that (no -intf-suffix hack as below). # We at least ensure that these two commands won't run at the same time, by a fake # dependency from the packed .cmx to the packed .cmo. %.cmo: %.mlpack $(SHOW)'OCAMLC -pack -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -pack -o $@ $(filter-out %.mlpack, $^) %.cmx: %.mlpack %.cmo $(SHOW)'OCAMLOPT -pack -o $@' $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -pack -o $@ $(filter-out %.mlpack %.cmo, $^) COND_BYTEFLAGS= \ $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) $(BYTEFLAGS) COND_OPTFLAGS= \ $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) $(OPTFLAGS) %.cmi: %.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< %.cmo: %.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< ## NB: for the moment ocamlopt erases and recreates .cmi if there's no .mli around. ## This can lead to nasty things with make -j. To avoid that: ## 1) We make .cmx always depend on .cmi ## 2) This .cmi will be created from the .mli, or trigger the compilation of the ## .cmo if there's no .mli (see rule below about MLWITHOUTMLI) ## 3) We tell ocamlopt to use the .cmi as the interface source file. With this ## hack, everything goes as if there is a .mli, and the .cmi is preserved ## and the .cmx is checked with respect to this .cmi HACKMLI = $(if $(wildcard $= 3.12) OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack %.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(GENFILES) $(SHOW)'OCAMLDEP $<' $(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET) %.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(GENFILES) $(SHOW)'OCAMLDEP $<' $(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET) %.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) $(SHOW)'OCAMLLIBDEP $<' $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET) %.mlpack.d: $(D_DEPEND_BEFORE_SRC) %.mlpack $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) $(SHOW)'OCAMLLIBDEP $<' $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET) ########################################################################### # Compilation of .v files ########################################################################### # NB: for make world, no need to mention explicitly the .cmxs of the plugins, # since they are all mentioned in at least one Declare ML Module in some .v coqlib: theories plugins theories: $(THEORIESVO) plugins: $(PLUGINSVO) .PHONY: coqlib theories plugins # One of the .v files is macro-generated theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml $(OCAML) $< $(TOTARGET) # The .vo files in Init are built with the -noinit option theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) $(SHOW)'COQC $(COQ_XML) -noinit $<' $(HIDE)rm -f theories/Init/$*.glob $(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq # The general rule for building .vo files : %.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) $(SHOW)'COQC $<' $(HIDE)rm -f $*.glob $(HIDE)$(BOOTCOQC) $< ifdef VALIDATE $(SHOW)'COQCHK $(call vo_to_mod,$@)' $(HIDE)$(CHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \ || ( RV=$$?; rm -f "$@"; exit $${RV} ) endif # Dependencies of .v files %.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENVFILES) $(SHOW)'COQDEP $<' $(HIDE)$(COQDEPBOOT) -boot $(DEPNATDYN) "$<" $(TOTARGET) ########################################################################### # To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles Makefile $(wildcard Makefile.*) config/Makefile : ; # Final catch-all rule. # Usually, 'make' would display such an error itself. # But if the target has some declared dependencies (e.g. in a .d) # but no building rule, 'make' succeeds silently (see bug #4812). %: @echo "Error: no rule to make target $@ (or missing .PHONY)" && false # For emacs: # Local Variables: # mode: makefile # End: coq-8.6/README.md0000644000175000017500000000322413022274260012413 0ustar garesgares# Coq Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable algorithms and theorems together with an environment for semi-interactive development of machine-checked proofs. ## Installation See the file `INSTALL` for installation procedure. ## Documentation The documentation is part of the archive in directory doc. The documentation of the last released version is available on the Coq web site at [coq.inria.fr/doc](http://coq.inria.fr/doc). ## Changes There is a file named `CHANGES` that explains the differences and the incompatibilities since last versions. If you upgrade Coq, please read it carefully. ## Availability Coq is available from [coq.inria.fr](http://coq.inria.fr). ## The Coq Club The Coq Club moderated mailing list is meant to be a standard way to discuss questions about the Coq system and related topics. The subscription link can be found at [coq.inria.fr/community](http://coq.inria.fr/community). The topics to be discussed in the club should include: * technical problems; * questions about proof developments; * suggestions and questions about the implementation; * announcements of proofs; * theoretical questions about typed lambda-calculi which are closely related to Coq. For any questions/suggestions about the Coq Club, please write to `coq-club-request@inria.fr`. ## Bugs report Send your bug reports by filling a form at [coq.inria.fr/bugs](http://coq.inria.fr/bugs). To be effective, bug reports should mention the OCaml version used to compile and run Coq, the Coq version (`coqtop -v`), the configuration used, and include a complete source example leading to the bug. coq-8.6/.merlin0000644000175000017500000000062313022274260012423 0ustar garesgaresFLG -rectypes -thread S config B config S ide B ide S lib B lib S intf B intf S kernel B kernel S kernel/byterun B kernel/byterun S library B library S engine B engine S pretyping B pretyping S interp B interp S proofs B proofs S tactics B tactics S printing B printing S parsing B parsing S stm B stm S toplevel B toplevel S tools B tools S tools/coqdoc B tools/coqdoc S dev B dev PKG threads.posix coq-8.6/Makefile.common0000644000175000017500000001451613022274260014071 0ustar garesgares####################################################################### # v # The Coq Proof Assistant / The Coq Development Team # # string array (* run by the master, on a thread *) val request_of_task : competence worker_status -> task -> request option val task_match : competence worker_status -> task -> bool val use_response : competence worker_status -> task -> response -> [ `Stay of competence * task list | `End ] val on_marshal_error : string -> task -> unit val on_task_cancellation_or_expiration_or_slave_death : task option -> unit val forward_feedback : Feedback.feedback -> unit (* run by the worker *) val perform : request -> response (* debugging *) val name_of_task : task -> string val name_of_request : request -> string end type expiration = bool ref module MakeQueue(T : Task) : sig type queue (* Number of workers, 0 = lazy local *) val create : int -> queue val destroy : queue -> unit val n_workers : queue -> int val enqueue_task : queue -> T.task * expiration -> unit (* blocking function that waits for the task queue to be empty *) val join : queue -> unit val cancel_all : queue -> unit val cancel_worker : queue -> WorkerPool.worker_id -> unit val set_order : queue -> (T.task -> T.task -> int) -> unit val broadcast : queue -> unit (* Take a snapshot (non destructive but waits until all workers are * enqueued) *) val snapshot : queue -> T.task list (* Clears the queue, only if the worker prool is empty *) val clear : queue -> unit (* create a queue, run the function, destroy the queue. * the user should call join *) val with_n_workers : int -> (queue -> 'a) -> 'a end module MakeWorker(T : Task) : sig val main_loop : unit -> unit val init_stdout : unit -> unit end coq-8.6/stm/spawned.ml0000644000175000017500000000534713022274260013742 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* prerr_endline "internal protocol error"; exit 1 | ReqDie -> prerr_endline "death sentence received"; exit 0 | ReqStats -> output_value oc (RespStats (Gc.quick_stat ())); flush oc; loop () with | e -> prerr_endline ("control channel broken: " ^ Printexc.to_string e); exit 1 in loop () in ignore(Thread.create main ()) let main_channel = ref None let control_channel = ref None let channels = ref None let init_channels () = if !channels <> None then CErrors.anomaly(Pp.str "init_channels called twice"); let () = match !main_channel with | None -> () | Some (Socket(mh,mpr,mpw)) -> channels := Some (open_bin_connection mh mpr mpw); | Some AnonPipe -> let stdin = Unix.in_channel_of_descr (Unix.dup Unix.stdin) in let stdout = Unix.out_channel_of_descr (Unix.dup Unix.stdout) in Unix.dup2 Unix.stderr Unix.stdout; set_binary_mode_in stdin true; set_binary_mode_out stdout true; let stdin = CThread.prepare_in_channel_for_thread_friendly_io stdin in channels := Some (stdin, stdout); in match !control_channel with | None -> () | Some (Socket (ch, cpr, cpw)) -> controller ch cpr cpw | Some AnonPipe -> CErrors.anomaly (Pp.str "control channel cannot be a pipe") let get_channels () = match !channels with | None -> Printf.eprintf "Fatal error: ideslave communication channels not set.\n"; exit 1 | Some(ic, oc) -> ic, oc coq-8.6/stm/coqworkmgrApi.ml0000644000175000017500000001022713022274260015117 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* '\r' then s else String.sub s 0 (len - 1) let positive_int_of_string n = try let n = int_of_string n in if n <= 0 then raise ParseError else n with Invalid_argument _ | Failure _ -> raise ParseError let parse_request s = if debug then Printf.eprintf "parsing '%s'\n" s; match Str.split (Str.regexp " ") (strip_r s) with | [ "HELLO"; "LOW" ] -> Hello Flags.Low | [ "HELLO"; "HIGH" ] -> Hello Flags.High | [ "GET"; n ] -> Get (positive_int_of_string n) | [ "TRYGET"; n ] -> TryGet (positive_int_of_string n) | [ "GIVEBACK"; n ] -> GiveBack (positive_int_of_string n) | [ "PING" ] -> Ping | _ -> raise ParseError let parse_response s = if debug then Printf.eprintf "parsing '%s'\n" s; match Str.split (Str.regexp " ") (strip_r s) with | [ "TOKENS"; n ] -> Tokens (positive_int_of_string n) | [ "NOLUCK" ] -> Noluck | [ "PONG"; n; m; p ] -> let n = try int_of_string n with _ -> raise ParseError in let m = try int_of_string m with _ -> raise ParseError in let p = try int_of_string p with _ -> raise ParseError in Pong (n,m,p) | _ -> raise ParseError let print_request = function | Hello Flags.Low -> "HELLO LOW\n" | Hello Flags.High -> "HELLO HIGH\n" | Get n -> Printf.sprintf "GET %d\n" n | TryGet n -> Printf.sprintf "TRYGET %d\n" n | GiveBack n -> Printf.sprintf "GIVEBACK %d\n" n | Ping -> "PING\n" let print_response = function | Tokens n -> Printf.sprintf "TOKENS %d\n" n | Noluck -> "NOLUCK\n" | Pong (n,m,p) -> Printf.sprintf "PONG %d %d %d\n" n m p let connect s = try match Str.split (Str.regexp ":") s with | [ h; p ] -> let open Unix in let s = socket PF_INET SOCK_STREAM 0 in connect s (ADDR_INET (inet_addr_of_string h,int_of_string p)); Some s | _ -> None with Unix.Unix_error _ -> None let manager = ref None let option_map f = function None -> None | Some x -> Some (f x) let init p = try let sock = Sys.getenv "COQWORKMGR_SOCK" in manager := option_map (fun s -> let cout = Unix.out_channel_of_descr s in set_binary_mode_out cout true; let cin = Unix.in_channel_of_descr s in set_binary_mode_in cin true; output_string cout (print_request (Hello p)); flush cout; cin, cout) (connect sock) with Not_found | End_of_file -> () let with_manager f g = try match !manager with | None -> f () | Some (cin, cout) -> g cin cout with | ParseError | End_of_file -> manager := None; f () let get n = with_manager (fun () -> min n (min !Flags.async_proofs_n_workers !Flags.async_proofs_n_tacworkers)) (fun cin cout -> output_string cout (print_request (Get n)); flush cout; let l = input_line cin in match parse_response l with | Tokens m -> m | _ -> raise (Failure "coqworkmgr protocol error")) let tryget n = with_manager (fun () -> Some (min n (min !Flags.async_proofs_n_workers !Flags.async_proofs_n_tacworkers))) (fun cin cout -> output_string cout (print_request (TryGet n)); flush cout; let l = input_line cin in match parse_response l with | Tokens m -> Some m | Noluck -> None | _ -> raise (Failure "coqworkmgr protocol error")) let giveback n = with_manager (fun () -> ()) (fun cin cout -> output_string cout (print_request (GiveBack n)); flush cout) coq-8.6/stm/vcs.mli0000644000175000017500000000720513022274260013240 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t val equal : t -> t -> bool val compare : t -> t -> int val to_string : t -> string val master : t end type id type ('kind) branch_info = { kind : [> `Master] as 'kind; root : id; pos : id; } type ('kind,'diff,'info,'property_data) t constraint 'kind = [> `Master ] val empty : id -> ('kind,'diff,'info,'property_data) t val current_branch : ('k,'e,'i,'c) t -> Branch.t val branches : ('k,'e,'i,'c) t -> Branch.t list val get_branch : ('k,'e,'i,'c) t -> Branch.t -> 'k branch_info val reset_branch : ('k,'e,'i,'c) t -> Branch.t -> id -> ('k,'e,'i,'c) t val branch : ('kind,'e,'i,'c) t -> ?root:id -> ?pos:id -> Branch.t -> 'kind -> ('kind,'e,'i,'c) t val delete_branch : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t val merge : ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> ?into:Branch.t -> Branch.t -> ('k,'diff,'i,'c) t val commit : ('k,'diff,'i,'c) t -> id -> 'diff -> ('k,'diff,'i,'c) t val rewrite_merge : ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> at:id -> Branch.t -> ('k,'diff,'i,'c) t val checkout : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t val set_info : ('k,'e,'info,'c) t -> id -> 'info -> ('k,'e,'info,'c) t val get_info : ('k,'e,'info,'c) t -> id -> 'info option (* Read only dag *) module Dag : Dag.S with type node = id val dag : ('kind,'diff,'info,'cdata) t -> ('diff,'info,'cdata) Dag.t (* Properties are not a concept typical of a VCS, but a useful metadata * of a DAG (or graph). *) val create_property : ('k,'e,'i,'c) t -> id list -> 'c -> ('k,'e,'i,'c) t val property_of : ('k,'e,'i,'c) t -> id -> 'c Dag.Property.t list val delete_property : ('k,'e,'i,'c) t -> 'c Dag.Property.t -> ('k,'e,'i,'c) t (* Removes all unreachable nodes and returns them *) val gc : ('k,'e,'info,'c) t -> ('k,'e,'info,'c) t * Dag.NodeSet.t val reachable : ('k,'e,'info,'c) t -> id -> Dag.NodeSet.t end module Make(OT : Map.OrderedType) : S with type id = OT.t and type Dag.node = OT.t and type Dag.NodeSet.t = Set.Make(OT).t and type Dag.NodeSet.elt = OT.t coq-8.6/stm/vio_checking.mli0000644000175000017500000000135313022274260015073 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val schedule_vio_checking : int -> string list -> unit val schedule_vio_compilation : int -> string list -> unit coq-8.6/stm/stm.mli0000644000175000017500000002051513022274260013247 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ?newtip:Stateid.t -> ?check:(vernac_expr located -> unit) -> bool -> edit_id -> string -> Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] (* parses and executes a command at a given state, throws away its side effects but for the printings. Feedback is sent with report_with (defaults to dummy state id) *) val query : at:Stateid.t -> ?report_with:(Stateid.t * Feedback.route_id) -> string -> unit (* [edit_at id] is issued to change the editing zone. [`NewTip] is returned if the requested id is the new document tip hence the document portion following [id] is dropped by Coq. [`Focus fo] is returned to say that [fo.tip] is the new document tip, the document between [id] and [fo.stop] has been dropped. The portion between [fo.stop] and [fo.tip] has been kept. [fo.start] is just to tell the gui where the editing zone starts, in case it wants to graphically denote it. All subsequent [add] happen on top of [id]. If Flags.async_proofs_full is set, then [id] is not [observe]d, else it is. *) type focus = { start : Stateid.t; stop : Stateid.t; tip : Stateid.t } val edit_at : Stateid.t -> [ `NewTip | `Focus of focus ] (* Evaluates the tip of the current branch *) val finish : unit -> unit val observe : Stateid.t -> unit val stop_worker : string -> unit (* Joins the entire document. Implies finish, but also checks proofs *) val join : unit -> unit (* Saves on the disk a .vio corresponding to the current status: - if the worker pool is empty, all tasks are saved - if the worker proof is not empty, then it waits until all workers are done with their current jobs and then dumps (or fails if one of the completed tasks is a failure) *) val snapshot_vio : DirPath.t -> string -> unit (* Empties the task queue, can be used only if the worker pool is empty (E.g. * after having built a .vio in batch mode *) val reset_task_queue : unit -> unit (* A .vio contains tasks to be completed *) type tasks val check_task : string -> tasks -> int -> bool val info_tasks : tasks -> (string * float * int) list val finish_tasks : string -> Library.seg_univ -> Library.seg_discharge -> Library.seg_proofs -> tasks -> Library.seg_univ * Library.seg_proofs (* Id of the tip of the current branch *) val get_current_state : unit -> Stateid.t (* Misc *) val init : unit -> unit (* This returns the node at that position *) val get_ast : Stateid.t -> (Vernacexpr.vernac_expr * Loc.t) option (* Filename *) val set_compilation_hints : string -> unit (* Reorders the task queue putting forward what is in the perspective *) val set_perspective : Stateid.t list -> unit type document val backup : unit -> document val restore : document -> unit (** workers **************************************************************** **) module ProofTask : AsyncTaskQueue.Task module TacTask : AsyncTaskQueue.Task module QueryTask : AsyncTaskQueue.Task (** document structure customization *************************************** **) (* A proof block delimiter defines a syntactic delimiter for sub proofs that, when contain an error, do not impact the rest of the proof. While checking a proof, if an error occurs in a (valid) block then processing can skip the entire block and go on to give feedback on the rest of the proof. static_block_detection and dynamic_block_validation are run when the closing block marker is parsed/executed respectively. static_block_detection is for example called when "}" is parsed and declares a block containing all proof steps between it and the matching "{". dynamic_block_validation is called when an error "crosses" the "}" statement. Depending on the nature of the goal focused by "{" the block may absorb the error or not. For example if the focused goal occurs in the type of another goal, then the block is leaky. Note that one can design proof commands that need no dynamic validation. Example of document: .. { tac1. tac2. } .. Corresponding DAG: .. (3) <-- { -- (4) <-- tac1 -- (5) <-- tac2 -- (6) <-- } -- (7) .. Declaration of block [-------------------------------------------] start = 5 the first state_id that could fail in the block stop = 7 the node that may absorb the error dynamic_switch = 4 dynamic check on this node carry_on_data = () no need to carry extra data from static to dynamic checks *) module DynBlockData : Dyn.S type static_block_declaration = { block_start : Stateid.t; block_stop : Stateid.t; dynamic_switch : Stateid.t; carry_on_data : DynBlockData.t; } type document_node = { indentation : int; ast : Vernacexpr.vernac_expr; id : Stateid.t; } type document_view = { entry_point : document_node; prev_node : document_node -> document_node option; } type static_block_detection = document_view -> static_block_declaration option type recovery_action = { base_state : Stateid.t; goals_to_admit : Goal.goal list; recovery_command : Vernacexpr.vernac_expr option; } type dynamic_block_error_recovery = static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ] val register_proof_block_delimiter : Vernacexpr.proof_block_name -> static_block_detection -> dynamic_block_error_recovery -> unit (** customization ********************************************************** **) (* From the master (or worker, but beware that to install the hook * into a worker one has to build the worker toploop to do so and * the alternative toploop for the worker can be selected by changing * the name of the Task(s) above) *) val state_computed_hook : (Stateid.t -> in_cache:bool -> unit) Hook.t val parse_error_hook : (Feedback.edit_or_state_id -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t 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 type state = { system : States.state; proof : Proof_global.state; shallow : bool } val state_of_id : Stateid.t -> [ `Valid of state option | `Expired | `Error of exn ] (** read-eval-print loop compatible interface ****************************** **) (* Adds a new line to the document. It replaces the core of Vernac.interp. [finish] is called as the last bit of this function if the system is running interactively (-emacs or coqtop). *) val interp : bool -> vernac_expr located -> unit (* Queries for backward compatibility *) val current_proof_depth : unit -> int val get_all_proof_names : unit -> Id.t list val get_current_proof_name : unit -> Id.t option val show_script : ?proof:Proof_global.closed_proof -> unit -> unit (* Hooks to be set by other Coq components in order to break file cycles *) val process_error_hook : Future.fix_exn Hook.t val interp_hook : (?verbosely:bool -> ?proof:Proof_global.closed_proof -> Loc.t * Vernacexpr.vernac_expr -> unit) Hook.t val with_fail_hook : (bool -> (unit -> unit) -> unit) Hook.t val get_fix_exn : unit -> (Exninfo.iexn -> Exninfo.iexn) coq-8.6/stm/tacworkertop.mllib0000644000175000017500000000001513022274260015477 0ustar garesgaresTacworkertop coq-8.6/stm/queryworkertop.ml0000644000175000017500000000144513022274260015416 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Flags.make_silent true; W.init_stdout (); CoqworkmgrApi.init !Flags.async_proofs_worker_priority; args) let () = Coqtop.toploop_run := W.main_loop coq-8.6/stm/vcs.ml0000644000175000017500000001362313022274260013070 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* t val equal : t -> t -> bool val compare : t -> t -> int val to_string : t -> string val master : t end type id type ('kind) branch_info = { kind : [> `Master] as 'kind; root : id; pos : id; } type ('kind,'diff,'info,'property_data) t constraint 'kind = [> `Master ] val empty : id -> ('kind,'diff,'info,'property_data) t val current_branch : ('k,'e,'i,'c) t -> Branch.t val branches : ('k,'e,'i,'c) t -> Branch.t list val get_branch : ('k,'e,'i,'c) t -> Branch.t -> 'k branch_info val reset_branch : ('k,'e,'i,'c) t -> Branch.t -> id -> ('k,'e,'i,'c) t val branch : ('kind,'e,'i,'c) t -> ?root:id -> ?pos:id -> Branch.t -> 'kind -> ('kind,'e,'i,'c) t val delete_branch : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t val merge : ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> ?into:Branch.t -> Branch.t -> ('k,'diff,'i,'c) t val commit : ('k,'diff,'i,'c) t -> id -> 'diff -> ('k,'diff,'i,'c) t val rewrite_merge : ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> at:id -> Branch.t -> ('k,'diff,'i,'c) t val checkout : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t val set_info : ('k,'e,'info,'c) t -> id -> 'info -> ('k,'e,'info,'c) t val get_info : ('k,'e,'info,'c) t -> id -> 'info option (* Read only dag *) module Dag : Dag.S with type node = id val dag : ('kind,'diff,'info,'cdata) t -> ('diff,'info,'cdata) Dag.t val create_property : ('k,'e,'i,'c) t -> id list -> 'c -> ('k,'e,'i,'c) t val property_of : ('k,'e,'i,'c) t -> id -> 'c Dag.Property.t list val delete_property : ('k,'e,'i,'c) t -> 'c Dag.Property.t -> ('k,'e,'i,'c) t (* Removes all unreachable nodes and returns them *) val gc : ('k,'e,'info,'c) t -> ('k,'e,'info,'c) t * Dag.NodeSet.t val reachable : ('k,'e,'info,'c) t -> id -> Dag.NodeSet.t end module Make(OT : Map.OrderedType) = struct module Dag = Dag.Make(OT) type id = OT.t module NodeSet = Dag.NodeSet module Branch = struct type t = string let make = let bid = ref 0 in fun s -> incr bid; string_of_int !bid ^ "_" ^ s let equal = CString.equal let compare = CString.compare let to_string s = s let master = "master" end module BranchMap = Map.Make(Branch) type 'kind branch_info = { kind : [> `Master] as 'kind; root : id; pos : id; } type ('kind,'edge,'info,'property_data) t = { cur_branch : Branch.t; heads : 'kind branch_info BranchMap.t; dag : ('edge,'info,'property_data) Dag.t; } let empty root = { cur_branch = Branch.master; heads = BranchMap.singleton Branch.master { root = root; pos = root; kind = `Master }; dag = Dag.empty; } let add_node vcs id edges = assert (not (CList.is_empty edges)); { vcs with dag = List.fold_left (fun g (t,tgt) -> Dag.add_edge g id t tgt) vcs.dag edges } let get_branch vcs head = try BranchMap.find head vcs.heads with Not_found -> anomaly (str"head " ++ str head ++ str" not found") let reset_branch vcs head id = let map name h = if Branch.equal name head then { h with pos = id } else h in { vcs with heads = BranchMap.mapi map vcs.heads; } let current_branch vcs = vcs.cur_branch let branch vcs ?(root=(get_branch vcs vcs.cur_branch).pos) ?(pos=root) name kind = { vcs with heads = BranchMap.add name { kind; root; pos } vcs.heads; cur_branch = name } let delete_branch vcs name = if Branch.equal Branch.master name then vcs else let filter n _ = not (Branch.equal n name) in { vcs with heads = BranchMap.filter filter vcs.heads } let merge vcs id ~ours:tr1 ~theirs:tr2 ?(into = vcs.cur_branch) name = assert (not (Branch.equal name into)); let br_id = (get_branch vcs name).pos in let cur_id = (get_branch vcs into).pos in let vcs = add_node vcs id [tr1,cur_id; tr2,br_id] in let vcs = reset_branch vcs into id in vcs let del_edge id vcs tgt = { vcs with dag = Dag.del_edge vcs.dag id tgt } let rewrite_merge vcs id ~ours:tr1 ~theirs:tr2 ~at:cur_id name = let br_id = (get_branch vcs name).pos in let old_edges = List.map fst (Dag.from_node vcs.dag id) in let vcs = List.fold_left (del_edge id) vcs old_edges in let vcs = add_node vcs id [tr1,cur_id; tr2,br_id] in vcs let commit vcs id tr = let vcs = add_node vcs id [tr, (get_branch vcs vcs.cur_branch).pos] in let vcs = reset_branch vcs vcs.cur_branch id in vcs let checkout vcs name = { vcs with cur_branch = name } let set_info vcs id info = { vcs with dag = Dag.set_info vcs.dag id info } let get_info vcs id = Dag.get_info vcs.dag id let create_property vcs l i = { vcs with dag = Dag.create_property vcs.dag l i } let property_of vcs i = Dag.property_of vcs.dag i let delete_property vcs c = { vcs with dag = Dag.del_property vcs.dag c } let branches vcs = BranchMap.fold (fun x _ accu -> x :: accu) vcs.heads [] let dag vcs = vcs.dag let rec closure s d n = let l = try Dag.from_node d n with Not_found -> [] in List.fold_left (fun s (n',_) -> if Dag.NodeSet.mem n' s then s else closure s d n') (Dag.NodeSet.add n s) l let reachable vcs i = closure Dag.NodeSet.empty vcs.dag i let gc vcs = let alive = BranchMap.fold (fun b { pos } s -> closure s vcs.dag pos) vcs.heads Dag.NodeSet.empty in let dead = Dag.NodeSet.diff (Dag.all_nodes vcs.dag) alive in { vcs with dag = Dag.del_nodes vcs.dag dead }, dead end coq-8.6/stm/tacworkertop.ml0000644000175000017500000000144313022274260015016 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Flags.make_silent true; W.init_stdout (); CoqworkmgrApi.init !Flags.async_proofs_worker_priority; args) let () = Coqtop.toploop_run := W.main_loop coq-8.6/stm/stm.ml0000644000175000017500000033502013022274260013076 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* feedback ~id:(State state_id) Processed) () let state_ready, state_ready_hook = Hook.make ~default:(fun state_id -> ()) () let forward_feedback, forward_feedback_hook = let m = Mutex.create () in Hook.make ~default:(function | { id = id; route; contents } -> try Mutex.lock m; feedback ~id:id ~route contents; Mutex.unlock m with e -> Mutex.unlock m; raise e) () let parse_error, parse_error_hook = Hook.make ~default:(fun id loc msg -> feedback ~id (Message(Error, Some loc, pp_to_richpp msg))) () let execution_error, execution_error_hook = Hook.make ~default:(fun state_id loc msg -> feedback ~id:(State state_id) (Message(Error, Some loc, pp_to_richpp msg))) () let unreachable_state, unreachable_state_hook = Hook.make ~default:(fun _ _ -> ()) () let tactic_being_run, tactic_being_run_hook = Hook.make ~default:(fun _ -> ()) () include Hook (* enables: Hooks.(call foo args) *) let call = get let call_process_error_once = let processed : unit Exninfo.t = Exninfo.make () in fun (_, info as ei) -> match Exninfo.get info processed with | Some _ -> ei | None -> let e, info = call process_error ei in let info = Exninfo.add info processed () in e, info end (* During interactive use we cache more states so that Undoing is fast *) let interactive () = if !Flags.ide_slave || !Flags.print_emacs || not !Flags.batch_mode then `Yes else `No let async_proofs_workers_extra_env = ref [||] type aast = { verbose : bool; loc : Loc.t; indentation : int; strlen : int; mutable expr : vernac_expr; (* mutable: Proof using hinted by aux file *) } let pr_ast { expr; indentation } = int indentation ++ str " " ++ pr_vernac expr let default_proof_mode () = Proof_global.get_default_proof_mode_name () (* Commands piercing opaque *) let may_pierce_opaque = function | { expr = VernacPrint _ } -> true | { expr = VernacExtend (("Extraction",_), _) } -> true | { expr = VernacExtend (("SeparateExtraction",_), _) } -> true | { expr = VernacExtend (("ExtractionLibrary",_), _) } -> true | { expr = VernacExtend (("RecursiveExtractionLibrary",_), _) } -> true | { expr = VernacExtend (("ExtractionConstant",_), _) } -> true | { expr = VernacExtend (("ExtractionInlinedConstant",_), _) } -> true | { expr = VernacExtend (("ExtractionInductive",_), _) } -> true | _ -> false (* Wrapper for Vernacentries.interp to set the feedback id *) let vernac_interp ?proof id ?route { verbose; loc; expr } = let rec internal_command = function | VernacResetName _ | VernacResetInitial | VernacBack _ | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> internal_command e | _ -> false in if internal_command expr then begin prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr)) end else begin set_id_for_feedback ?route (State id); Aux_file.record_in_aux_set_at loc; prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr)); try Hooks.(call interp ?verbosely:(Some verbose) ?proof (loc, expr)) with e -> let e = CErrors.push e in iraise Hooks.(call_process_error_once e) end (* Wrapper for Vernac.parse_sentence to set the feedback id *) let indentation_of_string s = let len = String.length s in let rec aux n i precise = if i >= len then 0, precise, len else match s.[i] with | ' ' | '\t' -> aux (succ n) (succ i) precise | '\n' | '\r' -> aux 0 (succ i) true | _ -> n, precise, len in aux 0 0 false let vernac_parse ?(indlen_prev=fun() -> 0) ?newtip ?route eid s = let feedback_id = if Option.is_empty newtip then Edit eid else State (Option.get newtip) in let indentation, precise, strlen = indentation_of_string s in let indentation = if precise then indentation else indlen_prev () + indentation in set_id_for_feedback ?route feedback_id; let pa = Pcoq.Gram.parsable (Stream.of_string s) in Flags.with_option Flags.we_are_parsing (fun () -> try match Pcoq.Gram.entry_parse Pcoq.main_entry pa with | None -> raise (Invalid_argument "vernac_parse") | Some (loc, ast) -> indentation, strlen, loc, ast with e when CErrors.noncritical e -> let (e, info) = CErrors.push e in let loc = Option.default Loc.ghost (Loc.get_loc info) in Hooks.(call parse_error feedback_id loc (iprint (e, info))); iraise (e, info)) () let pr_open_cur_subgoals () = try Printer.pr_open_subgoals () with Proof_global.NoCurrentProof -> Pp.str "" let update_global_env () = if Proof_global.there_are_pending_proofs () then Proof_global.update_global_env () module Vcs_ = Vcs.Make(Stateid.Self) type future_proof = Proof_global.closed_proof_output Future.computation type proof_mode = string type depth = int type cancel_switch = bool ref type branch_type = [ `Master | `Proof of proof_mode * depth | `Edit of proof_mode * Stateid.t * Stateid.t * vernac_qed_type * Vcs_.Branch.t ] (* TODO 8.7 : split commands and tactics, since this type is too messy now *) type cmd_t = { ctac : bool; (* is a tactic *) ceff : bool; (* is a side-effecting command in the middle of a proof *) cast : aast; cids : Id.t list; cblock : proof_block_name option; cqueue : [ `MainQueue | `TacQueue of solving_tac * anon_abstracting_tac * cancel_switch | `QueryQueue of cancel_switch | `SkipQueue ] } type fork_t = aast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Id.t list type qed_t = { qast : aast; keep : vernac_qed_type; mutable fproof : (future_proof * cancel_switch) option; brname : Vcs_.Branch.t; brinfo : branch_type Vcs_.branch_info } type seff_t = aast option type alias_t = Stateid.t * aast type transaction = | Cmd of cmd_t | Fork of fork_t | Qed of qed_t | Sideff of seff_t | Alias of alias_t | Noop type step = [ `Cmd of cmd_t | `Fork of fork_t * Stateid.t option | `Qed of qed_t * Stateid.t | `Sideff of [ `Ast of aast * Stateid.t | `Id of Stateid.t ] | `Alias of alias_t ] type visit = { step : step; next : Stateid.t } let mkTransTac cast cblock cqueue = Cmd { ctac = true; cast; cblock; cqueue; cids = []; ceff = false } let mkTransCmd cast cids ceff cqueue = Cmd { ctac = false; cast; cblock = None; cqueue; cids; ceff } (* Parts of the system state that are morally part of the proof state *) let summary_pstate = [ Evarutil.meta_counter_summary_name; Evd.evar_counter_summary_name; "program-tcc-table" ] type cached_state = | Empty | Error of Exninfo.iexn | Valid of state and state = { (* TODO: inline records in OCaml 4.03 *) system : States.state; (* summary + libstack *) proof : Proof_global.state; (* proof state *) shallow : bool (* is the state trimmed down (libstack) *) } type branch = Vcs_.Branch.t * branch_type Vcs_.branch_info type backup = { mine : branch; others : branch list } type 'vcs state_info = { (* TODO: Make this record private to VCS *) mutable n_reached : int; (* debug cache: how many times was computed *) mutable n_goals : int; (* open goals: indentation *) mutable state : cached_state; (* state value *) mutable vcs_backup : 'vcs option * backup option; } let default_info () = { n_reached = 0; n_goals = 0; state = Empty; vcs_backup = None,None } module DynBlockData : Dyn.S = Dyn.Make(struct end) (* Clusters of nodes implemented as Dag properties. While Dag and Vcs impose * no constraint on properties, here we impose boxes to be non overlapping. * Such invariant makes sense for the current kinds of boxes (proof blocks and * entire proofs) but may make no sense and dropped/refined in the future. * Such invariant is useful to detect broken proof block detection code *) type box = | ProofTask of pt | ProofBlock of static_block_declaration * proof_block_name and pt = { (* TODO: inline records in OCaml 4.03 *) lemma : Stateid.t; qed : Stateid.t; } and static_block_declaration = { block_start : Stateid.t; block_stop : Stateid.t; dynamic_switch : Stateid.t; carry_on_data : DynBlockData.t; } (* Functions that work on a Vcs with a specific branch type *) module Vcs_aux : sig val proof_nesting : (branch_type, 't,'i,'c) Vcs_.t -> int val find_proof_at_depth : (branch_type, 't, 'i,'c) Vcs_.t -> int -> Vcs_.Branch.t * branch_type Vcs_.branch_info exception Expired val visit : (branch_type, transaction,'i,'c) Vcs_.t -> Vcs_.Dag.node -> visit end = struct (* {{{ *) let proof_nesting vcs = List.fold_left max 0 (List.map_filter (function | { Vcs_.kind = `Proof (_,n) } -> Some n | { Vcs_.kind = `Edit _ } -> Some 1 | _ -> None) (List.map (Vcs_.get_branch vcs) (Vcs_.branches vcs))) let find_proof_at_depth vcs pl = try List.find (function | _, { Vcs_.kind = `Proof(m, n) } -> Int.equal n pl | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.str "find_proof_at_depth") | _ -> false) (List.map (fun h -> h, Vcs_.get_branch vcs h) (Vcs_.branches vcs)) with Not_found -> failwith "find_proof_at_depth" exception Expired let visit vcs id = if Stateid.equal id Stateid.initial then anomaly(Pp.str "Visiting the initial state id") else if Stateid.equal id Stateid.dummy then anomaly(Pp.str "Visiting the dummy state id") else try match Vcs_.Dag.from_node (Vcs_.dag vcs) id with | [n, Cmd x] -> { step = `Cmd x; next = n } | [n, Alias x] -> { step = `Alias x; next = n } | [n, Fork x] -> { step = `Fork (x,None); next = n } | [n, Fork x; p, Noop] -> { step = `Fork (x,Some p); next = n } | [p, Noop; n, Fork x] -> { step = `Fork (x,Some p); next = n } | [n, Qed x; p, Noop] | [p, Noop; n, Qed x] -> { step = `Qed (x,p); next = n } | [n, Sideff None; p, Noop] | [p, Noop; n, Sideff None]-> { step = `Sideff (`Id p); next = n } | [n, Sideff (Some x); p, Noop] | [p, Noop; n, Sideff (Some x)]-> { step = `Sideff(`Ast (x,p)); next = n } | [n, Sideff (Some x)]-> {step = `Sideff(`Ast (x,Stateid.dummy)); next=n} | _ -> anomaly (Pp.str ("Malformed VCS at node "^Stateid.to_string id)) with Not_found -> raise Expired end (* }}} *) (*************************** THE DOCUMENT *************************************) (******************************************************************************) (* Imperative wrap around VCS to obtain _the_ VCS that is the * representation of the document Coq is currently processing *) module VCS : sig exception Expired module Branch : (module type of Vcs_.Branch with type t = Vcs_.Branch.t) type id = Stateid.t type 'branch_type branch_info = 'branch_type Vcs_.branch_info = { kind : [> `Master] as 'branch_type; root : id; pos : id; } type vcs = (branch_type, transaction, vcs state_info, box) Vcs_.t val init : id -> unit val current_branch : unit -> Branch.t val checkout : Branch.t -> unit val branches : unit -> Branch.t list val get_branch : Branch.t -> branch_type branch_info val get_branch_pos : Branch.t -> id val new_node : ?id:Stateid.t -> unit -> id val merge : id -> ours:transaction -> ?into:Branch.t -> Branch.t -> unit val rewrite_merge : id -> ours:transaction -> at:id -> Branch.t -> unit val delete_branch : Branch.t -> unit val commit : id -> transaction -> unit val mk_branch_name : aast -> Branch.t val edit_branch : Branch.t val branch : ?root:id -> ?pos:id -> Branch.t -> branch_type -> unit val reset_branch : Branch.t -> id -> unit val reachable : id -> Stateid.Set.t val cur_tip : unit -> id val get_info : id -> vcs state_info val reached : id -> unit val goals : id -> int -> unit val set_state : id -> cached_state -> unit val get_state : id -> cached_state (* cuts from start -> stop, raising Expired if some nodes are not there *) val slice : block_start:id -> block_stop:id -> vcs val nodes_in_slice : block_start:id -> block_stop:id -> Stateid.t list val create_proof_task_box : id list -> qed:id -> block_start:id -> unit val create_proof_block : static_block_declaration -> string -> unit val box_of : id -> box list val delete_boxes_of : id -> unit val proof_task_box_of : id -> pt option val proof_nesting : unit -> int val checkout_shallowest_proof_branch : unit -> unit val propagate_sideff : replay:aast option -> unit val gc : unit -> unit val visit : id -> visit val print : ?now:bool -> unit -> unit val backup : unit -> vcs val restore : vcs -> unit end = struct (* {{{ *) include Vcs_ exception Expired = Vcs_aux.Expired open Printf let print_dag vcs () = let fname = "stm_" ^ Str.global_replace (Str.regexp " ") "_" (System.process_id ()) in let string_of_transaction = function | Cmd { cast = t } | Fork (t, _,_,_) -> (try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR") | Sideff (Some t) -> sprintf "Sideff(%s)" (try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR") | Sideff None -> "EnvChange" | Noop -> " " | Alias (id,_) -> sprintf "Alias(%s)" (Stateid.to_string id) | Qed { qast } -> string_of_ppcmds (pr_ast qast) in let is_green id = match get_info vcs id with | Some { state = Valid _ } -> true | _ -> false in let is_red id = match get_info vcs id with | Some { state = Error _ } -> true | _ -> false in let head = current_branch vcs in let heads = List.map (fun x -> x, (get_branch vcs x).pos) (branches vcs) in let graph = dag vcs in let quote s = Str.global_replace (Str.regexp "\n") "
" (Str.global_replace (Str.regexp "<") "<" (Str.global_replace (Str.regexp ">") ">" (Str.global_replace (Str.regexp "\"") """ (Str.global_replace (Str.regexp "&") "&" (String.sub s 0 (min (String.length s) 20)))))) in let fname_dot, fname_ps = let f = "/tmp/" ^ Filename.basename fname in f ^ ".dot", f ^ ".pdf" in let node id = "s" ^ Stateid.to_string id in let edge tr = sprintf "<%s>" (quote (string_of_transaction tr)) in let node_info id = match get_info vcs id with | None -> "" | Some info -> sprintf "<%s" (Stateid.to_string id) ^ sprintf " r:%d g:%d>" info.n_reached info.n_goals in let color id = if is_red id then "red" else if is_green id then "green" else "white" in let nodefmt oc id = fprintf oc "%s [label=%s,style=filled,fillcolor=%s];\n" (node id) (node_info id) (color id) in let ids = ref Stateid.Set.empty in let boxes = ref [] in (* Fill in *) Dag.iter graph (fun from _ _ l -> ids := Stateid.Set.add from !ids; List.iter (fun box -> boxes := box :: !boxes) (Dag.property_of graph from); List.iter (fun (dest, _) -> ids := Stateid.Set.add dest !ids; List.iter (fun box -> boxes := box :: !boxes) (Dag.property_of graph dest)) l); boxes := CList.sort_uniquize Dag.Property.compare !boxes; let oc = open_out fname_dot in output_string oc "digraph states {\n"; Dag.iter graph (fun from cf _ l -> List.iter (fun (dest, trans) -> fprintf oc "%s -> %s [xlabel=%s,labelfloat=true];\n" (node from) (node dest) (edge trans)) l ); let contains b1 b2 = Stateid.Set.subset (Dag.Property.having_it b2) (Dag.Property.having_it b1) in let same_box = Dag.Property.equal in let outerboxes boxes = List.filter (fun b -> not (List.exists (fun b1 -> not (same_box b1 b) && contains b1 b) boxes) ) boxes in let rec rec_print b = boxes := CList.remove same_box b !boxes; let sub_boxes = List.filter (contains b) (outerboxes !boxes) in fprintf oc "subgraph cluster_%s {\n" (Dag.Property.to_string b); List.iter rec_print sub_boxes; Stateid.Set.iter (fun id -> if Stateid.Set.mem id !ids then begin ids := Stateid.Set.remove id !ids; nodefmt oc id end) (Dag.Property.having_it b); match Dag.Property.data b with | ProofBlock ({ dynamic_switch = id }, lbl) -> fprintf oc "label=\"%s (test:%s)\";\n" lbl (Stateid.to_string id); fprintf oc "color=red; }\n" | ProofTask _ -> fprintf oc "color=blue; }\n" in List.iter rec_print (outerboxes !boxes); Stateid.Set.iter (nodefmt oc) !ids; List.iteri (fun i (b,id) -> let shape = if Branch.equal head b then "box3d" else "box" in fprintf oc "b%d -> %s;\n" i (node id); fprintf oc "b%d [shape=%s,label=\"%s\"];\n" i shape (Branch.to_string b); ) heads; output_string oc "}\n"; close_out oc; ignore(Sys.command ("dot -Tpdf -Gcharset=latin1 " ^ fname_dot ^ " -o" ^ fname_ps)) type vcs = (branch_type, transaction, vcs state_info, box) t let vcs : vcs ref = ref (empty Stateid.dummy) let init id = vcs := empty id; vcs := set_info !vcs id (default_info ()) let current_branch () = current_branch !vcs let checkout head = vcs := checkout !vcs head let branches () = branches !vcs let get_branch head = get_branch !vcs head let get_branch_pos head = (get_branch head).pos let new_node ?(id=Stateid.fresh ()) () = assert(Vcs_.get_info !vcs id = None); vcs := set_info !vcs id (default_info ()); id let merge id ~ours ?into branch = vcs := merge !vcs id ~ours ~theirs:Noop ?into branch let delete_branch branch = vcs := delete_branch !vcs branch let reset_branch branch id = vcs := reset_branch !vcs branch id let commit id t = vcs := commit !vcs id t let rewrite_merge id ~ours ~at branch = vcs := rewrite_merge !vcs id ~ours ~theirs:Noop ~at branch let reachable id = reachable !vcs id let mk_branch_name { expr = x } = Branch.make (match x with | VernacDefinition (_,((_,i),_),_) -> string_of_id i | VernacStartTheoremProof (_,[Some ((_,i),_),_],_) -> string_of_id i | _ -> "branch") let edit_branch = Branch.make "edit" let branch ?root ?pos name kind = vcs := branch !vcs ?root ?pos name kind let get_info id = match get_info !vcs id with | Some x -> x | None -> raise Vcs_aux.Expired let set_state id s = (get_info id).state <- s; if Flags.async_proofs_is_master () then Hooks.(call state_ready id) let get_state id = (get_info id).state let reached id = let info = get_info id in info.n_reached <- info.n_reached + 1 let goals id n = (get_info id).n_goals <- n let cur_tip () = get_branch_pos (current_branch ()) let proof_nesting () = Vcs_aux.proof_nesting !vcs let checkout_shallowest_proof_branch () = if List.mem edit_branch (Vcs_.branches !vcs) then begin checkout edit_branch; match get_branch edit_branch with | { kind = `Edit (mode, _,_,_,_) } -> Proof_global.activate_proof_mode mode | _ -> assert false end else let pl = proof_nesting () in try let branch, mode = match Vcs_aux.find_proof_at_depth !vcs pl with | h, { Vcs_.kind = `Proof (m, _) } -> h, m | _ -> assert false in checkout branch; prerr_endline (fun () -> "mode:" ^ mode); Proof_global.activate_proof_mode mode with Failure _ -> checkout Branch.master; Proof_global.disactivate_current_proof_mode () (* copies the transaction on every open branch *) let propagate_sideff ~replay:t = List.iter (fun b -> checkout b; let id = new_node () in merge id ~ours:(Sideff t) ~into:b Branch.master) (List.filter (fun b -> not (Branch.equal b Branch.master)) (branches ())) let visit id = Vcs_aux.visit !vcs id let nodes_in_slice ~block_start ~block_stop = let rec aux id = if Stateid.equal id block_start then [] else match visit id with | { next = n; step = `Cmd x } -> (id,Cmd x) :: aux n | { next = n; step = `Alias x } -> (id,Alias x) :: aux n | { next = n; step = `Sideff (`Ast (x,_)) } -> (id,Sideff (Some x)) :: aux n | _ -> anomaly(str("Cannot slice from "^ Stateid.to_string block_start ^ " to "^Stateid.to_string block_stop)) in aux block_stop let slice ~block_start ~block_stop = let l = nodes_in_slice ~block_start ~block_stop in let copy_info v id = Vcs_.set_info v id { (get_info id) with state = Empty; vcs_backup = None,None } in let copy_info_w_state v id = Vcs_.set_info v id { (get_info id) with vcs_backup = None,None } in let copy_proof_blockes v = let nodes = Vcs_.Dag.all_nodes (Vcs_.dag v) in let props = Stateid.Set.fold (fun n pl -> Vcs_.property_of !vcs n @ pl) nodes [] in let props = CList.sort_uniquize Vcs_.Dag.Property.compare props in List.fold_left (fun v p -> Vcs_.create_property v (Stateid.Set.elements (Vcs_.Dag.Property.having_it p)) (Vcs_.Dag.Property.data p)) v props in let v = Vcs_.empty block_start in let v = copy_info v block_start in let v = List.fold_right (fun (id,tr) v -> let v = Vcs_.commit v id tr in let v = copy_info v id in v) l v in (* Stm should have reached the beginning of proof *) assert (match (get_info block_start).state with Valid _ -> true | _ -> false); (* We put in the new dag the most recent state known to master *) let rec fill id = match (get_info id).state with | Empty | Error _ -> fill (Vcs_aux.visit v id).next | Valid _ -> copy_info_w_state v id in let v = fill block_stop in (* We put in the new dag the first state (since Qed shall run on it, * see check_task_aux) *) let v = copy_info_w_state v block_start in copy_proof_blockes v let nodes_in_slice ~block_start ~block_stop = List.rev (List.map fst (nodes_in_slice ~block_start ~block_stop)) let topo_invariant l = let all = List.fold_right Stateid.Set.add l Stateid.Set.empty in List.for_all (fun x -> let props = property_of !vcs x in let sets = List.map Dag.Property.having_it props in List.for_all (fun s -> Stateid.Set.(subset s all || subset all s)) sets) l let create_proof_task_box l ~qed ~block_start:lemma = if not (topo_invariant l) then anomaly (str "overlapping boxes"); vcs := create_property !vcs l (ProofTask { qed; lemma }) let create_proof_block ({ block_start; block_stop} as decl) name = let l = nodes_in_slice ~block_start ~block_stop in if not (topo_invariant l) then anomaly (str "overlapping boxes"); vcs := create_property !vcs l (ProofBlock (decl, name)) let box_of id = List.map Dag.Property.data (property_of !vcs id) let delete_boxes_of id = List.iter (fun x -> vcs := delete_property !vcs x) (property_of !vcs id) let proof_task_box_of id = match CList.map_filter (function ProofTask x -> Some x | _ -> None) (box_of id) with | [] -> None | [x] -> Some x | _ -> anomaly (str "node with more than 1 proof task box") let gc () = let old_vcs = !vcs in let new_vcs, erased_nodes = gc old_vcs in Stateid.Set.iter (fun id -> match (Vcs_aux.visit old_vcs id).step with | `Qed ({ fproof = Some (_, cancel_switch) }, _) | `Cmd { cqueue = `TacQueue (_,_,cancel_switch) } | `Cmd { cqueue = `QueryQueue cancel_switch } -> cancel_switch := true | _ -> ()) erased_nodes; vcs := new_vcs module NB : sig (* Non blocking Sys.command *) val command : now:bool -> (unit -> unit) -> unit end = struct let m = Mutex.create () let c = Condition.create () let job = ref None let worker = ref None let set_last_job j = Mutex.lock m; job := Some j; Condition.signal c; Mutex.unlock m let get_last_job () = Mutex.lock m; while Option.is_empty !job do Condition.wait c m; done; match !job with | None -> assert false | Some x -> job := None; Mutex.unlock m; x let run_command () = try while true do get_last_job () () done with e -> () (* No failure *) let command ~now job = if now then job () else begin set_last_job job; if Option.is_empty !worker then worker := Some (Thread.create run_command ()) end end let print ?(now=false) () = if not !Flags.debug && not now then () else NB.command ~now (print_dag !vcs) let backup () = !vcs let restore v = vcs := v end (* }}} *) let state_of_id id = try match (VCS.get_info id).state with | Valid s -> `Valid (Some s) | Error (e,_) -> `Error e | Empty -> `Valid None with VCS.Expired -> `Expired (****** A cache: fills in the nodes of the VCS document with their value ******) module State : sig (** The function is from unit, so it uses the current state to define a new one. I.e. one may been to install the right state before defining a new one. Warning: an optimization in installed_cached requires that state modifying functions are always executed using this wrapper. *) val define : ?safe_id:Stateid.t -> ?redefine:bool -> ?cache:Summary.marshallable -> ?feedback_processed:bool -> (unit -> unit) -> Stateid.t -> unit val fix_exn_ref : (iexn -> iexn) ref val install_cached : Stateid.t -> unit val is_cached : ?cache:Summary.marshallable -> Stateid.t -> bool val is_cached_and_valid : ?cache:Summary.marshallable -> Stateid.t -> bool val exn_on : Stateid.t -> valid:Stateid.t -> iexn -> iexn (* to send states across worker/master *) type frozen_state val get_cached : Stateid.t -> frozen_state val same_env : frozen_state -> frozen_state -> bool type proof_part type partial_state = [ `Full of frozen_state | `Proof of Stateid.t * proof_part ] val proof_part_of_frozen : frozen_state -> proof_part val assign : Stateid.t -> partial_state -> unit end = struct (* {{{ *) (* cur_id holds Stateid.dummy in case the last attempt to define a state * failed, so the global state may contain garbage *) let cur_id = ref Stateid.dummy let fix_exn_ref = ref (fun x -> x) (* helpers *) let freeze_global_state marshallable = { system = States.freeze ~marshallable; proof = Proof_global.freeze ~marshallable; shallow = (marshallable = `Shallow) } let unfreeze_global_state { system; proof } = States.unfreeze system; Proof_global.unfreeze proof (* hack to make futures functional *) let () = Future.set_freeze (fun () -> Obj.magic (freeze_global_state `No, !cur_id)) (fun t -> let s,i = Obj.magic t in unfreeze_global_state s; cur_id := i) type frozen_state = state type proof_part = Proof_global.state * Summary.frozen_bits (* only meta counters *) type partial_state = [ `Full of frozen_state | `Proof of Stateid.t * proof_part ] let proof_part_of_frozen { proof; system } = proof, Summary.project_summary (States.summary_of_state system) summary_pstate let freeze marshallable id = VCS.set_state id (Valid (freeze_global_state marshallable)) let freeze_invalid id iexn = VCS.set_state id (Error iexn) let is_cached ?(cache=`No) id only_valid = if Stateid.equal id !cur_id then try match VCS.get_info id with | { state = Empty } when cache = `Yes -> freeze `No id; true | { state = Empty } when cache = `Shallow -> freeze `Shallow id; true | _ -> true with VCS.Expired -> false else try match VCS.get_info id with | { state = Empty } -> false | { state = Valid _ } -> true | { state = Error _ } -> not only_valid with VCS.Expired -> false let is_cached_and_valid ?cache id = is_cached ?cache id true let is_cached ?cache id = is_cached ?cache id false let install_cached id = match VCS.get_info id with | { state = Valid s } -> if Stateid.equal id !cur_id then () (* optimization *) else begin unfreeze_global_state s; cur_id := id end | { state = Error ie } -> cur_id := id; Exninfo.iraise ie | _ -> (* coqc has a 1 slot cache and only for valid states *) if interactive () = `No && Stateid.equal id !cur_id then () else anomaly (str "installing a non cached state") let get_cached id = try match VCS.get_info id with | { state = Valid s } -> s | _ -> anomaly (str "not a cached state") with VCS.Expired -> anomaly (str "not a cached state (expired)") let assign id what = if VCS.get_state id <> Empty then () else try match what with | `Full s -> let s = try let prev = (VCS.visit id).next in if is_cached_and_valid prev then { s with proof = Proof_global.copy_terminators ~src:(get_cached prev).proof ~tgt:s.proof } else s with VCS.Expired -> s in VCS.set_state id (Valid s) | `Proof(ontop,(pstate,counters)) -> if is_cached_and_valid ontop then let s = get_cached ontop in let s = { s with proof = Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in let s = { s with system = States.replace_summary s.system (Summary.surgery_summary (States.summary_of_state s.system) counters) } in VCS.set_state id (Valid s) with VCS.Expired -> () let exn_on id ~valid (e, info) = match Stateid.get info with | Some _ -> (e, info) | None -> let loc = Option.default Loc.ghost (Loc.get_loc info) in let (e, info) = Hooks.(call_process_error_once (e, info)) in Hooks.(call execution_error id loc (iprint (e, info))); (e, Stateid.add info ~valid id) let same_env { system = s1 } { system = s2 } = let s1 = States.summary_of_state s1 in let e1 = Summary.project_summary s1 [Global.global_env_summary_name] in let s2 = States.summary_of_state s2 in let e2 = Summary.project_summary s2 [Global.global_env_summary_name] in Summary.pointer_equal e1 e2 let define ?safe_id ?(redefine=false) ?(cache=`No) ?(feedback_processed=true) f id = feedback ~id:(State id) (ProcessingIn !Flags.async_proofs_worker_id); let str_id = Stateid.to_string id in if is_cached id && not redefine then anomaly (str"defining state "++str str_id++str" twice"); try prerr_endline (fun () -> "defining "^str_id^" (cache="^ if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)"); let good_id = match safe_id with None -> !cur_id | Some id -> id in fix_exn_ref := exn_on id ~valid:good_id; f (); fix_exn_ref := (fun x -> x); if cache = `Yes then freeze `No id else if cache = `Shallow then freeze `Shallow id; prerr_endline (fun () -> "setting cur id to "^str_id); cur_id := id; if feedback_processed then Hooks.(call state_computed id ~in_cache:false); VCS.reached id; if Proof_global.there_are_pending_proofs () then VCS.goals id (Proof_global.get_open_goals ()) with e -> let (e, info) = CErrors.push e in let good_id = !cur_id in cur_id := Stateid.dummy; VCS.reached id; let ie = match Stateid.get info, safe_id with | None, None -> (exn_on id ~valid:good_id (e, info)) | None, Some good_id -> (exn_on id ~valid:good_id (e, info)) | Some _, None -> (e, info) | Some (_,at), Some id -> (e, Stateid.add info ~valid:id at) in if cache = `Yes || cache = `Shallow then freeze_invalid id ie; Hooks.(call unreachable_state id ie); Exninfo.iraise ie end (* }}} *) (****************************** CRUFT *****************************************) (******************************************************************************) (* The backtrack module simulates the classic behavior of a linear document *) module Backtrack : sig val record : unit -> unit val backto : Stateid.t -> unit val back_safe : unit -> unit (* we could navigate the dag, but this ways easy *) val branches_of : Stateid.t -> backup (* To be installed during initialization *) val undo_vernac_classifier : vernac_expr -> vernac_classification end = struct (* {{{ *) let record () = List.iter (fun current_branch -> let mine = current_branch, VCS.get_branch current_branch in let info = VCS.get_info (VCS.get_branch_pos current_branch) in let others = CList.map_filter (fun b -> if Vcs_.Branch.equal b current_branch then None else Some(b, VCS.get_branch b)) (VCS.branches ()) in let backup = if fst info.vcs_backup <> None then fst info.vcs_backup else Some (VCS.backup ()) in let branches = if snd info.vcs_backup <> None then snd info.vcs_backup else Some { mine; others } in info.vcs_backup <- backup, branches) [VCS.current_branch (); VCS.Branch.master] let backto oid = let info = VCS.get_info oid in match info.vcs_backup with | None, _ -> anomaly(str"Backtrack.backto "++str(Stateid.to_string oid)++ str": a state with no vcs_backup") | Some vcs, _ -> VCS.restore vcs let branches_of id = let info = VCS.get_info id in match info.vcs_backup with | _, None -> anomaly(str"Backtrack.branches_of "++str(Stateid.to_string id)++ str": a state with no vcs_backup") | _, Some x -> x let rec fold_until f acc id = let next acc = if id = Stateid.initial then raise Not_found else fold_until f acc (VCS.visit id).next in let info = VCS.get_info id in match info.vcs_backup with | None, _ -> next acc | Some vcs, _ -> let ids, tactic, undo = if id = Stateid.initial || id = Stateid.dummy then [],false,0 else match VCS.visit id with | { step = `Fork ((_,_,_,l),_) } -> l, false,0 | { step = `Cmd { cids = l; ctac } } -> l, ctac,0 | { step = `Alias (_,{ expr = VernacUndo n}) } -> [], false, n | _ -> [],false,0 in match f acc (id, vcs, ids, tactic, undo) with | `Stop x -> x | `Cont acc -> next acc let back_safe () = let id = fold_until (fun n (id,_,_,_,_) -> if n >= 0 && State.is_cached_and_valid id then `Stop id else `Cont (succ n)) 0 (VCS.get_branch_pos (VCS.current_branch ())) in backto id let undo_vernac_classifier v = try match v with | VernacResetInitial -> VtStm (VtBack Stateid.initial, true), VtNow | VernacResetName (_,name) -> let id = VCS.get_branch_pos (VCS.current_branch ()) in (try let oid = fold_until (fun b (id,_,label,_,_) -> if b then `Stop id else `Cont (List.mem name label)) false id in VtStm (VtBack oid, true), VtNow with Not_found -> VtStm (VtBack id, true), VtNow) | VernacBack n -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) n id in VtStm (VtBack oid, true), VtNow | VernacUndo n -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun n (id,_,_,tactic,undo) -> let value = (if tactic then 1 else 0) - undo in if Int.equal n 0 then `Stop id else `Cont (n-value)) n id in VtStm (VtBack oid, true), VtLater | VernacUndoTo _ | VernacRestart as e -> let m = match e with VernacUndoTo m -> m | _ -> 0 in let id = VCS.get_branch_pos (VCS.current_branch ()) in let vcs = match (VCS.get_info id).vcs_backup with | None, _ -> anomaly(str"Backtrack: tip with no vcs_backup") | Some vcs, _ -> vcs in let cb, _ = try Vcs_aux.find_proof_at_depth vcs (Vcs_aux.proof_nesting vcs) with Failure _ -> raise Proof_global.NoCurrentProof in let n = fold_until (fun n (_,vcs,_,_,_) -> if List.mem cb (Vcs_.branches vcs) then `Cont (n+1) else `Stop n) 0 id in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) (n-m-1) id in VtStm (VtBack oid, true), VtLater | VernacAbortAll -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun () (id,vcs,_,_,_) -> match Vcs_.branches vcs with [_] -> `Stop id | _ -> `Cont ()) () id in VtStm (VtBack oid, true), VtLater | VernacBacktrack (id,_,_) | VernacBackTo id -> VtStm (VtBack (Stateid.of_int id), not !Flags.print_emacs), VtNow | _ -> VtUnknown, VtNow with | Not_found -> CErrors.errorlabstrm "undo_vernac_classifier" (str "Cannot undo") end (* }}} *) let hints = ref Aux_file.empty_aux_file let set_compilation_hints file = hints := Aux_file.load_aux_file_for file let get_hint_ctx loc = let s = Aux_file.get !hints loc "context_used" in match Str.split (Str.regexp ";") s with | ids :: _ -> let ids = List.map Names.Id.of_string (Str.split (Str.regexp " ") ids) in let ids = List.map (fun id -> Loc.ghost, id) ids in begin match ids with | [] -> SsEmpty | x :: xs -> List.fold_left (fun a x -> SsUnion (SsSingl x,a)) (SsSingl x) xs end | _ -> raise Not_found let get_hint_bp_time proof_name = try float_of_string (Aux_file.get !hints Loc.ghost proof_name) with Not_found -> 1.0 let record_pb_time proof_name loc time = let proof_build_time = Printf.sprintf "%.3f" time in Aux_file.record_in_aux_at loc "proof_build_time" proof_build_time; if proof_name <> "" then begin Aux_file.record_in_aux_at Loc.ghost proof_name proof_build_time; hints := Aux_file.set !hints Loc.ghost proof_name proof_build_time end exception RemoteException of std_ppcmds let _ = CErrors.register_handler (function | RemoteException ppcmd -> ppcmd | _ -> raise Unhandled) (****************** proof structure for error recovery ************************) (******************************************************************************) type document_node = { indentation : int; ast : Vernacexpr.vernac_expr; id : Stateid.t; } type document_view = { entry_point : document_node; prev_node : document_node -> document_node option; } type static_block_detection = document_view -> static_block_declaration option type recovery_action = { base_state : Stateid.t; goals_to_admit : Goal.goal list; recovery_command : Vernacexpr.vernac_expr option; } type dynamic_block_error_recovery = static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ] let proof_block_delimiters = ref [] let register_proof_block_delimiter name static dynamic = if List.mem_assoc name !proof_block_delimiters then CErrors.errorlabstrm "STM" (str "Duplicate block delimiter " ++ str name); proof_block_delimiters := (name, (static,dynamic)) :: !proof_block_delimiters let mk_doc_node id = function | { step = `Cmd { ctac; cast = { indentation; expr }}; next } when ctac -> Some { indentation; ast = expr; id } | { step = `Sideff (`Ast ({ indentation; expr }, _)); next } -> Some { indentation; ast = expr; id } | _ -> None let prev_node { id } = let id = (VCS.visit id).next in mk_doc_node id (VCS.visit id) let cur_node id = mk_doc_node id (VCS.visit id) let is_block_name_enabled name = match !Flags.async_proofs_tac_error_resilience with | `None -> false | `All -> true | `Only l -> List.mem name l let detect_proof_block id name = let name = match name with None -> "indent" | Some x -> x in if is_block_name_enabled name && (Flags.async_proofs_is_master () || Flags.async_proofs_is_worker ()) then ( match cur_node id with | None -> () | Some entry_point -> try let static, _ = List.assoc name !proof_block_delimiters in begin match static { prev_node; entry_point } with | None -> () | Some ({ block_start; block_stop } as decl) -> VCS.create_proof_block decl name end with Not_found -> CErrors.errorlabstrm "STM" (str "Unknown proof block delimiter " ++ str name) ) (****************************** THE SCHEDULER *********************************) (******************************************************************************) module rec ProofTask : sig type competence = Stateid.t list type task_build_proof = { t_exn_info : Stateid.t * Stateid.t; t_start : Stateid.t; t_stop : Stateid.t; t_drop : bool; t_states : competence; t_assign : Proof_global.closed_proof_output Future.assignement -> unit; t_loc : Loc.t; t_uuid : Future.UUID.t; t_name : string } type task = | BuildProof of task_build_proof | States of Stateid.t list type request = | ReqBuildProof of (Future.UUID.t,VCS.vcs) Stateid.request * bool * competence | ReqStates of Stateid.t list include AsyncTaskQueue.Task with type task := task and type competence := competence and type request := request val build_proof_here : drop_pt:bool -> Stateid.t * Stateid.t -> Loc.t -> Stateid.t -> Proof_global.closed_proof_output Future.computation (* If set, only tasks overlapping with this list are processed *) val set_perspective : Stateid.t list -> unit end = struct (* {{{ *) let forward_feedback msg = Hooks.(call forward_feedback msg) type competence = Stateid.t list type task_build_proof = { t_exn_info : Stateid.t * Stateid.t; t_start : Stateid.t; t_stop : Stateid.t; t_drop : bool; t_states : competence; t_assign : Proof_global.closed_proof_output Future.assignement -> unit; t_loc : Loc.t; t_uuid : Future.UUID.t; t_name : string } type task = | BuildProof of task_build_proof | States of Stateid.t list type request = | ReqBuildProof of (Future.UUID.t,VCS.vcs) Stateid.request * bool * competence | ReqStates of Stateid.t list type error = { e_error_at : Stateid.t; e_safe_id : Stateid.t; e_msg : std_ppcmds; e_safe_states : Stateid.t list } type response = | RespBuiltProof of Proof_global.closed_proof_output * float | RespError of error | RespStates of (Stateid.t * State.partial_state) list | RespDone let name = ref "proofworker" let extra_env () = !async_proofs_workers_extra_env let perspective = ref [] let set_perspective l = perspective := l let task_match age t = match age, t with | `Fresh, BuildProof { t_states } -> not !Flags.async_proofs_full || List.exists (fun x -> CList.mem_f Stateid.equal x !perspective) t_states | `Old my_states, States l -> List.for_all (fun x -> CList.mem_f Stateid.equal x my_states) l | _ -> false let name_of_task = function | BuildProof t -> "proof: " ^ t.t_name | States l -> "states: " ^ String.concat "," (List.map Stateid.to_string l) let name_of_request = function | ReqBuildProof(r,_,_) -> "proof: " ^ r.Stateid.name | ReqStates l -> "states: "^String.concat "," (List.map Stateid.to_string l) let request_of_task age = function | States l -> Some (ReqStates l) | BuildProof { t_exn_info;t_start;t_stop;t_loc;t_uuid;t_name;t_states;t_drop } -> assert(age = `Fresh); try Some (ReqBuildProof ({ Stateid.exn_info = t_exn_info; stop = t_stop; document = VCS.slice ~block_start:t_start ~block_stop:t_stop; loc = t_loc; uuid = t_uuid; name = t_name }, t_drop, t_states)) with VCS.Expired -> None let use_response (s : competence AsyncTaskQueue.worker_status) t r = match s, t, r with | `Old c, States _, RespStates l -> List.iter (fun (id,s) -> State.assign id s) l; `End | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states; t_drop }, RespBuiltProof (pl, time) -> feedback (InProgress ~-1); t_assign (`Val pl); record_pb_time t_name t_loc time; if !Flags.async_proofs_full || t_drop then `Stay(t_states,[States t_states]) else `End | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states }, RespError { e_error_at; e_safe_id = valid; e_msg; e_safe_states } -> feedback (InProgress ~-1); let info = Stateid.add ~valid Exninfo.null e_error_at in let e = (RemoteException e_msg, info) in t_assign (`Exn e); `Stay(t_states,[States e_safe_states]) | _ -> assert false let on_task_cancellation_or_expiration_or_slave_death = function | None -> () | Some (States _) -> () | Some (BuildProof { t_start = start; t_assign }) -> let s = "Worker dies or task expired" in let info = Stateid.add ~valid:start Exninfo.null start in let e = (RemoteException (strbrk s), info) in t_assign (`Exn e); Hooks.(call execution_error start Loc.ghost (strbrk s)); feedback (InProgress ~-1) let build_proof_here ~drop_pt (id,valid) loc eop = Future.create (State.exn_on id ~valid) (fun () -> let wall_clock1 = Unix.gettimeofday () in if !Flags.batch_mode then Reach.known_state ~cache:`No eop else Reach.known_state ~cache:`Shallow eop; let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); let p = Proof_global.return_proof ~allow_partial:drop_pt () in if drop_pt then feedback ~id:(State id) Complete; p) let perform_buildp { Stateid.exn_info; stop; document; loc } drop my_states = try VCS.restore document; VCS.print (); let proof, future_proof, time = let wall_clock = Unix.gettimeofday () in let fp = build_proof_here ~drop_pt:drop exn_info loc stop in let proof = Future.force fp in proof, fp, Unix.gettimeofday () -. wall_clock in (* We typecheck the proof with the kernel (in the worker) to spot * the few errors tactics don't catch, like the "fix" tactic building * a bad fixpoint *) let fix_exn = Future.fix_exn_of future_proof in if not drop then begin let checked_proof = Future.chain ~pure:false future_proof (fun p -> let pobject, _ = Proof_global.close_future_proof stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in vernac_interp stop ~proof:(pobject, terminator) { verbose = false; loc; indentation = 0; strlen = 0; expr = (VernacEndProof (Proved (Opaque None,None))) }) in ignore(Future.join checked_proof); end; RespBuiltProof(proof,time) with | e when CErrors.noncritical e || e = Stack_overflow -> let (e, info) = CErrors.push e in (* This can happen if the proof is broken. The error has also been * signalled as a feedback, hence we can silently recover *) let e_error_at, e_safe_id = match Stateid.get info with | Some (safe, err) -> err, safe | None -> Stateid.dummy, Stateid.dummy in let e_msg = iprint (e, info) in prerr_endline (fun () -> "failed with the following exception:"); prerr_endline (fun () -> string_of_ppcmds e_msg); let e_safe_states = List.filter State.is_cached_and_valid my_states in RespError { e_error_at; e_safe_id; e_msg; e_safe_states } let perform_states query = if query = [] then [] else let is_tac e = match classify_vernac e with | VtProofStep _, _ -> true | _ -> false in let initial = let rec aux id = try match VCS.visit id with { next } -> aux next with VCS.Expired -> id in aux (List.hd query) in let get_state seen id = let prev = try let { next = prev; step } = VCS.visit id in if State.is_cached_and_valid prev && List.mem prev seen then Some (prev, State.get_cached prev, step) else None with VCS.Expired -> None in let this = if State.is_cached_and_valid id then Some (State.get_cached id) else None in match prev, this with | _, None -> None | Some (prev, o, `Cmd { cast = { expr }}), Some n when is_tac expr && State.same_env o n -> (* A pure tactic *) Some (id, `Proof (prev, State.proof_part_of_frozen n)) | Some _, Some s -> msg_debug (str "STM: sending back a fat state"); Some (id, `Full s) | _, Some s -> Some (id, `Full s) in let rec aux seen = function | [] -> [] | id :: rest -> match get_state seen id with | None -> aux seen rest | Some stuff -> stuff :: aux (id :: seen) rest in aux [initial] query let perform = function | ReqBuildProof (bp,drop,states) -> perform_buildp bp drop states | ReqStates sl -> RespStates (perform_states sl) let on_marshal_error s = function | States _ -> msg_error(strbrk("Marshalling error: "^s^". "^ "The system state could not be sent to the master process.")) | BuildProof { t_exn_info; t_stop; t_assign; t_loc; t_drop = drop_pt } -> msg_error(strbrk("Marshalling error: "^s^". "^ "The system state could not be sent to the worker process. "^ "Falling back to local, lazy, evaluation.")); t_assign(`Comp(build_proof_here ~drop_pt t_exn_info t_loc t_stop)); feedback (InProgress ~-1) end (* }}} *) (* Slave processes (if initialized, otherwise local lazy evaluation) *) and Slaves : sig (* (eventually) remote calls *) val build_proof : loc:Loc.t -> drop_pt:bool -> exn_info:(Stateid.t * Stateid.t) -> block_start:Stateid.t -> block_stop:Stateid.t -> name:string -> future_proof * cancel_switch (* blocking function that waits for the task queue to be empty *) val wait_all_done : unit -> unit (* initialize the whole machinery (optional) *) val init : unit -> unit type 'a tasks = (('a,VCS.vcs) Stateid.request * bool) list val dump_snapshot : unit -> Future.UUID.t tasks val check_task : string -> int tasks -> int -> bool val info_tasks : 'a tasks -> (string * float * int) list val finish_task : string -> Library.seg_univ -> Library.seg_discharge -> Library.seg_proofs -> int tasks -> int -> Library.seg_univ val cancel_worker : WorkerPool.worker_id -> unit val reset_task_queue : unit -> unit val set_perspective : Stateid.t list -> unit end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(ProofTask) let queue = ref None let init () = if Flags.async_proofs_is_master () then queue := Some (TaskQueue.create !Flags.async_proofs_n_workers) else queue := Some (TaskQueue.create 0) let check_task_aux extra name l i = let { Stateid.stop; document; loc; name = r_name }, drop = List.nth l i in Flags.if_verbose msg_info (str(Printf.sprintf "Checking task %d (%s%s) of %s" i r_name extra name)); VCS.restore document; let start = let rec aux cur = try aux (VCS.visit cur).next with VCS.Expired -> cur in aux stop in try Reach.known_state ~cache:`No stop; if drop then let _proof = Proof_global.return_proof ~allow_partial:true () in `OK_ADMITTED else begin (* The original terminator, a hook, has not been saved in the .vio*) Proof_global.set_terminator (Lemmas.standard_proof_terminator [] (Lemmas.mk_hook (fun _ _ -> ()))); let proof = Proof_global.close_proof ~keep_body_ucst_separate:true (fun x -> x) in (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) Reach.known_state ~cache:`No start; vernac_interp stop ~proof { verbose = false; loc; indentation = 0; strlen = 0; expr = (VernacEndProof (Proved (Opaque None,None))) }; `OK proof end with e -> let (e, info) = CErrors.push e in (try match Stateid.get info with | None -> msg_error ( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ spc () ++ iprint (e, info)) | Some (_, cur) -> match VCS.visit cur with | { step = `Cmd { cast = { loc } } } | { step = `Fork (( { loc }, _, _, _), _) } | { step = `Qed ( { qast = { loc } }, _) } | { step = `Sideff (`Ast ( { loc }, _)) } -> let start, stop = Loc.unloc loc in msg_error ( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ str ": chars " ++ int start ++ str "-" ++ int stop ++ spc () ++ iprint (e, info)) | _ -> msg_error ( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ spc () ++ iprint (e, info)) with e -> msg_error (str"unable to print error message: " ++ str (Printexc.to_string e))); if drop then `ERROR_ADMITTED else `ERROR let finish_task name (u,cst,_) d p l i = let { Stateid.uuid = bucket }, drop = List.nth l i in let bucket_name = if bucket < 0 then (assert drop; ", no bucket") else Printf.sprintf ", bucket %d" bucket in match check_task_aux bucket_name name l i with | `ERROR -> exit 1 | `ERROR_ADMITTED -> u, cst, false | `OK_ADMITTED -> u, cst, false | `OK (po,_) -> let discharge c = List.fold_right Cooking.cook_constr d.(bucket) c in let con = Nametab.locate_constant (Libnames.qualid_of_ident po.Proof_global.id) in let c = Global.lookup_constant con in let o = match c.Declarations.const_body with | Declarations.OpaqueDef o -> o | _ -> assert false in let uc = Option.get (Opaqueproof.get_constraints (Global.opaque_tables ()) o) in let pr = Future.from_val (Option.get (Global.body_of_constant_body c)) in let uc = Future.chain ~greedy:true ~pure:true uc Univ.hcons_universe_context_set in let pr = Future.chain ~greedy:true ~pure:true pr discharge in let pr = Future.chain ~greedy:true ~pure:true pr Constr.hcons in Future.sink pr; let extra = Future.join uc in u.(bucket) <- uc; p.(bucket) <- pr; u, Univ.ContextSet.union cst extra, false let check_task name l i = match check_task_aux "" name l i with | `OK _ | `OK_ADMITTED -> true | `ERROR | `ERROR_ADMITTED -> false let info_tasks l = CList.map_i (fun i ({ Stateid.loc; name }, _) -> let time1 = try float_of_string (Aux_file.get !hints loc "proof_build_time") with Not_found -> 0.0 in let time2 = try float_of_string (Aux_file.get !hints loc "proof_check_time") with Not_found -> 0.0 in name, max (time1 +. time2) 0.0001,i) 0 l let set_perspective idl = ProofTask.set_perspective idl; TaskQueue.broadcast (Option.get !queue); let open ProofTask in let overlap s1 s2 = List.exists (fun x -> CList.mem_f Stateid.equal x s2) s1 in let overlap_rel s1 s2 = match overlap s1 idl, overlap s2 idl with | true, true | false, false -> 0 | true, false -> -1 | false, true -> 1 in TaskQueue.set_order (Option.get !queue) (fun task1 task2 -> match task1, task2 with | BuildProof { t_states = s1 }, BuildProof { t_states = s2 } -> overlap_rel s1 s2 | _ -> 0) let build_proof ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name:pname = let id, valid as t_exn_info = exn_info in let cancel_switch = ref false in if TaskQueue.n_workers (Option.get !queue) = 0 then if !Flags.compilation_mode = Flags.BuildVio then begin let f,assign = Future.create_delegate ~blocking:true ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in let task = ProofTask.(BuildProof { t_exn_info; t_start = block_start; t_stop = block_stop; t_drop = drop_pt; t_assign = assign; t_loc = loc; t_uuid; t_name = pname; t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch); f, cancel_switch end else ProofTask.build_proof_here ~drop_pt t_exn_info loc block_stop, cancel_switch else let f, t_assign = Future.create_delegate ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in feedback (InProgress 1); let task = ProofTask.(BuildProof { t_exn_info; t_start = block_start; t_stop = block_stop; t_assign; t_drop = drop_pt; t_loc = loc; t_uuid; t_name = pname; t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch); f, cancel_switch let wait_all_done () = TaskQueue.join (Option.get !queue) let cancel_worker n = TaskQueue.cancel_worker (Option.get !queue) n (* For external users this name is nicer than request *) type 'a tasks = (('a,VCS.vcs) Stateid.request * bool) list let dump_snapshot () = let tasks = TaskQueue.snapshot (Option.get !queue) in let reqs = CList.map_filter ProofTask.(fun x -> match request_of_task `Fresh x with | Some (ReqBuildProof (r, b, _)) -> Some(r, b) | _ -> None) tasks in prerr_endline (fun () -> Printf.sprintf "dumping %d tasks\n" (List.length reqs)); reqs let reset_task_queue () = TaskQueue.clear (Option.get !queue) end (* }}} *) and TacTask : sig type output = Constr.constr * Evd.evar_universe_context type task = { t_state : Stateid.t; t_state_fb : Stateid.t; t_assign : output Future.assignement -> unit; t_ast : int * aast; t_goal : Goal.goal; t_kill : unit -> unit; t_name : string } exception NoProgress include AsyncTaskQueue.Task with type task := task end = struct (* {{{ *) type output = Constr.constr * Evd.evar_universe_context let forward_feedback msg = Hooks.(call forward_feedback msg) type task = { t_state : Stateid.t; t_state_fb : Stateid.t; t_assign : output Future.assignement -> unit; t_ast : int * aast; t_goal : Goal.goal; t_kill : unit -> unit; t_name : string } type request = { r_state : Stateid.t; r_state_fb : Stateid.t; r_document : VCS.vcs option; r_ast : int * aast; r_goal : Goal.goal; r_name : string } type response = | RespBuiltSubProof of output | RespError of std_ppcmds | RespNoProgress exception NoProgress let name = ref "tacworker" let extra_env () = [||] type competence = unit let task_match _ _ = true (* run by the master, on a thread *) let request_of_task age { t_state; t_state_fb; t_ast; t_goal; t_name } = try Some { r_state = t_state; r_state_fb = t_state_fb; r_document = if age <> `Fresh then None else Some (VCS.slice ~block_start:t_state ~block_stop:t_state); r_ast = t_ast; r_goal = t_goal; r_name = t_name } with VCS.Expired -> None let use_response _ { t_assign; t_state; t_state_fb; t_kill } resp = match resp with | RespBuiltSubProof o -> t_assign (`Val o); `Stay ((),[]) | RespNoProgress -> let e = (NoProgress, Exninfo.null) in t_assign (`Exn e); t_kill (); `Stay ((),[]) | RespError msg -> let e = (RemoteException msg, Exninfo.null) in t_assign (`Exn e); t_kill (); `Stay ((),[]) let on_marshal_error err { t_name } = pr_err ("Fatal marshal error: " ^ t_name ); flush_all (); exit 1 let on_task_cancellation_or_expiration_or_slave_death = function | Some { t_kill } -> t_kill () | _ -> () let command_focus = Proof.new_focus_kind () let focus_cond = Proof.no_cond command_focus let perform { r_state = id; r_state_fb; r_document = vcs; r_ast; r_goal } = Option.iter VCS.restore vcs; try Reach.known_state ~cache:`No id; 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 (Context.Named.Declaration.for_all (Evarutil.is_ground_term sigma0)) Evd.(evar_context g)) then CErrors.errorlabstrm "STM" (strbrk("the par: goal selector supports ground "^ "goals only")) else begin let (i, ast) = r_ast in Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); vernac_interp r_state_fb ast; let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> RespNoProgress | Evd.Evar_defined t -> let t = Evarutil.nf_evar sigma t in if Evarutil.is_ground_term sigma t then RespBuiltSubProof (t, Evd.evar_universe_context sigma) else CErrors.errorlabstrm "STM" (str"The solution is not ground") end) () with e when CErrors.noncritical e -> RespError (CErrors.print e) let name_of_task { t_name } = t_name let name_of_request { r_name } = r_name end (* }}} *) and Partac : sig val vernac_interp : solve:bool -> abstract:bool -> cancel_switch -> int -> Stateid.t -> Stateid.t -> aast -> unit end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) let vernac_interp ~solve ~abstract cancel nworkers safe_id id { indentation; verbose; loc; expr = e; strlen } = let e, time, fail = let rec find time fail = function | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> find true fail e | VernacFail e -> find time true e | _ -> e, time, fail in find false false e in Hooks.call Hooks.with_fail fail (fun () -> (if time then System.with_time false else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> Proof_global.with_current_proof (fun _ p -> let goals, _, _, _, _ = Proof.proof p in let open TacTask in let res = CList.map_i (fun i g -> let f, assign = Future.create_delegate ~name:(Printf.sprintf "subgoal %d" i) (State.exn_on id ~valid:safe_id) in let t_ast = (i, { indentation; verbose; loc; expr = e; strlen }) in let t_name = Goal.uid g in TaskQueue.enqueue_task queue ({ t_state = safe_id; t_state_fb = id; t_assign = assign; t_ast; t_goal = g; t_name; t_kill = (fun () -> if solve then TaskQueue.cancel_all queue) }, cancel); g,f) 1 goals in TaskQueue.join queue; let assign_tac : unit Proofview.tactic = Proofview.(Goal.nf_enter { Goal.enter = fun g -> let gid = Goal.goal g in let f = try List.assoc gid res with Not_found -> CErrors.anomaly(str"Partac: wrong focus") in if not (Future.is_over f) then (* One has failed and cancelled the others, but not this one *) if solve then Tacticals.New.tclZEROMSG (str"Interrupted by the failure of another goal") else tclUNIT () else let open Notations in try let pt, uc = Future.join f in prerr_endline (fun () -> string_of_ppcmds(hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ str"t=" ++ (Printer.pr_constr pt) ++ spc () ++ str"uc=" ++ Evd.pr_evar_universe_context uc))); (if abstract then Tactics.tclABSTRACT None else (fun x -> x)) (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*> Tactics.exact_no_check pt) with TacTask.NoProgress -> if solve then Tacticals.New.tclSOLVE [] else tclUNIT () }) in Proof.run_tactic (Global.env()) assign_tac p)))) ()) end (* }}} *) and QueryTask : sig type task = { t_where : Stateid.t; t_for : Stateid.t ; t_what : aast } include AsyncTaskQueue.Task with type task := task end = struct (* {{{ *) type task = { t_where : Stateid.t; t_for : Stateid.t ; t_what : aast } type request = { r_where : Stateid.t ; r_for : Stateid.t ; r_what : aast; r_doc : VCS.vcs } type response = unit let name = ref "queryworker" let extra_env _ = [||] type competence = unit let task_match _ _ = true let request_of_task _ { t_where; t_what; t_for } = try Some { r_where = t_where; r_for = t_for; r_doc = VCS.slice ~block_start:t_where ~block_stop:t_where; r_what = t_what } with VCS.Expired -> None let use_response _ _ _ = `End let on_marshal_error _ _ = pr_err ("Fatal marshal error in query"); flush_all (); exit 1 let on_task_cancellation_or_expiration_or_slave_death _ = () let forward_feedback msg = Hooks.(call forward_feedback msg) let perform { r_where; r_doc; r_what; r_for } = VCS.restore r_doc; VCS.print (); Reach.known_state ~cache:`No r_where; try vernac_interp r_for { r_what with verbose = true }; feedback ~id:(State r_for) Processed with e when CErrors.noncritical e -> let e = CErrors.push e in let msg = pp_to_richpp (iprint e) in feedback ~id:(State r_for) (Message (Error, None, msg)) let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what) let name_of_request { r_what } = string_of_ppcmds (pr_ast r_what) end (* }}} *) and Query : sig val init : unit -> unit val vernac_interp : cancel_switch -> Stateid.t -> Stateid.t -> aast -> unit end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(QueryTask) let queue = ref None let vernac_interp switch prev id q = assert(TaskQueue.n_workers (Option.get !queue) > 0); TaskQueue.enqueue_task (Option.get !queue) QueryTask.({ t_where = prev; t_for = id; t_what = q }, switch) let init () = queue := Some (TaskQueue.create (if !Flags.async_proofs_full then 1 else 0)) end (* }}} *) (* Runs all transactions needed to reach a state *) and Reach : sig val known_state : ?redefine_qed:bool -> cache:Summary.marshallable -> Stateid.t -> unit end = struct (* {{{ *) let pstate = summary_pstate let async_policy () = let open Flags in if is_universe_polymorphism () then false else if interactive () = `Yes then (async_proofs_is_master () || !async_proofs_mode = APonLazy) else (!compilation_mode = BuildVio || !async_proofs_mode <> APoff) let delegate name = get_hint_bp_time name >= !Flags.async_proofs_delegation_threshold || !Flags.compilation_mode = Flags.BuildVio || !Flags.async_proofs_full let warn_deprecated_nested_proofs = CWarnings.create ~name:"deprecated-nested-proofs" ~category:"deprecated" (fun () -> strbrk ("Nested proofs are deprecated and will "^ "stop working in a future Coq version")) let collect_proof keep cur hd brkind id = prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id); let no_name = "" in let name = function | [] -> no_name | id :: _ -> Id.to_string id in let loc = (snd cur).loc in let is_defined = function | _, { expr = VernacEndProof (Proved ((Transparent|Opaque (Some _)),_)) } -> true | _ -> false in let proof_using_ast = function | Some (_, ({ expr = VernacProof(_,Some _) } as v)) -> Some v | _ -> None in let has_proof_using x = proof_using_ast x <> None in let proof_no_using = function | Some (_, ({ expr = VernacProof(t,None) } as v)) -> t,v | _ -> assert false in let has_proof_no_using = function | Some (_, { expr = VernacProof(_,None) }) -> true | _ -> false in let too_complex_to_delegate = function | { expr = (VernacDeclareModule _ | VernacDefineModule _ | VernacDeclareModuleType _ | VernacInclude _) } -> true | { expr = (VernacRequire _ | VernacImport _) } -> true | ast -> may_pierce_opaque ast in let parent = function Some (p, _) -> p | None -> assert false in let is_empty = function `Async(_,_,[],_,_) | `MaybeASync(_,_,[],_,_) -> true | _ -> false in let rec collect last accn id = let view = VCS.visit id in match view.step with | (`Sideff (`Ast(x,_)) | `Cmd { cast = x }) when too_complex_to_delegate x -> `Sync(no_name,None,`Print) | `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next | `Sideff (`Ast(x,_)) -> collect (Some (id,x)) (id::accn) view.next (* An Alias could jump everywhere... we hope we can ignore it*) | `Alias _ -> `Sync (no_name,None,`Alias) | `Fork((_,_,_,_::_::_), _) -> `Sync (no_name,proof_using_ast last,`MutualProofs) | `Fork((_,_,Doesn'tGuaranteeOpacity,_), _) -> `Sync (no_name,proof_using_ast last,`Doesn'tGuaranteeOpacity) | `Fork((_,hd',GuaranteesOpacity,ids), _) when has_proof_using last -> assert (VCS.Branch.equal hd hd' || VCS.Branch.equal hd VCS.edit_branch); let name = name ids in `ASync (parent last,proof_using_ast last,accn,name,delegate name) | `Fork((_, hd', GuaranteesOpacity, ids), _) when has_proof_no_using last && not (State.is_cached_and_valid (parent last)) && !Flags.compilation_mode = Flags.BuildVio -> assert (VCS.Branch.equal hd hd'||VCS.Branch.equal hd VCS.edit_branch); (try let name, hint = name ids, get_hint_ctx loc in let t, v = proof_no_using last in v.expr <- VernacProof(t, Some hint); `ASync (parent last,proof_using_ast last,accn,name,delegate name) with Not_found -> let name = name ids in `MaybeASync (parent last, None, accn, name, delegate name)) | `Fork((_, hd', GuaranteesOpacity, ids), _) -> assert (VCS.Branch.equal hd hd' || VCS.Branch.equal hd VCS.edit_branch); let name = name ids in `MaybeASync (parent last, None, accn, name, delegate name) | `Sideff _ -> warn_deprecated_nested_proofs (); `Sync (no_name,None,`NestedProof) | _ -> `Sync (no_name,None,`Unknown) in let make_sync why = function | `Sync(name,pua,_) -> `Sync (name,pua,why) | `MaybeASync(_,pua,_,name,_) -> `Sync (name,pua,why) | `ASync(_,pua,_,name,_) -> `Sync (name,pua,why) in let check_policy rc = if async_policy () then rc else make_sync `Policy rc in match cur, (VCS.visit id).step, brkind with | (parent, { expr = VernacExactProof _ }), `Fork _, _ -> `Sync (no_name,None,`Immediate) | _, _, { VCS.kind = `Edit _ } -> check_policy (collect (Some cur) [] id) | _ -> if is_defined cur then `Sync (no_name,None,`Transparent) else if keep == VtDrop then `Sync (no_name,None,`Aborted) else let rc = collect (Some cur) [] id in if is_empty rc then make_sync `AlreadyEvaluated rc else if (keep == VtKeep || keep == VtKeepAsAxiom) && (not(State.is_cached_and_valid id) || !Flags.async_proofs_full) then check_policy rc else make_sync `AlreadyEvaluated rc let string_of_reason = function | `Transparent -> "non opaque" | `AlreadyEvaluated -> "proof already evaluated" | `Policy -> "policy" | `NestedProof -> "contains nested proof" | `Immediate -> "proof term given explicitly" | `Aborted -> "aborted proof" | `Doesn'tGuaranteeOpacity -> "not a simple opaque lemma" | `MutualProofs -> "block of mutually recursive proofs" | `Alias -> "contains Undo-like command" | `Print -> "contains Print-like command" | `NoPU_NoHint_NoES -> "no 'Proof using..', no .aux file, inside a section" | `Unknown -> "unsupported case" let log_string s = prerr_debug (fun () -> "STM: " ^ s) let log_processing_async id name = log_string Printf.(sprintf "%s: proof %s: asynch" (Stateid.to_string id) name ) let log_processing_sync id name reason = log_string Printf.(sprintf "%s: proof %s: synch (cause: %s)" (Stateid.to_string id) name (string_of_reason reason) ) let wall_clock_last_fork = ref 0.0 let known_state ?(redefine_qed=false) ~cache id = let error_absorbing_tactic id blockname exn = (* We keep the static/dynamic part of block detection separate, since the static part could be performed earlier. As of today there is no advantage in doing so since no UI can exploit such piece of info *) detect_proof_block id blockname; let boxes = VCS.box_of id in let valid_boxes = CList.map_filter (function | ProofBlock ({ block_stop } as decl, name) when Stateid.equal block_stop id -> Some (decl, name) | _ -> None) boxes in assert(List.length valid_boxes < 2); if valid_boxes = [] then iraise exn else let decl, name = List.hd valid_boxes in try let _, dynamic_check = List.assoc name !proof_block_delimiters in match dynamic_check decl with | `Leaks -> iraise exn | `ValidBlock { base_state; goals_to_admit; recovery_command } -> begin let tac = let open Proofview.Notations in Proofview.Goal.nf_enter { enter = fun gl -> if CList.mem_f Evar.equal (Proofview.Goal.goal gl) goals_to_admit then Proofview.give_up else Proofview.tclUNIT () } in match (VCS.get_info base_state).state with | Valid { proof } -> Proof_global.unfreeze proof; Proof_global.with_current_proof (fun _ p -> feedback ~id:(State id) Feedback.AddedAxiom; fst (Pfedit.solve Vernacexpr.SelectAll None tac p), ()); Option.iter (fun expr -> vernac_interp id { verbose = true; loc = Loc.ghost; expr; indentation = 0; strlen = 0 }) recovery_command | _ -> assert false end with Not_found -> CErrors.errorlabstrm "STM" (str "Unknown proof block delimiter " ++ str name) in (* Absorb tactic errors from f () *) let resilient_tactic id blockname f = if !Flags.async_proofs_tac_error_resilience = `None || (Flags.async_proofs_is_master () && !Flags.async_proofs_mode = Flags.APoff) then f () else try f () with e when CErrors.noncritical e -> let ie = CErrors.push e in error_absorbing_tactic id blockname ie in (* Absorb errors from f x *) let resilient_command f x = if not !Flags.async_proofs_cmd_error_resilience || (Flags.async_proofs_is_master () && !Flags.async_proofs_mode = Flags.APoff) then f x else try f x with e when CErrors.noncritical e -> () in (* ugly functions to process nested lemmas, i.e. hard to reproduce * side effects *) let cherry_pick_non_pstate () = Summary.freeze_summary ~marshallable:`No ~complement:true pstate, Lib.freeze ~marshallable:`No in let inject_non_pstate (s,l) = Summary.unfreeze_summary s; Lib.unfreeze l; update_global_env () in let rec pure_cherry_pick_non_pstate safe_id id = Future.purify (fun id -> prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id); reach ~safe_id id; cherry_pick_non_pstate ()) id (* traverses the dag backward from nodes being already calculated *) and reach ?safe_id ?(redefine_qed=false) ?(cache=cache) id = prerr_endline (fun () -> "reaching: " ^ Stateid.to_string id); if not redefine_qed && State.is_cached ~cache id then begin Hooks.(call state_computed id ~in_cache:true); prerr_endline (fun () -> "reached (cache)"); State.install_cached id end else let step, cache_step, feedback_processed = let view = VCS.visit id in match view.step with | `Alias (id,_) -> (fun () -> reach view.next; reach id ), cache, true | `Cmd { cast = x; cqueue = `SkipQueue } -> (fun () -> reach view.next), cache, true | `Cmd { cast = x; cqueue = `TacQueue (solve,abstract,cancel); cblock } -> (fun () -> resilient_tactic id cblock (fun () -> reach ~cache:`Shallow view.next; Hooks.(call tactic_being_run true); Partac.vernac_interp ~solve ~abstract 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; ctac = true; cblock } -> (fun () -> resilient_tactic id cblock (fun () -> reach view.next; Hooks.(call tactic_being_run true); vernac_interp id x; Hooks.(call tactic_being_run false)); if eff then update_global_env () ), (if eff then `Yes else cache), true | `Cmd { cast = x; ceff = eff } -> (fun () -> resilient_command reach view.next; vernac_interp id x; if eff then update_global_env () ), (if eff then `Yes else cache), true | `Fork ((x,_,_,_), None) -> (fun () -> resilient_command reach view.next; vernac_interp id x; wall_clock_last_fork := Unix.gettimeofday () ), `Yes, true | `Fork ((x,_,_,_), Some prev) -> (fun () -> (* nested proof *) reach ~cache:`Shallow prev; reach view.next; (try vernac_interp id x; with e when CErrors.noncritical e -> let (e, info) = CErrors.push e in let info = Stateid.add info ~valid:prev id in iraise (e, info)); wall_clock_last_fork := Unix.gettimeofday () ), `Yes, true | `Qed ({ qast = x; keep; brinfo; brname } as qed, eop) -> let rec aux = function | `ASync (block_start, pua, nodes, name, delegate) -> (fun () -> assert(keep == VtKeep || keep == VtKeepAsAxiom); let drop_pt = keep == VtKeepAsAxiom in let block_stop, exn_info, loc = eop, (id, eop), x.loc in log_processing_async id name; VCS.create_proof_task_box nodes ~qed:id ~block_start; begin match brinfo, qed.fproof with | { VCS.kind = `Edit _ }, None -> assert false | { VCS.kind = `Edit (_,_,_, okeep, _) }, Some (ofp, cancel) -> assert(redefine_qed = true); if okeep != keep then msg_error(strbrk("The command closing the proof changed. " ^"The kernel cannot take this into account and will " ^(if keep == VtKeep then "not check " else "reject ") ^"the "^(if keep == VtKeep then "new" else "incomplete") ^" proof. Reprocess the command declaring " ^"the proof's statement to avoid that.")); let fp, cancel = Slaves.build_proof ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name in Future.replace ofp fp; qed.fproof <- Some (fp, cancel); (* We don't generate a new state, but we still need * to install the right one *) State.install_cached id | { VCS.kind = `Proof _ }, Some _ -> assert false | { VCS.kind = `Proof _ }, None -> reach ~cache:`Shallow block_start; let fp, cancel = if delegate then Slaves.build_proof ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name else ProofTask.build_proof_here ~drop_pt exn_info loc block_stop, ref false in qed.fproof <- Some (fp, cancel); let proof = Proof_global.close_future_proof ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; vernac_interp id ~proof x; feedback ~id:(State id) Incomplete | { VCS.kind = `Master }, _ -> assert false end; Proof_global.discard_all () ), (if redefine_qed then `No else `Yes), true | `Sync (name, _, `Immediate) -> (fun () -> reach eop; vernac_interp id x; Proof_global.discard_all () ), `Yes, true | `Sync (name, pua, reason) -> (fun () -> log_processing_sync id name reason; reach eop; let wall_clock = Unix.gettimeofday () in record_pb_time name x.loc (wall_clock -. !wall_clock_last_fork); let proof = match keep with | VtDrop -> None | VtKeepAsAxiom -> let ctx = Evd.empty_evar_universe_context in let fp = Future.from_val ([],ctx) in qed.fproof <- Some (fp, ref false); None | VtKeep -> Some(Proof_global.close_proof ~keep_body_ucst_separate:false (State.exn_on id ~valid:eop)) in if keep != VtKeepAsAxiom then reach view.next; let wall_clock2 = Unix.gettimeofday () in vernac_interp id ?proof x; let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at x.loc "proof_check_time" (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); Proof_global.discard_all () ), `Yes, true | `MaybeASync (start, pua, nodes, name, delegate) -> (fun () -> reach ~cache:`Shallow start; (* no sections *) if List.is_empty (Environ.named_context (Global.env ())) then pi1 (aux (`ASync (start, pua, nodes, name, delegate))) () else pi1 (aux (`Sync (name, pua, `NoPU_NoHint_NoES))) () ), (if redefine_qed then `No else `Yes), true in aux (collect_proof keep (view.next, x) brname brinfo eop) | `Sideff (`Ast (x,_)) -> (fun () -> reach view.next; vernac_interp id x; update_global_env () ), cache, true | `Sideff (`Id origin) -> (fun () -> reach view.next; inject_non_pstate (pure_cherry_pick_non_pstate view.next origin); ), cache, true in let cache_step = if !Flags.async_proofs_cache = Some Flags.Force then `Yes else cache_step in State.define ?safe_id ~cache:cache_step ~redefine:redefine_qed ~feedback_processed step id; prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in reach ~redefine_qed id end (* }}} *) (********************************* STM API ************************************) (******************************************************************************) let init () = VCS.init Stateid.initial; set_undo_classifier Backtrack.undo_vernac_classifier; State.define ~cache:`Yes (fun () -> ()) Stateid.initial; Backtrack.record (); Slaves.init (); if Flags.async_proofs_is_master () then begin prerr_endline (fun () -> "Initializing workers"); Query.init (); let opts = match !Flags.async_proofs_private_flags with | None -> [] | Some s -> Str.split_delim (Str.regexp ",") s in begin try let env_opt = Str.regexp "^extra-env=" in let env = List.find (fun s -> Str.string_match env_opt s 0) opts in async_proofs_workers_extra_env := Array.of_list (Str.split_delim (Str.regexp ";") (Str.replace_first env_opt "" env)) with Not_found -> () end; end let observe id = let vcs = VCS.backup () in try Reach.known_state ~cache:(interactive ()) id; VCS.print () with e -> let e = CErrors.push e in VCS.print (); VCS.restore vcs; iraise e let finish ?(print_goals=false) () = let head = VCS.current_branch () in observe (VCS.get_branch_pos head); if print_goals then msg_notice (pr_open_cur_subgoals ()); VCS.print (); (* Some commands may by side effect change the proof mode *) match VCS.get_branch head with | { VCS.kind = `Edit (mode,_,_,_,_) } -> Proof_global.activate_proof_mode mode | { VCS.kind = `Proof (mode, _) } -> Proof_global.activate_proof_mode mode | _ -> () let wait () = Slaves.wait_all_done (); VCS.print () let rec join_admitted_proofs id = if Stateid.equal id Stateid.initial then () else let view = VCS.visit id in match view.step with | `Qed ({ keep = VtKeepAsAxiom; fproof = Some (fp,_) },_) -> ignore(Future.force fp); join_admitted_proofs view.next | _ -> join_admitted_proofs view.next let join () = finish (); wait (); prerr_endline (fun () -> "Joining the environment"); Global.join_safe_environment (); prerr_endline (fun () -> "Joining Admitted proofs"); join_admitted_proofs (VCS.get_branch_pos (VCS.current_branch ())); VCS.print (); VCS.print () let dump_snapshot () = Slaves.dump_snapshot (), RemoteCounter.snapshot () type document = VCS.vcs type tasks = int Slaves.tasks * RemoteCounter.remote_counters_status let check_task name (tasks,rcbackup) i = RemoteCounter.restore rcbackup; let vcs = VCS.backup () in try let rc = Future.purify (Slaves.check_task name tasks) i in VCS.restore vcs; rc with e when CErrors.noncritical e -> VCS.restore vcs; false let info_tasks (tasks,_) = Slaves.info_tasks tasks let finish_tasks name u d p (t,rcbackup as tasks) = RemoteCounter.restore rcbackup; let finish_task u (_,_,i) = let vcs = VCS.backup () in let u = Future.purify (Slaves.finish_task name u d p t) i in VCS.restore vcs; u in try let u, a, _ = List.fold_left finish_task u (info_tasks tasks) in (u,a,true), p with e -> let e = CErrors.push e in msg_error (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e); exit 1 let merge_proof_branch ~valid ?id qast keep brname = let brinfo = VCS.get_branch brname in let qed fproof = { qast; keep; brname; brinfo; fproof } in match brinfo with | { VCS.kind = `Proof _ } -> VCS.checkout VCS.Branch.master; let id = VCS.new_node ?id () in VCS.merge id ~ours:(Qed (qed None)) brname; VCS.delete_branch brname; VCS.propagate_sideff None; `Ok | { VCS.kind = `Edit (mode, qed_id, master_id, _,_) } -> let ofp = match VCS.visit qed_id with | { step = `Qed ({ fproof }, _) } -> fproof | _ -> assert false in VCS.rewrite_merge qed_id ~ours:(Qed (qed ofp)) ~at:master_id brname; VCS.delete_branch brname; VCS.gc (); Reach.known_state ~redefine_qed:true ~cache:`No qed_id; VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> iraise (State.exn_on ~valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null)) (* When tty is true, this code also does some of the job of the user interface: jump back to a state that is valid *) let handle_failure (e, info) vcs tty = if e = CErrors.Drop then iraise (e, info) else match Stateid.get info with | None -> VCS.restore vcs; VCS.print (); if tty && interactive () = `Yes then begin (* Hopefully the 1 to last state is valid *) Backtrack.back_safe (); VCS.checkout_shallowest_proof_branch (); end; VCS.print (); anomaly(str"error with no safe_id attached:" ++ spc() ++ CErrors.iprint_no_report (e, info)) | Some (safe_id, id) -> prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); VCS.restore vcs; if tty && interactive () = `Yes then begin (* We stay on a valid state *) Backtrack.backto safe_id; VCS.checkout_shallowest_proof_branch (); Reach.known_state ~cache:(interactive ()) safe_id; end; VCS.print (); iraise (e, info) let snapshot_vio ldir long_f_dot_vo = finish (); if List.length (VCS.branches ()) > 1 then CErrors.errorlabstrm "stm" (str"Cannot dump a vio with open proofs"); Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_vo (Global.opaque_tables ()) let reset_task_queue = Slaves.reset_task_queue (* Document building *) let process_transaction ?(newtip=Stateid.fresh ()) ~tty ({ verbose; loc; expr } as x) c = prerr_endline (fun () -> "{{{ processing: "^ string_of_ppcmds (pr_ast x)); let vcs = VCS.backup () in try let head = VCS.current_branch () in VCS.checkout head; let rc = begin prerr_endline (fun () -> " classified as: " ^ string_of_vernac_classification c); match c with (* PG stuff *) | VtStm(VtPG,false), VtNow -> vernac_interp Stateid.dummy x; `Ok | VtStm(VtPG,_), _ -> anomaly(str "PG command in script or VtLater") (* Joining various parts of the document *) | VtStm (VtJoinDocument, b), VtNow -> join (); `Ok | VtStm (VtFinish, b), VtNow -> finish (); `Ok | VtStm (VtWait, b), VtNow -> finish (); wait (); `Ok | VtStm (VtPrintDag, b), VtNow -> VCS.print ~now:true (); `Ok | VtStm (VtObserve id, b), VtNow -> observe id; `Ok | VtStm ((VtObserve _ | VtFinish | VtJoinDocument |VtPrintDag |VtWait),_), VtLater -> anomaly(str"classifier: join actions cannot be classified as VtLater") (* Back *) | VtStm (VtBack oid, true), w -> let id = VCS.new_node ~id:newtip () in let { mine; others } = Backtrack.branches_of oid in let valid = VCS.get_branch_pos head in List.iter (fun branch -> if not (List.mem_assoc branch (mine::others)) then ignore(merge_proof_branch ~valid x VtDrop branch)) (VCS.branches ()); VCS.checkout_shallowest_proof_branch (); let head = VCS.current_branch () in List.iter (fun b -> if not(VCS.Branch.equal b head) then begin VCS.checkout b; VCS.commit (VCS.new_node ()) (Alias (oid,x)); end) (VCS.branches ()); VCS.checkout_shallowest_proof_branch (); VCS.commit id (Alias (oid,x)); Backtrack.record (); if w == VtNow then finish (); `Ok | VtStm (VtBack id, false), VtNow -> prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id); Backtrack.backto id; VCS.checkout_shallowest_proof_branch (); Reach.known_state ~cache:(interactive ()) id; `Ok | VtStm (VtBack id, false), VtLater -> anomaly(str"classifier: VtBack + VtLater must imply part_of_script") (* Query *) | VtQuery (false,(report_id,route)), VtNow when tty = true -> finish (); (try Future.purify (vernac_interp report_id ~route) {x with verbose = true } with e when CErrors.noncritical e -> let e = CErrors.push e in iraise (State.exn_on ~valid:Stateid.dummy report_id e)); `Ok | VtQuery (false,(report_id,route)), VtNow -> (try vernac_interp report_id ~route x with e -> let e = CErrors.push e in iraise (State.exn_on ~valid:Stateid.dummy report_id e)); `Ok | VtQuery (true,(report_id,_)), w -> assert(Stateid.equal report_id Stateid.dummy); let id = VCS.new_node ~id:newtip () in let queue = if !Flags.async_proofs_full then `QueryQueue (ref false) else if Flags.(!compilation_mode = BuildVio) && VCS.((get_branch head).kind = `Master) && may_pierce_opaque x then `SkipQueue else `MainQueue in VCS.commit id (mkTransCmd x [] false queue); Backtrack.record (); if w == VtNow then finish (); `Ok | VtQuery (false,_), VtLater -> anomaly(str"classifier: VtQuery + VtLater must imply part_of_script") (* Proof *) | VtStartProof (mode, guarantee, names), w -> let id = VCS.new_node ~id:newtip () in let bname = VCS.mk_branch_name x in VCS.checkout VCS.Branch.master; if VCS.Branch.equal head VCS.Branch.master then begin VCS.commit id (Fork (x, bname, guarantee, names)); VCS.branch bname (`Proof (mode, VCS.proof_nesting () + 1)) end else begin VCS.branch bname (`Proof (mode, VCS.proof_nesting () + 1)); VCS.merge id ~ours:(Fork (x, bname, guarantee, names)) head end; Proof_global.activate_proof_mode mode; Backtrack.record (); if w == VtNow then finish (); `Ok | VtProofMode _, VtLater -> anomaly(str"VtProofMode must be executed VtNow") | VtProofMode mode, VtNow -> let id = VCS.new_node ~id:newtip () in VCS.commit id (mkTransCmd x [] false `MainQueue); List.iter (fun bn -> match VCS.get_branch bn with | { VCS.root; kind = `Master; pos } -> () | { VCS.root; kind = `Proof(_,d); pos } -> VCS.delete_branch bn; VCS.branch ~root ~pos bn (`Proof(mode,d)) | { VCS.root; kind = `Edit(_,f,q,k,ob); pos } -> VCS.delete_branch bn; VCS.branch ~root ~pos bn (`Edit(mode,f,q,k,ob))) (VCS.branches ()); VCS.checkout_shallowest_proof_branch (); Backtrack.record (); finish (); `Ok | VtProofStep { parallel; proof_block_detection = cblock }, w -> let id = VCS.new_node ~id:newtip () in let queue = match parallel with | `Yes(solve,abstract) -> `TacQueue (solve, abstract, ref false) | `No -> `MainQueue in VCS.commit id (mkTransTac x cblock queue); (* Static proof block detection delayed until an error really occurs. If/when and UI will make something useful with this piece of info, detection should occur here. detect_proof_block id cblock; *) Backtrack.record (); if w == VtNow then finish (); `Ok | VtQed keep, w -> let valid = VCS.get_branch_pos head in let rc = merge_proof_branch ~valid ~id:newtip x keep head in VCS.checkout_shallowest_proof_branch (); Backtrack.record (); if w == VtNow then finish (); rc (* Side effect on all branches *) | VtUnknown, _ when expr = VernacToplevelControl Drop -> vernac_interp (VCS.get_branch_pos head) x; `Ok | VtSideff l, w -> let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in let id = VCS.new_node ~id:newtip () in VCS.checkout VCS.Branch.master; VCS.commit id (mkTransCmd x l in_proof `MainQueue); (* We can't replay a Definition since universes may be differently * inferred. This holds in Coq >= 8.5 *) let replay = match x.expr with | VernacDefinition(_, _, DefineBody _) -> None | _ -> Some x in VCS.propagate_sideff ~replay; VCS.checkout_shallowest_proof_branch (); Backtrack.record (); if w == VtNow then finish (); `Ok (* Unknown: we execute it, check for open goals and propagate sideeff *) | VtUnknown, VtNow -> let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in let id = VCS.new_node ~id:newtip () in let head_id = VCS.get_branch_pos head in Reach.known_state ~cache:`Yes head_id; (* ensure it is ok *) let step () = VCS.checkout VCS.Branch.master; let mid = VCS.get_branch_pos VCS.Branch.master in Reach.known_state ~cache:(interactive ()) mid; vernac_interp id x; (* Vernac x may or may not start a proof *) if not in_proof && Proof_global.there_are_pending_proofs () then begin let bname = VCS.mk_branch_name x in let opacity_of_produced_term = match x.expr with (* This AST is ambiguous, hence we check it dynamically *) | VernacInstance (false, _,_ , None, _) -> GuaranteesOpacity | _ -> Doesn'tGuaranteeOpacity in VCS.commit id (Fork (x,bname,opacity_of_produced_term,[])); let proof_mode = default_proof_mode () in VCS.branch bname (`Proof (proof_mode, VCS.proof_nesting () + 1)); Proof_global.activate_proof_mode proof_mode; end else begin VCS.commit id (mkTransCmd x [] in_proof `MainQueue); (* We hope it can be replayed, but we can't really know *) VCS.propagate_sideff ~replay:(Some x); VCS.checkout_shallowest_proof_branch (); end in State.define ~safe_id:head_id ~cache:`Yes step id; Backtrack.record (); `Ok | VtUnknown, VtLater -> anomaly(str"classifier: VtUnknown must imply VtNow") end in (* Proof General *) begin match expr with | VernacStm (PGLast _) -> if not (VCS.Branch.equal head VCS.Branch.master) then vernac_interp Stateid.dummy { verbose = true; loc = Loc.ghost; indentation = 0; strlen = 0; expr = VernacShow (ShowGoal OpenSubgoals) } | _ -> () end; prerr_endline (fun () -> "processed }}}"); VCS.print (); rc with e -> let e = CErrors.push e in handle_failure e vcs tty let get_ast id = match VCS.visit id with | { step = `Cmd { cast = { loc; expr } } } | { step = `Fork (({ loc; expr }, _, _, _), _) } | { step = `Qed ({ qast = { loc; expr } }, _) } -> Some (expr, loc) | _ -> None let stop_worker n = Slaves.cancel_worker n (* You may need to know the len + indentation of previous command to compute * the indentation of the current one. * Eg. foo. bar. * Here bar is indented of the indentation of foo + its strlen (4) *) let ind_len_of id = if Stateid.equal id Stateid.initial then 0 else match (VCS.visit id).step with | `Cmd { ctac = true; cast = { indentation; strlen } } -> indentation + strlen | _ -> 0 let add ~ontop ?newtip ?(check=ignore) verb eid s = let cur_tip = VCS.cur_tip () in if not (Stateid.equal ontop cur_tip) then (* For now, arbitrary edits should be announced with edit_at *) anomaly(str"Not yet implemented, the GUI should not try this"); let indentation, strlen, loc, ast = vernac_parse ~indlen_prev:(fun () -> ind_len_of ontop) ?newtip eid s in CWarnings.set_current_loc loc; check(loc,ast); let clas = classify_vernac ast in let aast = { verbose = verb; indentation; strlen; loc; expr = ast } in match process_transaction ?newtip ~tty:false aast clas with | `Ok -> VCS.cur_tip (), `NewTip | `Unfocus qed_id -> qed_id, `Unfocus (VCS.cur_tip ()) let set_perspective id_list = Slaves.set_perspective id_list type focus = { start : Stateid.t; stop : Stateid.t; tip : Stateid.t } let query ~at ?(report_with=(Stateid.dummy,default_route)) s = Future.purify (fun s -> if Stateid.equal at Stateid.dummy then finish () else Reach.known_state ~cache:`Yes at; let newtip, route = report_with in let indentation, strlen, loc, ast = vernac_parse ~newtip ~route 0 s in CWarnings.set_current_loc loc; let clas = classify_vernac ast in let aast = { verbose = true; indentation; strlen; loc; expr = ast } in match clas with | VtStm (w,_), _ -> ignore(process_transaction ~tty:false aast (VtStm (w,false), VtNow)) | _ -> ignore(process_transaction ~tty:false aast (VtQuery (false,report_with), VtNow))) s let edit_at id = if Stateid.equal id Stateid.dummy then anomaly(str"edit_at dummy") else let vcs = VCS.backup () in let on_cur_branch id = let rec aux cur = if id = cur then true else match VCS.visit cur with | { step = `Fork _ } -> false | { next } -> aux next in aux (VCS.get_branch_pos (VCS.current_branch ())) in let rec is_pure_aux id = let view = VCS.visit id in match view.step with | `Cmd _ -> is_pure_aux view.next | `Fork _ -> true | _ -> false in let is_pure id = match (VCS.visit id).step with | `Qed (_,last_step) -> is_pure_aux last_step | _ -> assert false in let is_ancestor_of_cur_branch id = Stateid.Set.mem id (VCS.reachable (VCS.get_branch_pos (VCS.current_branch ()))) in let has_failed qed_id = match VCS.visit qed_id with | { step = `Qed ({ fproof = Some (fp,_) }, _) } -> Future.is_exn fp | _ -> false in let rec master_for_br root tip = if Stateid.equal tip Stateid.initial then tip else match VCS.visit tip with | { step = (`Fork _ | `Qed _) } -> tip | { step = `Sideff (`Ast(_,id)) } -> id | { step = `Sideff _ } -> tip | { next } -> master_for_br root next in let reopen_branch start at_id mode qed_id tip old_branch = let master_id, cancel_switch, keep = (* Hum, this should be the real start_id in the cluster and not next *) match VCS.visit qed_id with | { step = `Qed ({ fproof = Some (_,cs); keep },_) } -> start, cs, keep | _ -> anomaly (str "ProofTask not ending with Qed") in VCS.branch ~root:master_id ~pos:id VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch)); VCS.delete_boxes_of id; cancel_switch := true; Reach.known_state ~cache:(interactive ()) id; VCS.checkout_shallowest_proof_branch (); `Focus { stop = qed_id; start = master_id; tip } in let no_edit = function | `Edit (pm, _,_,_,_) -> `Proof(pm,1) | x -> x in let backto id bn = List.iter VCS.delete_branch (VCS.branches ()); let ancestors = VCS.reachable id in let { mine = brname, brinfo; others } = Backtrack.branches_of id in List.iter (fun (name,{ VCS.kind = k; root; pos }) -> if not(VCS.Branch.equal name VCS.Branch.master) && Stateid.Set.mem root ancestors then VCS.branch ~root ~pos name k) others; VCS.reset_branch VCS.Branch.master (master_for_br brinfo.VCS.root id); VCS.branch ~root:brinfo.VCS.root ~pos:brinfo.VCS.pos (Option.default brname bn) (no_edit brinfo.VCS.kind); VCS.delete_boxes_of id; VCS.gc (); VCS.print (); if not !Flags.async_proofs_full then Reach.known_state ~cache:(interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip in try let rc = let focused = List.exists ((=) VCS.edit_branch) (VCS.branches ()) in let branch_info = match snd (VCS.get_info id).vcs_backup with | Some{ mine = bn, { VCS.kind = `Proof(m,_) }} -> Some(m,bn) | Some{ mine = _, { VCS.kind = `Edit(m,_,_,_,bn) }} -> Some (m,bn) | _ -> None in match focused, VCS.proof_task_box_of id, branch_info with | _, Some _, None -> assert false | false, Some { qed = qed_id ; lemma = start }, Some(mode,bn) -> let tip = VCS.cur_tip () in if has_failed qed_id && is_pure qed_id && not !Flags.async_proofs_never_reopen_branch then reopen_branch start id mode qed_id tip bn else backto id (Some bn) | true, Some { qed = qed_id }, Some(mode,bn) -> if on_cur_branch id then begin assert false end else if is_ancestor_of_cur_branch id then begin backto id (Some bn) end else begin anomaly(str"Cannot leave an `Edit branch open") end | true, None, _ -> if on_cur_branch id then begin VCS.reset_branch (VCS.current_branch ()) id; Reach.known_state ~cache:(interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip end else if is_ancestor_of_cur_branch id then begin backto id None end else begin anomaly(str"Cannot leave an `Edit branch open") end | false, None, Some(_,bn) -> backto id (Some bn) | false, None, None -> backto id None in VCS.print (); rc with e -> let (e, info) = CErrors.push e in match Stateid.get info with | None -> VCS.print (); anomaly (str ("edit_at "^Stateid.to_string id^": ") ++ CErrors.print_no_report e) | Some (_, id) -> prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); VCS.restore vcs; VCS.print (); iraise (e, info) let backup () = VCS.backup () let restore d = VCS.restore d (*********************** TTY API (PG, coqtop, coqc) ***************************) (******************************************************************************) let interp verb (loc,e) = let clas = classify_vernac e in let aast = { verbose = verb; indentation = 0; strlen = 0; loc; expr = e } in let rc = process_transaction ~tty:true aast clas in if rc <> `Ok then anomaly(str"tty loop can't be mixed with the STM protocol"); if interactive () = `Yes || (!Flags.async_proofs_mode = Flags.APoff && !Flags.compilation_mode = Flags.BuildVo) then let vcs = VCS.backup () in let print_goals = verb && match clas with | VtQuery _, _ -> false | (VtProofStep _ | VtStm (VtBack _, _) | VtStartProof _), _ -> true | _ -> not !Flags.coqtop_ui in try finish ~print_goals () with e -> let e = CErrors.push e in handle_failure e vcs true let finish () = finish () let get_current_state () = VCS.cur_tip () let current_proof_depth () = let head = VCS.current_branch () in match VCS.get_branch head with | { VCS.kind = `Master } -> 0 | { VCS.pos = cur; VCS.kind = (`Proof _ | `Edit _); VCS.root = root } -> let rec distance root = if Stateid.equal cur root then 0 else 1 + distance (VCS.visit cur).next in distance cur let unmangle n = let n = VCS.Branch.to_string n in let idx = String.index n '_' + 1 in Names.id_of_string (String.sub n idx (String.length n - idx)) let proofname b = match VCS.get_branch b with | { VCS.kind = (`Proof _| `Edit _) } -> Some b | _ -> None let get_all_proof_names () = List.map unmangle (List.map_filter proofname (VCS.branches ())) let get_current_proof_name () = Option.map unmangle (proofname (VCS.current_branch ())) let get_script prf = let branch, test = match prf with | None -> VCS.Branch.master, fun _ -> true | Some name -> VCS.current_branch (),fun nl -> nl=[] || List.mem name nl in let rec find acc id = if Stateid.equal id Stateid.initial || Stateid.equal id Stateid.dummy then acc else let view = VCS.visit id in match view.step with | `Fork((_,_,_,ns), _) when test ns -> acc | `Qed (qed, proof) -> find [qed.qast.expr, (VCS.get_info id).n_goals] proof | `Sideff (`Ast (x,_)) -> find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next | `Sideff (`Id id) -> find acc id | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *) find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next | `Cmd _ -> find acc view.next | `Alias (id,_) -> find acc id | `Fork _ -> find acc view.next in find [] (VCS.get_branch_pos branch) (* indentation code for Show Script, initially contributed by D. de Rauglaudre *) let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) = (* ng1 : number of goals remaining at the current level (before cmd) ngl1 : stack of previous levels with their remaining goals ng : number of goals after the execution of cmd beginend : special indentation stack for { } *) let ngprev = List.fold_left (+) ng1 ngl1 in let new_ngl = if ng > ngprev then (* We've branched *) (ng - ngprev + 1, ng1 - 1 :: ngl1) else if ng < ngprev then (* A subgoal have been solved. Let's compute the new current level by discarding all levels with 0 remaining goals. *) let rec loop = function | (0, ng2::ngl2) -> loop (ng2,ngl2) | p -> p in loop (ng1-1, ngl1) else (* Standard case, same goal number as before *) (ng1, ngl1) in (* When a subgoal have been solved, separate this block by an empty line *) let new_nl = (ng < ngprev) in (* Indentation depth *) let ind = List.length ngl1 in (* Some special handling of bullets and { }, to get a nicer display *) let pred n = max 0 (n-1) in let ind, nl, new_beginend = match cmd with | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend | VernacEndSubproof -> List.hd beginend, false, List.tl beginend | VernacBullet _ -> pred ind, nl, beginend | _ -> ind, nl, beginend in let pp = (if nl then fnl () else mt ()) ++ (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd)) in (new_ngl, new_nl, new_beginend, pp :: ppl) let show_script ?proof () = try let prf = try match proof with | None -> Some (Pfedit.get_current_proof_name ()) | Some (p,_) -> Some (p.Proof_global.id) with Proof_global.NoCurrentProof -> None in let cmds = get_script prf in let _,_,_,indented_cmds = List.fold_left indent_script_item ((1,[]),false,[],[]) cmds in let indented_cmds = List.rev (indented_cmds) in msg_notice (v 0 (prlist_with_sep fnl (fun x -> x) indented_cmds)) with Vcs_aux.Expired -> () (* Export hooks *) let state_computed_hook = Hooks.state_computed_hook let state_ready_hook = Hooks.state_ready_hook let parse_error_hook = Hooks.parse_error_hook let execution_error_hook = Hooks.execution_error_hook let forward_feedback_hook = Hooks.forward_feedback_hook let process_error_hook = Hooks.process_error_hook 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: *) coq-8.6/stm/dag.ml0000644000175000017500000001056213022274260013027 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* node -> 'e -> node -> ('e,'i,'d) t val from_node : ('e,'i,'d) t -> node -> (node * 'e) list val mem : ('e,'i,'d) t -> node -> bool val del_edge : ('e,'i,'d) t -> node -> node -> ('e,'i,'d) t val del_nodes : ('e,'i,'d) t -> NodeSet.t -> ('e,'i,'d) t val all_nodes : ('e,'i,'d) t -> NodeSet.t val get_info : ('e,'i,'d) t -> node -> 'i option val set_info : ('e,'i,'d) t -> node -> 'i -> ('e,'i,'d) t val clear_info : ('e,'i,'d) t -> node -> ('e,'i,'d) t module Property : sig type 'd t val equal : 'd t -> 'd t -> bool val compare : 'd t -> 'd t -> int val to_string : 'd t -> string val data : 'd t -> 'd val having_it : 'd t -> NodeSet.t end val create_property : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t val property_of : ('e,'i,'d) t -> node -> 'd Property.t list val del_property : ('e,'i,'d) t -> 'd Property.t -> ('e,'i,'d) t val iter : ('e,'i,'d) t -> (node -> 'd Property.t list -> 'i option -> (node * 'e) list -> unit) -> unit end module Make(OT : Map.OrderedType) = struct module NodeSet = Set.Make(OT) module Property = struct type 'd t = { data : 'd; uid : int; having_it : NodeSet.t } let equal { uid = i1 } { uid = i2 } = Int.equal i1 i2 let compare { uid = i1 } { uid = i2 } = Int.compare i1 i2 let to_string { uid = i } = string_of_int i let data { data = d } = d let having_it { having_it } = having_it end type node = OT.t module NodeMap = CMap.Make(OT) type ('edge,'info,'data) t = { graph : (node * 'edge) list NodeMap.t; properties : 'data Property.t list NodeMap.t; infos : 'info NodeMap.t; } let empty = { graph = NodeMap.empty; properties = NodeMap.empty; infos = NodeMap.empty; } let mem { graph } id = NodeMap.mem id graph let add_edge dag from trans dest = { dag with graph = try NodeMap.modify from (fun _ arcs -> (dest, trans) :: arcs) dag.graph with Not_found -> NodeMap.add from [dest, trans] dag.graph } let from_node { graph } id = NodeMap.find id graph let del_edge dag id tgt = { dag with graph = try let modify _ arcs = let filter (d, _) = OT.compare d tgt <> 0 in List.filter filter arcs in NodeMap.modify id modify dag.graph with Not_found -> dag.graph } let del_nodes dag s = { infos = NodeMap.filter (fun n _ -> not(NodeSet.mem n s)) dag.infos; properties = NodeMap.filter (fun n _ -> not(NodeSet.mem n s)) dag.properties; graph = NodeMap.filter (fun n l -> let drop = NodeSet.mem n s in if not drop then assert(List.for_all (fun (n',_) -> not(NodeSet.mem n' s)) l); not drop) dag.graph } let map_add_list k v m = try let l = NodeMap.find k m in NodeMap.add k (v::l) m with Not_found -> NodeMap.add k [v] m let clid = ref 1 let create_property dag l data = incr clid; let having_it = List.fold_right NodeSet.add l NodeSet.empty in let property = { Property.data; uid = !clid; having_it } in { dag with properties = List.fold_right (fun x ps -> map_add_list x property ps) l dag.properties } let property_of dag id = try NodeMap.find id dag.properties with Not_found -> [] let del_property dag c = { dag with properties = NodeMap.filter (fun _ cl -> cl <> []) (NodeMap.map (fun cl -> List.filter (fun c' -> not (Property.equal c' c)) cl) dag.properties) } let get_info dag id = try Some (NodeMap.find id dag.infos) with Not_found -> None let set_info dag id info = { dag with infos = NodeMap.add id info dag.infos } let clear_info dag id = { dag with infos = NodeMap.remove id dag.infos } let iter dag f = NodeMap.iter (fun k v -> f k (property_of dag k) (get_info dag k) v) dag.graph let all_nodes dag = NodeMap.domain dag.graph end coq-8.6/stm/tQueue.mli0000644000175000017500000000233713022274260013716 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a t val pop : ?picky:('a -> bool) -> ?destroy:bool ref -> 'a t -> 'a val push : 'a t -> 'a -> unit val set_order : 'a t -> ('a -> 'a -> int) -> unit val wait_until_n_are_waiting_and_queue_empty : int -> 'a t -> unit (* Wake up all waiting threads *) val broadcast : 'a t -> unit (* Non destructive *) val wait_until_n_are_waiting_then_snapshot : int -> 'a t -> 'a list val clear : 'a t -> unit val clear_saving : 'a t -> ('a -> 'b option) -> 'b list val is_empty : 'a t -> bool exception BeingDestroyed (* Threads blocked in pop can get this exception if the queue is being * destroyed *) val destroy : 'a t -> unit val length : 'a t -> int coq-8.6/stm/dag.mli0000644000175000017500000000400713022274260013175 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* node -> 'e -> node -> ('e,'i,'d) t val from_node : ('e,'i,'d) t -> node -> (node * 'e) list val mem : ('e,'i,'d) t -> node -> bool val del_edge : ('e,'i,'d) t -> node -> node -> ('e,'i,'d) t val del_nodes : ('e,'i,'d) t -> NodeSet.t -> ('e,'i,'d) t val all_nodes : ('e,'i,'d) t -> NodeSet.t val get_info : ('e,'i,'d) t -> node -> 'i option val set_info : ('e,'i,'d) t -> node -> 'i -> ('e,'i,'d) t val clear_info : ('e,'i,'d) t -> node -> ('e,'i,'d) t (* A property applies to a set of nodes and holds some data. Stm uses this feature to group nodes contributing to the same proofs and to structure proofs in boxes limiting the scope of errors *) module Property : sig type 'd t val equal : 'd t -> 'd t -> bool val compare : 'd t -> 'd t -> int val to_string : 'd t -> string val data : 'd t -> 'd val having_it : 'd t -> NodeSet.t end val create_property : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t val property_of : ('e,'i,'d) t -> node -> 'd Property.t list val del_property : ('e,'i,'d) t -> 'd Property.t -> ('e,'i,'d) t val iter : ('e,'i,'d) t -> (node -> 'd Property.t list -> 'i option -> (node * 'e) list -> unit) -> unit end module Make(OT : Map.OrderedType) : S with type node = OT.t and type NodeSet.t = Set.Make(OT).t and type NodeSet.elt = OT.t coq-8.6/stm/proofworkertop.mllib0000644000175000017500000000001713022274260016057 0ustar garesgaresProofworkertop coq-8.6/stm/asyncTaskQueue.ml0000644000175000017500000003030413022274260015235 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string array (* run by the master, on a thread *) val request_of_task : competence worker_status -> task -> request option val task_match : competence worker_status -> task -> bool val use_response : competence worker_status -> task -> response -> [ `Stay of competence * task list | `End ] val on_marshal_error : string -> task -> unit val on_task_cancellation_or_expiration_or_slave_death : task option -> unit val forward_feedback : Feedback.feedback -> unit (* run by the worker *) val perform : request -> response (* debugging *) val name_of_task : task -> string val name_of_request : request -> string end type expiration = bool ref module Make(T : Task) = struct exception Die type response = | Response of T.response | RespFeedback of Feedback.feedback | RespGetCounterNewUnivLevel type request = Request of T.request type more_data = | MoreDataUnivLevel of Univ.universe_level list let slave_respond (Request r) = let res = T.perform r in Response res exception MarshalError of string let marshal_to_channel oc data = Marshal.to_channel oc data []; flush oc let marshal_err s = raise (MarshalError s) let marshal_request oc (req : request) = try marshal_to_channel oc req with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("marshal_request: "^s) let unmarshal_request ic = try (CThread.thread_friendly_input_value ic : request) with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("unmarshal_request: "^s) let marshal_response oc (res : response) = try marshal_to_channel oc res with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("marshal_response: "^s) let unmarshal_response ic = try (CThread.thread_friendly_input_value ic : response) with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("unmarshal_response: "^s) let marshal_more_data oc (res : more_data) = try marshal_to_channel oc res with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("marshal_more_data: "^s) let unmarshal_more_data ic = try (CThread.thread_friendly_input_value ic : more_data) with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("unmarshal_more_data: "^s) let report_status ?(id = !Flags.async_proofs_worker_id) s = let open Feedback in feedback ~id:(State Stateid.initial) (WorkerStatus(id, s)) module Worker = Spawn.Sync(struct end) module Model = struct type process = Worker.process type extra = (T.task * expiration) TQueue.t let spawn id = let name = Printf.sprintf "%s:%d" !T.name id in let proc, ic, oc = let rec set_slave_opt = function | [] -> !Flags.async_proofs_flags_for_workers @ ["-toploop"; !T.name^"top"; "-worker-id"; name; "-async-proofs-worker-priority"; Flags.string_of_priority !Flags.async_proofs_worker_priority] | ("-ideslave"|"-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl | ("-async-proofs" |"-toploop" |"-vio2vo" |"-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 let args = Array.of_list (set_slave_opt (List.tl (Array.to_list Sys.argv))) in let env = Array.append (T.extra_env ()) (Unix.environment ()) in Worker.spawn ~env Sys.argv.(0) args in name, proc, CThread.prepare_in_channel_for_thread_friendly_io ic, oc let manager cpanel (id, proc, ic, oc) = let { WorkerPool.extra = queue; exit; cancelled } = cpanel in let exit () = report_status ~id "Dead"; exit () in let last_task = ref None in let worker_age = ref `Fresh in let got_token = ref false in let giveback_exec_token () = if !got_token then (CoqworkmgrApi.giveback 1; got_token := false) in let stop_waiting = ref false in let expiration_date = ref (ref false) in let pick_task () = prerr_endline "waiting for a task"; let pick age (t, c) = not !c && T.task_match age t in let task, task_expiration = TQueue.pop ~picky:(pick !worker_age) ~destroy:stop_waiting queue in expiration_date := task_expiration; last_task := Some task; prerr_endline ("got task: "^T.name_of_task task); task in let add_tasks l = List.iter (fun t -> TQueue.push queue (t,!expiration_date)) l in let get_exec_token () = ignore(CoqworkmgrApi.get 1); got_token := true; prerr_endline ("got execution token") in let kill proc = Worker.kill proc; prerr_endline ("Worker exited: " ^ match Worker.wait proc with | Unix.WEXITED 0x400 -> "exit code unavailable" | Unix.WEXITED i -> Printf.sprintf "exit(%d)" i | Unix.WSIGNALED sno -> Printf.sprintf "signalled(%d)" sno | Unix.WSTOPPED sno -> Printf.sprintf "stopped(%d)" sno) in let more_univs n = CList.init 10 (fun _ -> Universes.new_univ_level (Global.current_dirpath ())) in let rec kill_if () = if not (Worker.is_alive proc) then () else if cancelled () || !(!expiration_date) then let () = stop_waiting := true in let () = TQueue.broadcast queue in Worker.kill proc else let () = Unix.sleep 1 in kill_if () in let kill_if () = try kill_if () with Sys.Break -> let () = stop_waiting := true in let () = TQueue.broadcast queue in Worker.kill proc in let _ = Thread.create kill_if () in try while true do report_status ~id "Idle"; let task = pick_task () in match T.request_of_task !worker_age task with | None -> prerr_endline ("Task expired: " ^ T.name_of_task task) | Some req -> try get_exec_token (); marshal_request oc (Request req); let rec continue () = match unmarshal_response ic with | RespGetCounterNewUnivLevel -> marshal_more_data oc (MoreDataUnivLevel (more_univs 10)); continue () | RespFeedback fbk -> T.forward_feedback fbk; continue () | Response resp -> match T.use_response !worker_age task resp with | `End -> raise Die | `Stay(competence, new_tasks) -> last_task := None; giveback_exec_token (); worker_age := `Old competence; add_tasks new_tasks in continue () with | (Sys_error _|Invalid_argument _|End_of_file|Die) as e -> raise e (* we pass the exception to the external handler *) | MarshalError s -> T.on_marshal_error s task; raise Die | e -> pr_err ("Uncaught exception in worker manager: "^ string_of_ppcmds (print e)); flush_all (); raise Die done with | (Die | TQueue.BeingDestroyed) -> giveback_exec_token (); kill proc; exit () | Sys_error _ | Invalid_argument _ | End_of_file -> T.on_task_cancellation_or_expiration_or_slave_death !last_task; giveback_exec_token (); kill proc; exit () end module Pool = WorkerPool.Make(Model) type queue = { active : Pool.pool; queue : (T.task * expiration) TQueue.t; cleaner : Thread.t; } let create size = let cleaner queue = while true do try ignore(TQueue.pop ~picky:(fun (_,cancelled) -> !cancelled) queue) with TQueue.BeingDestroyed -> Thread.exit () done in let queue = TQueue.create () in { active = Pool.create queue ~size; queue; cleaner = Thread.create cleaner queue; } let destroy { active; queue } = Pool.destroy active; TQueue.destroy queue let broadcast { queue } = TQueue.broadcast queue let enqueue_task { queue; active } (t, _ as item) = prerr_endline ("Enqueue task "^T.name_of_task t); TQueue.push queue item let cancel_worker { active } n = Pool.cancel n active let name_of_request (Request r) = T.name_of_request r let set_order { queue } cmp = TQueue.set_order queue (fun (t1,_) (t2,_) -> cmp t1 t2) let join { queue; active } = if not (Pool.is_empty active) then TQueue.wait_until_n_are_waiting_and_queue_empty (Pool.n_workers active + 1(*cleaner*)) queue let cancel_all { queue; active } = TQueue.clear queue; Pool.cancel_all active let slave_ic = ref None let slave_oc = ref None let init_stdout () = let ic, oc = Spawned.get_channels () in slave_oc := Some oc; slave_ic := Some ic let bufferize f = let l = ref [] in fun () -> match !l with | [] -> let data = f () in l := List.tl data; List.hd data | x::tl -> l := tl; x let slave_handshake () = Pool.worker_handshake (Option.get !slave_ic) (Option.get !slave_oc) let pp_pid pp = (* Breaking all abstraction barriers... very nice *) let get_xml pp = match Richpp.repr pp with | Xml_datatype.Element("_", [], xml) -> xml | _ -> assert false in Richpp.richpp_of_xml (Xml_datatype.Element("_", [], get_xml (Richpp.richpp_of_pp Pp.(str (System.process_id ()^ " "))) @ get_xml pp)) let debug_with_pid = Feedback.(function | { contents = Message(Debug, loc, pp) } as fb -> { fb with contents = Message(Debug,loc,pp_pid pp) } | x -> x) let main_loop () = (* We pass feedback to master *) let slave_feeder oc fb = Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc in Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x); Feedback.set_logger Feedback.feedback_logger; (* We ask master to allocate universe identifiers *) Universes.set_remote_new_univ_level (bufferize (fun () -> marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; match unmarshal_more_data (Option.get !slave_ic) with | MoreDataUnivLevel l -> l)); let working = ref false in slave_handshake (); while true do try working := false; let request = unmarshal_request (Option.get !slave_ic) in working := true; report_status (name_of_request request); let response = slave_respond request in report_status "Idle"; marshal_response (Option.get !slave_oc) response; CEphemeron.clear () with | MarshalError s -> pr_err ("Fatal marshal error: " ^ s); flush_all (); exit 2 | End_of_file -> prerr_endline "connection lost"; flush_all (); exit 2 | e -> pr_err ("Slave: critical exception: " ^ Pp.string_of_ppcmds (print e)); flush_all (); exit 1 done let clear { queue; active } = assert(Pool.is_empty active); (* We allow that only if no slaves *) TQueue.clear queue let snapshot { queue; active } = List.map fst (TQueue.wait_until_n_are_waiting_then_snapshot (Pool.n_workers active) queue) let with_n_workers n f = let q = create n in try let rc = f q in destroy q; rc with e -> let e = CErrors.push e in destroy q; iraise e let n_workers { active } = Pool.n_workers active end module MakeQueue(T : Task) = struct include Make(T) end module MakeWorker(T : Task) = struct include Make(T) end coq-8.6/stm/queryworkertop.mllib0000644000175000017500000000001713022274260016077 0ustar garesgaresQueryworkertop coq-8.6/stm/workerPool.ml0000644000175000017500000000743513022274260014444 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit; (* called by manager to exit instead of Thread.exit *) cancelled : unit -> bool; (* manager checks for a request of termination *) extra : 'a; (* extra stuff to pass to the manager *) } module type PoolModel = sig (* this shall come from a Spawn.* model *) type process val spawn : int -> worker_id * process * CThread.thread_ic * out_channel (* this defines the main loop of the manager *) type extra val manager : extra cpanel -> worker_id * process * CThread.thread_ic * out_channel -> unit end module Make(Model : PoolModel) = struct type worker = { name : worker_id; cancel : bool ref; manager : Thread.t; process : Model.process; } type pre_pool = { workers : worker list ref; count : int ref; extra_arg : Model.extra; } type pool = { lock : Mutex.t; pool : pre_pool } let magic_no = 17 let master_handshake worker_id ic oc = try Marshal.to_channel oc magic_no []; flush oc; let n = (CThread.thread_friendly_input_value ic : int) in if n <> magic_no then begin Printf.eprintf "Handshake with %s failed: protocol mismatch\n" worker_id; exit 1; end with e when CErrors.noncritical e -> Printf.eprintf "Handshake with %s failed: %s\n" worker_id (Printexc.to_string e); exit 1 let worker_handshake slave_ic slave_oc = try let v = (CThread.thread_friendly_input_value slave_ic : int) in if v <> magic_no then begin prerr_endline "Handshake failed: protocol mismatch\n"; exit 1; end; Marshal.to_channel slave_oc v []; flush slave_oc; with e when CErrors.noncritical e -> prerr_endline ("Handshake failed: " ^ Printexc.to_string e); exit 1 let locking { lock; pool = p } f = try Mutex.lock lock; let x = f p in Mutex.unlock lock; x with e -> Mutex.unlock lock; raise e let rec create_worker extra pool id = let cancel = ref false in let name, process, ic, oc as worker = Model.spawn id in master_handshake name ic oc; let exit () = cancel := true; cleanup pool; Thread.exit () in let cancelled () = !cancel in let cpanel = { exit; cancelled; extra } in let manager = Thread.create (Model.manager cpanel) worker in { name; cancel; manager; process } and cleanup x = locking x begin fun { workers; count; extra_arg } -> workers := List.map (function | { cancel } as w when !cancel = false -> w | _ -> let n = !count in incr count; create_worker extra_arg x n) !workers end let n_workers x = locking x begin fun { workers } -> List.length !workers end let is_empty x = locking x begin fun { workers } -> !workers = [] end let create extra_arg ~size = let x = { lock = Mutex.create (); pool = { extra_arg; workers = ref []; count = ref size; }} in locking x begin fun { workers } -> workers := CList.init size (create_worker extra_arg x) end; x let cancel n x = locking x begin fun { workers } -> List.iter (fun { name; cancel } -> if n = name then cancel := true) !workers end let cancel_all x = locking x begin fun { workers } -> List.iter (fun { cancel } -> cancel := true) !workers end let destroy x = locking x begin fun { workers } -> List.iter (fun { cancel } -> cancel := true) !workers; workers := [] end end coq-8.6/stm/vernac_classifier.mli0000644000175000017500000000223313022274260016123 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string (** What does a vernacular do *) val classify_vernac : vernac_expr -> vernac_classification (** Install a vernacular classifier for VernacExtend *) val declare_vernac_classifier : Vernacexpr.extend_name -> (raw_generic_argument list -> unit -> vernac_classification) -> unit (** Set by Stm *) val set_undo_classifier : (vernac_expr -> vernac_classification) -> unit (** Standard constant classifiers *) val classify_as_query : vernac_classification val classify_as_sideeff : vernac_classification val classify_as_proofstep : vernac_classification coq-8.6/stm/spawned.mli0000644000175000017500000000172413022274260014106 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit (* Once initialized, these are the channels to talk with our master *) val get_channels : unit -> CThread.thread_ic * out_channel coq-8.6/stm/tQueue.ml0000644000175000017500000001111113022274260013533 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a t val set_rel : ('a -> 'a -> int) -> 'a t -> unit val is_empty : 'a t -> bool val exists : ('a -> bool) -> 'a t -> bool val pop : ?picky:('a -> bool) -> 'a t -> 'a val push : 'a t -> 'a -> unit val clear : 'a t -> unit val length : 'a t -> int end = struct type 'a item = int * 'a type 'a rel = 'a item -> 'a item -> int type 'a t = ('a item list * 'a rel) ref let sort_timestamp (i,_) (j,_) = i - j let age = ref 0 let create () = ref ([],sort_timestamp) let is_empty t = fst !t = [] let exists p t = List.exists (fun (_,x) -> p x) (fst !t) let pop ?(picky=(fun _ -> true)) ({ contents = (l, rel) } as t) = let rec aux acc = function | [] -> raise Queue.Empty | (_,x) :: xs when picky x -> t := (List.rev acc @ xs, rel); x | (_,x) as hd :: xs -> aux (hd :: acc) xs in aux [] l let push ({ contents = (xs, rel) } as t) x = incr age; (* re-roting the whole list is not the most efficient way... *) t := (List.sort rel (xs @ [!age,x]), rel) let clear ({ contents = (l, rel) } as t) = t := ([], rel) let set_rel rel ({ contents = (xs, _) } as t) = let rel (_,x) (_,y) = rel x y in t := (List.sort rel xs, rel) let length ({ contents = (l, _) }) = List.length l end type 'a t = { queue: 'a PriorityQueue.t; lock : Mutex.t; cond : Condition.t; mutable nwaiting : int; cond_waiting : Condition.t; mutable release : bool; } exception BeingDestroyed let create () = { queue = PriorityQueue.create (); lock = Mutex.create (); cond = Condition.create (); nwaiting = 0; cond_waiting = Condition.create (); release = false; } let pop ?(picky=(fun _ -> true)) ?(destroy=ref false) ({ queue = q; lock = m; cond = c; cond_waiting = cn } as tq) = Mutex.lock m; if tq.release then (Mutex.unlock m; raise BeingDestroyed); while not (PriorityQueue.exists picky q || !destroy) do tq.nwaiting <- tq.nwaiting + 1; Condition.broadcast cn; Condition.wait c m; tq.nwaiting <- tq.nwaiting - 1; if tq.release || !destroy then (Mutex.unlock m; raise BeingDestroyed) done; if !destroy then (Mutex.unlock m; raise BeingDestroyed); let x = PriorityQueue.pop ~picky q in Condition.signal c; Condition.signal cn; Mutex.unlock m; x let broadcast { lock = m; cond = c } = Mutex.lock m; Condition.broadcast c; Mutex.unlock m let push { queue = q; lock = m; cond = c; release } x = if release then CErrors.anomaly(Pp.str "TQueue.push while being destroyed! Only 1 producer/destroyer allowed"); Mutex.lock m; PriorityQueue.push q x; Condition.broadcast c; Mutex.unlock m let length { queue = q; lock = m } = Mutex.lock m; let n = PriorityQueue.length q in Mutex.unlock m; n let clear { queue = q; lock = m; cond = c } = Mutex.lock m; PriorityQueue.clear q; Mutex.unlock m let clear_saving { queue = q; lock = m; cond = c } f = Mutex.lock m; let saved = ref [] in while not (PriorityQueue.is_empty q) do let elem = PriorityQueue.pop q in match f elem with | Some x -> saved := x :: !saved | None -> () done; Mutex.unlock m; List.rev !saved let is_empty { queue = q } = PriorityQueue.is_empty q let destroy tq = tq.release <- true; while tq.nwaiting > 0 do Mutex.lock tq.lock; Condition.broadcast tq.cond; Mutex.unlock tq.lock; done; tq.release <- false let wait_until_n_are_waiting_and_queue_empty j tq = Mutex.lock tq.lock; while not (PriorityQueue.is_empty tq.queue) || tq.nwaiting < j do Condition.wait tq.cond_waiting tq.lock done; Mutex.unlock tq.lock let wait_until_n_are_waiting_then_snapshot j tq = let l = ref [] in Mutex.lock tq.lock; while not (PriorityQueue.is_empty tq.queue) do l := PriorityQueue.pop tq.queue :: !l done; while tq.nwaiting < j do Condition.wait tq.cond_waiting tq.lock done; List.iter (PriorityQueue.push tq.queue) (List.rev !l); if !l <> [] then Condition.broadcast tq.cond; Mutex.unlock tq.lock; List.rev !l let set_order tq rel = Mutex.lock tq.lock; PriorityQueue.set_rel rel tq.queue; Mutex.unlock tq.lock coq-8.6/stm/stm.mllib0000644000175000017500000000017513022274260013565 0ustar garesgaresSpawned Dag Vcs TQueue WorkerPool Vernac_classifier Lemmas CoqworkmgrApi AsyncTaskQueue Stm ProofBlockDelimiter Vio_checking coq-8.6/stm/lemmas.ml0000644000175000017500000005316113022274260013554 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Globnames.global_reference -> 'a let mk_hook hook = hook let call_hook fix_exn hook l c = try hook l c with e when CErrors.noncritical e -> let e = CErrors.push e in iraise (fix_exn e) (* Support for mutually proved theorems *) let retrieve_first_recthm = function | VarRef id -> let open Context.Named.Declaration in (get_value (Global.lookup_named id),variable_opacity id) | ConstRef cst -> let cb = Global.lookup_constant cst in (Global.body_of_constant_body cb, is_opaque cb) | _ -> assert false let adjust_guardness_conditions const = function | [] -> const (* Not a recursive statement *) | possible_indexes -> (* Try all combinations... not optimal *) let env = Global.env() in { const with const_entry_body = Future.chain ~greedy:true ~pure:true const.const_entry_body (fun ((body, ctx), eff) -> match kind_of_term body with | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> (* let possible_indexes = List.map2 (fun i c -> match i with Some i -> i | None -> List.interval 0 (List.length ((lam_assum c)))) lemma_guard (Array.to_list fixdefs) in *) let add c cb e = let exists c e = try ignore(Environ.lookup_constant c e); true with Not_found -> false in if exists c e then e else Environ.add_constant c cb e in let env = List.fold_left (fun env { eff } -> match eff with | SEsubproof (c, cb,_) -> add c cb env | SEscheme (l,_) -> List.fold_left (fun e (_,c,cb,_) -> add c cb e) env l) env (Safe_typing.side_effects_of_private_constants eff) in let indexes = search_guard Loc.ghost env possible_indexes fixdecls in (mkFix ((indexes,0),fixdecls), ctx), eff | _ -> (body, ctx), eff) } let find_mutually_recursive_statements thms = let n = List.length thms in let inds = List.map (fun (id,(t,impls,annot)) -> let (hyps,ccl) = decompose_prod_assum t in let x = (id,(t,impls)) in match annot with (* Explicit fixpoint decreasing argument is given *) | Some (Some (_,id),CStructRec) -> let i,b,typ = lookup_rel_id id hyps in (match kind_of_term t with | Ind ((kn,_ as ind), u) when let mind = Global.lookup_mind kn in mind.mind_finite == Decl_kinds.Finite && Option.is_empty b -> [ind,x,i],[] | _ -> error "Decreasing argument is not an inductive assumption.") (* Unsupported cases *) | Some (_,(CWfRec _|CMeasureRec _)) -> error "Only structural decreasing is supported for mutual statements." (* Cofixpoint or fixpoint w/o explicit decreasing argument *) | None | Some (None, CStructRec) -> let whnf_hyp_hds = map_rel_context_in_env (fun env c -> fst (whd_all_stack env Evd.empty c)) (Global.env()) hyps in let ind_hyps = List.flatten (List.map_i (fun i decl -> let t = get_type decl in match kind_of_term t with | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in mind.mind_finite <> Decl_kinds.CoFinite && is_local_assum decl -> [ind,x,i] | _ -> []) 0 (List.rev whnf_hyp_hds)) in let ind_ccl = let cclenv = push_rel_context hyps (Global.env()) in let whnf_ccl,_ = whd_all_stack cclenv Evd.empty ccl in match kind_of_term whnf_ccl with | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in Int.equal mind.mind_ntypes n && mind.mind_finite == Decl_kinds.CoFinite -> [ind,x,0] | _ -> [] in ind_hyps,ind_ccl) thms in let inds_hyps,ind_ccls = List.split inds in let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> eq_mind kn kn' in (* Check if all conclusions are coinductive in the same type *) (* (degenerated cartesian product since there is at most one coind ccl) *) let same_indccl = List.cartesians_filter (fun hyp oks -> if List.for_all (of_same_mutind hyp) oks then Some (hyp::oks) else None) [] ind_ccls in let ordered_same_indccl = List.filter (List.for_all_i (fun i ((kn,j),_,_) -> Int.equal i j) 0) same_indccl in (* Check if some hypotheses are inductive in the same type *) let common_same_indhyp = List.cartesians_filter (fun hyp oks -> if List.for_all (of_same_mutind hyp) oks then Some (hyp::oks) else None) [] inds_hyps in let ordered_inds,finite,guard = match ordered_same_indccl, common_same_indhyp with | indccl::rest, _ -> assert (List.is_empty rest); (* One occ. of common coind ccls and no common inductive hyps *) if not (List.is_empty common_same_indhyp) then if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements."); flush_all (); indccl, true, [] | [], _::_ -> let () = match same_indccl with | ind :: _ -> if List.distinct_f ind_ord (List.map pi1 ind) then if_verbose Feedback.msg_info (strbrk ("Coinductive statements do not follow the order of "^ "definition, assuming the proof to be by induction.")); flush_all () | _ -> () in let possible_guards = List.map (List.map pi3) inds_hyps in (* assume the largest indices as possible *) List.last common_same_indhyp, false, possible_guards | _, [] -> error ("Cannot find common (mutual) inductive premises or coinductive" ^ " conclusions in the statements.") in (finite,guard,None), ordered_inds let look_for_possibly_mutual_statements = function | [id,(t,impls,None)] -> (* One non recursively proved theorem *) None,[id,(t,impls)],None | _::_ as thms -> (* More than one statement and/or an explicit decreasing mark: *) (* we look for a common inductive hyp or a common coinductive conclusion *) let recguard,ordered_inds = find_mutually_recursive_statements thms in let thms = List.map pi2 ordered_inds in Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds) | [] -> anomaly (Pp.str "Empty list of theorems.") (* Saving a goal *) let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook = let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in try let const = adjust_guardness_conditions const do_guard in let k = Kindops.logical_kind_of_goal_kind kind in let l,r = match locality with | Discharge when Lib.sections_are_opened () -> let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in (Local, VarRef id) | Local | Global | Discharge -> let local = match locality with | Local | Discharge -> true | Global -> false in let kn = declare_constant ?export_seff id ~local (DefinitionEntry const, k) in (locality, ConstRef kn) in definition_message id; Option.iter (Universes.register_universe_binders r) pl; call_hook (fun exn -> exn) hook l r with e when CErrors.noncritical e -> let e = CErrors.push e in iraise (fix_exn e) let default_thm_id = Id.of_string "Unnamed_thm" let compute_proof_name locality = function | Some ((loc,id),pl) -> (* We check existence here: it's a bit late at Qed time *) if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) then user_err_loc (loc,"",pr_id id ++ str " already exists."); id, pl | None -> 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,pl),(t_i,(_,imps))) = let t_i = norm t_i in match body with | None -> (match locality with | Discharge -> let impl = false in (* copy values from Vernacentries *) let k = IsAssumption Conjectural in let c = SectionLocalAssum ((t_i,ctx),p,impl) in let _ = declare_variable id (Lib.cwd(),c,k) in (Discharge, VarRef id,imps) | Local | Global -> let k = IsAssumption Conjectural in let local = match locality with | Local -> true | Global -> false | Discharge -> assert false in let ctx = Univ.ContextSet.to_context ctx in let decl = (ParameterEntry (None,p,(t_i,ctx),None), k) in let kn = declare_constant id ~local decl in (locality,ConstRef kn,imps)) | Some body -> let body = norm body in let k = Kindops.logical_kind_of_goal_kind kind in let rec body_i t = match kind_of_term t with | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) | CoFix (0,decls) -> mkCoFix (i,decls) | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2) | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) | App (t, args) -> mkApp (body_i t, args) | _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body) in let body_i = body_i body in match locality with | Discharge -> let const = definition_entry ~types:t_i ~opaque:opaq ~poly:p ~univs:(Univ.ContextSet.to_context ctx) body_i in let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in (Discharge,VarRef id,imps) | Local | Global -> let ctx = Univ.ContextSet.to_context ctx in let local = match locality with | Local -> true | Global -> false | Discharge -> assert false in let const = Declare.definition_entry ~types:t_i ~poly:p ~univs:ctx ~opaque:opaq body_i in let kn = declare_constant id ~local (DefinitionEntry const, k) in (locality,ConstRef kn,imps) let save_hook = ref ignore let set_save_hook f = save_hook := f let save_named ?export_seff proof = 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,pl),do_guard,persistence,hook = proof in check_anonymity id save_ident; 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,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 pl do_guard (Global, const.const_entry_polymorphic, Proof kind) hook (* Admitted *) let warn_let_as_axiom = CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" (fun id -> strbrk "Let definition" ++ spc () ++ pr_id id ++ spc () ++ strbrk "declared as an axiom.") let admit (id,k,e) pl hook () = let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in let () = match k with | Global, _, _ -> () | Local, _, _ | Discharge, _, _ -> warn_let_as_axiom id 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 *) let start_hook = ref ignore let set_start_hook = (:=) start_hook let get_proof proof do_guard hook opacity = let (id,(const,univs,persistence)) = Pfedit.cook_this_proof proof in id,{const with const_entry_opaque = opacity},univs,do_guard,persistence,hook let check_exist = List.iter (fun (loc,id) -> if not (Nametab.exists_cci (Lib.make_path id)) then user_err_loc (loc,"",pr_id id ++ str " does not exist.") ) let universe_proof_terminator compute_guard hook = let open Proof_global in make_terminator begin function | Admitted (id,k,pe,(ctx,pl)) -> admit (id,k,pe) pl (hook (Some ctx)) (); Feedback.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 (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 | Some ((_,id),Some kind) -> save_anonymous_with_strength ~export_seff proof kind id end; check_exist exports end let standard_proof_terminator compute_guard hook = universe_proof_terminator compute_guard (fun _ -> hook) let start_proof id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = let terminator = match terminator with | None -> standard_proof_terminator compute_guard hook | Some terminator -> terminator compute_guard hook in let sign = match sign with | Some sign -> sign | None -> initialize_named_context_for_proof () in !start_hook c; Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = let terminator = match terminator with | None -> universe_proof_terminator compute_guard hook | Some terminator -> terminator compute_guard hook in let sign = match sign with | Some sign -> sign | None -> initialize_named_context_for_proof () in !start_hook c; 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 | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else (* nl is dummy: it will be recomputed at Qed-time *) 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 | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false let start_proof_with_initialization kind ctx recguard thms snl hook = let intro_tac (_, (_, (ids, _))) = Tacticals.New.tclMAP (function | Name id -> Tactics.intro_mustbe_force id | Anonymous -> Tactics.intro) (List.rev ids) in let init_tac,guard = match recguard with | Some (finite,guard,init_tac) -> let rec_tac = rec_tac_initializer finite guard thms snl in Some (match init_tac with | None -> if Flags.is_auto_intros () then Tacticals.New.tclTHENS rec_tac (List.map intro_tac thms) else rec_tac | Some tacl -> Tacticals.New.tclTHENS rec_tac (if Flags.is_auto_intros () then List.map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms else tacl)),guard | None -> let () = match thms with [_] -> () | _ -> assert false in (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,pl),(t,(_,imps)))::other_thms -> let hook ctx strength ref = let ctx = match ctx with | None -> Evd.empty_evar_universe_context | Some ctx -> ctx in let other_thms_data = if List.is_empty other_thms then [] else (* there are several theorems defined mutually *) let body,opaq = retrieve_first_recthm ref in let subst = Evd.evar_universe_context_subst ctx in let norm c = Universes.subst_opt_univs_constr subst c in let ctx = UState.context_set (*FIXME*) ctx in let body = Option.map norm body in List.map_i (save_remaining_recthms kind norm ctx body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook (fun exn -> exn) hook strength ref) thms_data in start_proof_univs id ?pl kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard let start_proof_com ?inference_hook kind thms hook = let env0 = Global.env () in let levels = Option.map snd (fst (List.hd thms)) in let evdref = ref (match levels with | None -> Evd.from_env env0 | Some l -> Evd.from_ctx (Evd.make_evar_universe_context env0 l)) in let thms = List.map (fun (sopt,(bl,t,guard)) -> let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in let t', imps' = interp_type_evars_impls ~impls env evdref t in let flags = all_and_fail_flags in let flags = { flags with use_hook = inference_hook } in evdref := solve_remaining_evars flags env !evdref (Evd.empty,!evdref); let ids = List.map get_name ctx in (compute_proof_name (pi1 kind) sopt, (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), (ids, imps @ lift_implicits (List.length ids) imps'), guard))) thms in let recguard,thms,snl = look_for_possibly_mutual_statements thms in let evd, nf = Evarutil.nf_evars_and_universes !evdref in let thms = List.map (fun (n, (t, info)) -> (n, (nf t, info))) thms in let () = match levels with | None -> () | Some l -> ignore (Evd.universe_context evd ?names:l) in let evd = if pi2 kind then evd else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd in start_proof_with_initialization kind evd recguard thms snl hook (* Saving a proof *) let keep_admitted_vars = ref true let _ = let open Goptions in declare_bool_option { optsync = true; optdepr = false; optname = "keep section variables in admitted proofs"; optkey = ["Keep"; "Admitted"; "Variables"]; optread = (fun () -> !keep_admitted_vars); optwrite = (fun b -> keep_admitted_vars := b) } let save_proof ?proof = function | Vernacexpr.Admitted -> let pe = let open Proof_global in match proof with | Some ({ id; entries; persistence = k; universes }, _) -> if List.length entries <> 1 then error "Admitted does not support multiple statements"; let { const_entry_secctx; const_entry_type } = List.hd entries in if const_entry_type = None then error "Admitted requires an explicit statement"; let typ = Option.get const_entry_type in let ctx = Evd.evar_context_universe_context (fst universes) in let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in Admitted(id, k, (sec_vars, pi2 k, (typ, ctx), None), universes) | None -> let pftree = Pfedit.get_pftreestate () in let id, k, typ = Pfedit.current_proof_statement () in let universes = Proof.initial_euctx pftree in (* This will warn if the proof is complete *) let pproofs, _univs = Proof_global.return_proof ~allow_partial:true () in let sec_vars = if not !keep_admitted_vars then None else match Pfedit.get_used_variables(), pproofs with | Some _ as x, _ -> x | None, (pproof, _) :: _ -> let env = Global.env () in let ids_typ = Environ.global_vars_set env typ in let ids_def = Environ.global_vars_set env pproof in Some (Environ.keep_hyps env (Idset.union ids_typ ids_def)) | _ -> None in let names = Pfedit.get_universe_binders () in let evd = Evd.from_ctx universes in let binders, ctx = Evd.universe_context ?names evd in Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None), (universes, Some binders)) in Proof_global.apply_terminator (Proof_global.get_terminator ()) pe | Vernacexpr.Proved (is_opaque,idopt) -> let (proof_obj,terminator) = match proof with | None -> Proof_global.close_proof ~keep_body_ucst_separate:false (fun x -> x) | Some proof -> proof in (* if the proof is given explicitly, nothing has to be deleted *) if Option.is_empty proof then Pfedit.delete_current_proof (); Proof_global.(apply_terminator terminator (Proved (is_opaque,idopt,proof_obj))) (* Miscellaneous *) let get_current_context () = Pfedit.get_current_context () coq-8.6/stm/lemmas.mli0000644000175000017500000000552413022274260013725 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Globnames.global_reference -> 'a) -> 'a declaration_hook val call_hook : Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> Globnames.global_reference -> 'a (** 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 -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> ?terminator:(lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> ?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 -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> ?terminator:(lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> unit val start_proof_com : ?inference_hook:Pretyping.inference_hook -> 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 * universe_binders option) * (types * (Name.t list * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit val universe_proof_terminator : Proof_global.lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator val standard_proof_terminator : Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator (** {6 ... } *) (** A hook the next three functions pass to cook_proof *) val set_save_hook : (Proof.proof -> unit) -> unit val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit (** [get_current_context ()] returns the evar context and env of the current open proof if any, otherwise returns the empty evar context and the current global env *) val get_current_context : unit -> Evd.evar_map * Environ.env coq-8.6/stm/vio_checking.ml0000644000175000017500000001247513022274260014731 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Stm.check_task f tasks ids && acc) true ts module Worker = Spawn.Sync(struct end) module IntOT = struct type t = int let compare = compare end module Pool = Map.Make(IntOT) let schedule_vio_checking j fs = if j < 1 then CErrors.error "The number of workers must be bigger than 0"; let jobs = ref [] in List.iter (fun f -> let f = if Filename.check_suffix f ".vio" then Filename.chop_extension f else f in let long_f_dot_v, _,_,_,_, tasks, _ = Library.load_library_todo f in Stm.set_compilation_hints long_f_dot_v; let infos = Stm.info_tasks tasks in let eta = List.fold_left (fun a (_,t,_) -> a +. t) 0.0 infos in if infos <> [] then jobs := (f, eta, infos) :: !jobs) fs; let cmp_job (_,t1,_) (_,t2,_) = compare t2 t1 in jobs := List.sort cmp_job !jobs; let eta = ref (List.fold_left (fun a j -> a +. pi2 j) 0.0 !jobs) in let pool : Worker.process Pool.t ref = ref Pool.empty in let rec filter_argv b = function | [] -> [] | "-schedule-vio-checking" :: rest -> filter_argv true 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 | [] -> [] | ((f,_),_,_) :: _ as l -> let rec aux last acc = function | [] -> [last,acc] | ((f',id),_,_) :: tl when last = f' -> aux last (id::acc) tl | ((f',id),_,_) :: _ as l -> (last,acc) :: aux f' [] l in aux f [] l in let prog = Sys.argv.(0) in let stdargs = filter_argv false (List.tl (Array.to_list Sys.argv)) in let make_job () = let cur = ref 0.0 in let what = ref [] in let j_left = j - Pool.cardinal !pool in let take_next_file () = let f, t, tasks = List.hd !jobs in jobs := List.tl !jobs; cur := !cur +. t; what := (List.map (fun (n,t,id) -> (f,id),n,t) tasks) @ !what in if List.length !jobs >= j_left then take_next_file () else while !jobs <> [] && !cur < max 0.0 (min 60.0 (!eta /. float_of_int j_left)) do let f, t, tasks = List.hd !jobs in jobs := List.tl !jobs; let n, tt, id = List.hd tasks in if List.length tasks > 1 then jobs := (f, t -. tt, List.tl tasks) :: !jobs; cur := !cur +. tt; what := ((f,id),n,tt) :: !what; done; if !what = [] then take_next_file (); eta := !eta -. !cur; let cmp_job (f1,_,_) (f2,_,_) = compare f1 f2 in List.flatten (List.map (fun (f, tl) -> "-check-vio-tasks" :: String.concat "," (List.map string_of_int tl) :: [f]) (pack (List.sort cmp_job !what))) in let rc = ref 0 in while !jobs <> [] || Pool.cardinal !pool > 0 do while Pool.cardinal !pool < j && !jobs <> [] do let args = Array.of_list (stdargs @ make_job ()) in let proc, _, _ = Worker.spawn prog args in pool := Pool.add (Worker.unixpid proc) proc !pool; done; let pid, ret = Unix.wait () in if ret <> Unix.WEXITED 0 then rc := 1; pool := Pool.remove pid !pool; done; exit !rc let schedule_vio_compilation j fs = if j < 1 then CErrors.error "The number of workers must be bigger than 0"; let jobs = ref [] in List.iter (fun f -> let f = if Filename.check_suffix f ".vio" then Filename.chop_extension f else f in let long_f_dot_v = Loadpath.locate_file (f^".v") in let aux = Aux_file.load_aux_file_for long_f_dot_v in let eta = try float_of_string (Aux_file.get aux Loc.ghost "vo_compile_time") with Not_found -> 0.0 in jobs := (f, eta) :: !jobs) fs; let cmp_job (_,t1) (_,t2) = compare t2 t1 in jobs := List.sort cmp_job !jobs; let pool : Worker.process Pool.t ref = ref Pool.empty in let rec filter_argv b = function | [] -> [] | "-schedule-vio2vo" :: rest -> filter_argv true rest | s :: rest when String.length s > 0 && s.[0] = '-' && b -> filter_argv false (s :: rest) | _ :: rest when b -> filter_argv b rest | s :: rest -> s :: filter_argv b rest in let prog = Sys.argv.(0) in let stdargs = filter_argv false (List.tl (Array.to_list Sys.argv)) in let make_job () = let f, t = List.hd !jobs in jobs := List.tl !jobs; [ "-vio2vo"; f ] in let rc = ref 0 in while !jobs <> [] || Pool.cardinal !pool > 0 do while Pool.cardinal !pool < j && !jobs <> [] do let args = Array.of_list (stdargs @ make_job ()) in let proc, _, _ = Worker.spawn prog args in pool := Pool.add (Worker.unixpid proc) proc !pool; done; let pid, ret = Unix.wait () in if ret <> Unix.WEXITED 0 then rc := 1; pool := Pool.remove pid !pool; done; exit !rc coq-8.6/stm/proofBlockDelimiter.ml0000644000175000017500000001472613022274260016241 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Goal.goal -> Goal.goal list -> bool val is_focused_goal_simple : Stateid.t -> [ `Simple of Goal.goal list | `Not ] type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] val crawl : document_view -> ?init:document_node option -> ('a -> document_node -> 'a until) -> 'a -> static_block_declaration option val unit_val : Stm.DynBlockData.t val of_bullet_val : Vernacexpr.bullet -> Stm.DynBlockData.t val to_bullet_val : Stm.DynBlockData.t -> Vernacexpr.bullet val of_vernac_expr_val : Vernacexpr.vernac_expr -> Stm.DynBlockData.t val to_vernac_expr_val : Stm.DynBlockData.t -> Vernacexpr.vernac_expr end = struct let unit_tag = DynBlockData.create "unit" let unit_val = DynBlockData.Easy.inj () unit_tag let of_bullet_val, to_bullet_val = DynBlockData.Easy.make_dyn "bullet" let of_vernac_expr_val, to_vernac_expr_val = DynBlockData.Easy.make_dyn "vernac_expr" let simple_goal sigma g gs = let open Evar in let open Evd in let open Evarutil in let evi = Evd.find sigma g in Set.is_empty (evars_of_term evi.evar_concl) && Set.is_empty (evars_of_filtered_evar_info (nf_evar_info sigma evi)) && not (List.exists (Proofview.depends_on sigma g) gs) let is_focused_goal_simple id = match state_of_id id with | `Expired | `Error _ | `Valid None -> `Not | `Valid (Some { proof }) -> let proof = Proof_global.proof_of_state proof in let focused, r1, r2, r3, sigma = Proof.proof proof in let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in if List.for_all (fun x -> simple_goal sigma x rest) focused then `Simple focused else `Not type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] let crawl { entry_point; prev_node } ?(init=Some entry_point) f acc = let rec crawl node acc = match node with | None -> None | Some node -> match f acc node with | `Stop -> None | `Found x -> Some x | `Cont acc -> crawl (prev_node node) acc in crawl init acc end include Util (* ****************** - foo - bar - baz *********************************** *) let static_bullet ({ entry_point; prev_node } as view) = match entry_point.ast with | Vernacexpr.VernacBullet b -> let base = entry_point.indentation in let last_tac = prev_node entry_point in crawl view ~init:last_tac (fun prev node -> if node.indentation < base then `Stop else if node.indentation > base then `Cont node else match node.ast with | Vernacexpr.VernacBullet b' when b = b' -> `Found { block_stop = entry_point.id; block_start = prev.id; dynamic_switch = node.id; carry_on_data = of_bullet_val b } | _ -> `Stop) entry_point | _ -> assert false let dynamic_bullet { dynamic_switch = id; carry_on_data = b } = match is_focused_goal_simple id with | `Simple focused -> `ValidBlock { base_state = id; goals_to_admit = focused; recovery_command = Some (Vernacexpr.VernacBullet (to_bullet_val b)) } | `Not -> `Leaks let () = register_proof_block_delimiter "bullet" static_bullet dynamic_bullet (* ******************** { block } ***************************************** *) let static_curly_brace ({ entry_point; prev_node } as view) = assert(entry_point.ast = Vernacexpr.VernacEndSubproof); crawl view (fun (nesting,prev) node -> match node.ast with | Vernacexpr.VernacSubproof _ when nesting = 0 -> `Found { block_stop = entry_point.id; block_start = prev.id; dynamic_switch = node.id; carry_on_data = unit_val } | Vernacexpr.VernacSubproof _ -> `Cont (nesting - 1,node) | Vernacexpr.VernacEndSubproof -> `Cont (nesting + 1,node) | _ -> `Cont (nesting,node)) (-1, entry_point) let dynamic_curly_brace { dynamic_switch = id } = match is_focused_goal_simple id with | `Simple focused -> `ValidBlock { base_state = id; goals_to_admit = focused; recovery_command = Some Vernacexpr.VernacEndSubproof } | `Not -> `Leaks let () = register_proof_block_delimiter "curly" static_curly_brace dynamic_curly_brace (* ***************** par: ************************************************* *) let static_par { entry_point; prev_node } = match prev_node entry_point with | None -> None | Some { id = pid } -> Some { block_stop = entry_point.id; block_start = pid; dynamic_switch = pid; carry_on_data = unit_val } let dynamic_par { dynamic_switch = id } = match is_focused_goal_simple id with | `Simple focused -> `ValidBlock { base_state = id; goals_to_admit = focused; recovery_command = None; } | `Not -> `Leaks let () = register_proof_block_delimiter "par" static_par dynamic_par (* ***************** simple indentation *********************************** *) let static_indent ({ entry_point; prev_node } as view) = Printf.eprintf "@%d\n" (Stateid.to_int entry_point.id); match prev_node entry_point with | None -> None | Some last_tac -> if last_tac.indentation <= entry_point.indentation then None else crawl view ~init:(Some last_tac) (fun prev node -> if node.indentation >= last_tac.indentation then `Cont node else `Found { block_stop = entry_point.id; block_start = node.id; dynamic_switch = node.id; carry_on_data = of_vernac_expr_val entry_point.ast } ) last_tac let dynamic_indent { dynamic_switch = id; carry_on_data = e } = Printf.eprintf "%s\n" (Stateid.to_string id); match is_focused_goal_simple id with | `Simple [] -> `Leaks | `Simple focused -> let but_last = List.tl (List.rev focused) in `ValidBlock { base_state = id; goals_to_admit = but_last; recovery_command = Some (to_vernac_expr_val e); } | `Not -> `Leaks let () = register_proof_block_delimiter "indent" static_indent dynamic_indent coq-8.6/stm/proofworkertop.ml0000644000175000017500000000144513022274260015376 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Flags.make_silent true; W.init_stdout (); CoqworkmgrApi.init !Flags.async_proofs_worker_priority; args) let () = Coqtop.toploop_run := W.main_loop coq-8.6/stm/workerPool.mli0000644000175000017500000000310613022274260014604 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit; (* called by manager to exit instead of Thread.exit *) cancelled : unit -> bool; (* manager checks for a request of termination *) extra : 'a; (* extra stuff to pass to the manager *) } module type PoolModel = sig (* this shall come from a Spawn.* model *) type process val spawn : int -> worker_id * process * CThread.thread_ic * out_channel (* this defines the main loop of the manager *) type extra val manager : extra cpanel -> worker_id * process * CThread.thread_ic * out_channel -> unit end module Make(Model : PoolModel) : sig type pool val create : Model.extra -> size:int -> pool val is_empty : pool -> bool val n_workers : pool -> int (* cancel signal *) val cancel : worker_id -> pool -> unit val cancel_all : pool -> unit (* camcel signal + true removal, the pool is empty afterward *) val destroy : pool -> unit (* The worker should call this function *) val worker_handshake : CThread.thread_ic -> out_channel -> unit end coq-8.6/stm/vernac_classifier.ml0000644000175000017500000002431113022274260015753 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* "par" ^ if solve then "solve" else "" ^ if abs then "abs" else "" | `No -> "" let string_of_vernac_type = function | VtUnknown -> "Unknown" | VtStartProof _ -> "StartProof" | VtSideff _ -> "Sideff" | VtQed VtKeep -> "Qed(keep)" | VtQed VtKeepAsAxiom -> "Qed(admitted)" | VtQed VtDrop -> "Qed(drop)" | VtProofStep { parallel; proof_block_detection } -> "ProofStep " ^ string_of_parallel parallel ^ Option.default "" proof_block_detection | VtProofMode s -> "ProofMode " ^ s | VtQuery (b,(id,route)) -> "Query " ^ string_of_in_script b ^ " report " ^ Stateid.to_string id ^ " route " ^ string_of_int route | VtStm ((VtFinish|VtJoinDocument|VtObserve _|VtPrintDag|VtWait), b) -> "Stm " ^ string_of_in_script b | VtStm (VtPG, b) -> "Stm PG " ^ string_of_in_script b | VtStm (VtBack _, b) -> "Stm Back " ^ string_of_in_script b let string_of_vernac_when = function | VtLater -> "Later" | VtNow -> "Now" let string_of_vernac_classification (t,w) = string_of_vernac_type t ^ " " ^ string_of_vernac_when w let classifiers = ref [] let declare_vernac_classifier (s : Vernacexpr.extend_name) (f : Genarg.raw_generic_argument list -> unit -> vernac_classification) = classifiers := !classifiers @ [s,f] let elide_part_of_script_and_now (a, _) = match a with | VtQuery (_,id) -> VtQuery (false,id), VtNow | VtStm (x, _) -> VtStm (x, false), VtNow | x -> x, VtNow let make_polymorphic (a, b as x) = match a with | VtStartProof (x, _, ids) -> VtStartProof (x, Doesn'tGuaranteeOpacity, ids), b | _ -> x let undo_classifier = ref (fun _ -> assert false) let set_undo_classifier f = undo_classifier := f let rec classify_vernac e = let static_classifier e = match e with (* PG compatibility *) | VernacUnsetOption (["Silent"]|["Undo"]|["Printing";"Depth"]) | VernacSetOption ((["Silent"]|["Undo"]|["Printing";"Depth"]),_) when !Flags.print_emacs -> VtStm(VtPG,false), VtNow (* Univ poly compatibility: we run it now, so that we can just * look at Flags in stm.ml. Would be nicer to have the stm * look at the entire dag to detect this option. *) | VernacSetOption (["Universe"; "Polymorphism"],_) | VernacUnsetOption (["Universe"; "Polymorphism"]) -> VtSideff [], VtNow (* Stm *) | VernacStm Finish -> VtStm (VtFinish, true), VtNow | VernacStm Wait -> VtStm (VtWait, true), VtNow | VernacStm JoinDocument -> VtStm (VtJoinDocument, true), VtNow | VernacStm PrintDag -> VtStm (VtPrintDag, true), VtNow | VernacStm (Observe id) -> VtStm (VtObserve id, true), VtNow | VernacStm (Command x) -> elide_part_of_script_and_now (classify_vernac x) | VernacStm (PGLast x) -> fst (classify_vernac x), VtNow (* Nested vernac exprs *) | VernacProgram e -> classify_vernac e | VernacLocal (_,e) -> classify_vernac e | VernacPolymorphic (b, e) -> if b || Flags.is_universe_polymorphism () (* Ok or not? *) then make_polymorphic (classify_vernac e) else classify_vernac e | VernacTimeout (_,e) -> classify_vernac e | VernacTime (_,e) | VernacRedirect (_, (_,e)) -> classify_vernac e | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match classify_vernac e with | ( VtQuery _ | VtProofStep _ | VtSideff _ | VtStm _ | VtProofMode _ ), _ as x -> x | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, VtNow | (VtStartProof _ | VtUnknown), _ -> VtUnknown, VtNow) (* Qed *) | VernacAbort _ -> VtQed VtDrop, VtLater | VernacEndProof Admitted -> VtQed VtKeepAsAxiom, VtLater | VernacEndProof _ | VernacExactProof _ -> VtQed VtKeep, VtLater (* Query *) | VernacShow _ | VernacPrint _ | VernacSearch _ | VernacLocate _ | VernacCheckMayEval _ -> VtQuery (true,(Stateid.dummy,Feedback.default_route)), VtLater (* ProofStep *) | VernacProof _ | VernacFocus _ | VernacUnfocus | VernacSubproof _ | VernacCheckGuard | VernacUnfocused | VernacSolveExistential _ -> VtProofStep { parallel = `No; proof_block_detection = None }, VtLater | VernacBullet _ -> VtProofStep { parallel = `No; proof_block_detection = Some "bullet" }, VtLater | VernacEndSubproof -> VtProofStep { parallel = `No; proof_block_detection = Some "curly" }, VtLater (* Options changing parser *) | VernacUnsetOption (["Default";"Proof";"Using"]) | VernacSetOption (["Default";"Proof";"Using"],_) -> VtSideff [], VtNow (* StartProof *) | VernacDefinition ( (Some Decl_kinds.Discharge,Decl_kinds.Definition),((_,i),_),ProveBody _) -> VtStartProof(default_proof_mode (),Doesn'tGuaranteeOpacity,[i]), VtLater | VernacDefinition (_,((_,i),_),ProveBody _) -> VtStartProof(default_proof_mode (),GuaranteesOpacity,[i]), VtLater | VernacStartTheoremProof (_,l,_) -> let ids = CList.map_filter (function (Some ((_,i),pl), _) -> Some i | _ -> None) l in VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater | VernacGoal _ -> VtStartProof (default_proof_mode (),GuaranteesOpacity,[]), VtLater | VernacFixpoint (_,l) -> let ids, open_proof = List.fold_left (fun (l,b) ((((_,id),_),_,_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof then VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater else VtSideff ids, VtLater | VernacCoFixpoint (_,l) -> let ids, open_proof = List.fold_left (fun (l,b) ((((_,id),_),_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof then VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater else VtSideff ids, VtLater (* Sideff: apply to all open branches. usually run on master only *) | VernacAssumption (_,_,l) -> let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map (fun (id, _) -> snd id) l) l) in VtSideff ids, VtLater | VernacDefinition (_,((_,id),_),DefineBody _) -> VtSideff [id], VtLater | VernacInductive (_,_,l) -> let ids = List.map (fun (((_,((_,id),_)),_,_,_,cl),_) -> id :: match cl with | Constructors l -> List.map (fun (_,((_,id),_)) -> id) l | RecordDecl (oid,l) -> (match oid with Some (_,x) -> [x] | _ -> []) @ CList.map_filter (function | ((_,AssumExpr((_,Names.Name n),_)),_),_ -> Some n | _ -> None) l) l in VtSideff (List.flatten ids), VtLater | VernacScheme l -> let ids = List.map snd (CList.map_filter (fun (x,_) -> x) l) in VtSideff ids, VtLater | VernacCombinedScheme ((_,id),_) -> VtSideff [id], VtLater | VernacBeginSection (_,id) -> VtSideff [id], VtLater | VernacUniverse _ | VernacConstraint _ | VernacCanonical _ | VernacCoercion _ | VernacIdentityCoercion _ | VernacAddLoadPath _ | VernacRemoveLoadPath _ | VernacAddMLPath _ | VernacChdir _ | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _ | VernacDeclareImplicits _ | VernacArguments _ | VernacArgumentsScope _ | VernacReserve _ | VernacGeneralizable _ | VernacSetOpacity _ | VernacSetStrategy _ | VernacUnsetOption _ | VernacSetOption _ | VernacSetAppendOption _ | VernacAddOption _ | VernacRemoveOption _ | VernacMemOption _ | VernacPrintOption _ | VernacGlobalCheck _ | VernacDeclareReduction _ | VernacDeclareClass _ | VernacDeclareInstances _ | VernacRegister _ | VernacNameSectionHypSet _ | VernacComments _ -> VtSideff [], VtLater (* Who knows *) | VernacLoad _ -> VtSideff [], VtNow (* (Local) Notations have to disappear *) | VernacEndSegment _ -> VtSideff [], VtNow (* Modules with parameters have to be executed: can import notations *) | VernacDeclareModule (exp,(_,id),bl,_) | VernacDefineModule (exp,(_,id),bl,_,_) -> VtSideff [id], if bl = [] && exp = None then VtLater else VtNow | VernacDeclareModuleType ((_,id),bl,_,_) -> VtSideff [id], if bl = [] then VtLater else VtNow (* These commands alter the parser *) | VernacOpenCloseScope _ | VernacDelimiters _ | VernacBindScope _ | VernacInfix _ | VernacNotation _ | VernacNotationAddFormat _ | VernacSyntaxExtension _ | VernacSyntacticDefinition _ | VernacRequire _ | VernacImport _ | VernacInclude _ | VernacDeclareMLModule _ | VernacContext _ (* TASSI: unsure *) | VernacProofMode _ (* These are ambiguous *) | VernacInstance _ -> VtUnknown, VtNow (* Stm will install a new classifier to handle these *) | VernacBack _ | VernacAbortAll | VernacUndoTo _ | VernacUndo _ | VernacResetName _ | VernacResetInitial | VernacBacktrack _ | VernacBackTo _ | VernacRestart -> !undo_classifier e (* What are these? *) | VernacToplevelControl _ | VernacRestoreState _ | VernacWriteState _ -> VtUnknown, VtNow | VernacError _ -> assert false (* Plugins should classify their commands *) | VernacExtend (s,l) -> try List.assoc s !classifiers l () with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)) in let res = static_classifier e in if Flags.is_universe_polymorphism () then make_polymorphic res else res let classify_as_query = VtQuery (true,(Stateid.dummy,Feedback.default_route)), VtLater let classify_as_sideeff = VtSideff [], VtLater let classify_as_proofstep = VtProofStep { parallel = `No; proof_block_detection = None}, VtLater coq-8.6/stm/coqworkmgrApi.mli0000644000175000017500000000252413022274260015271 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* unit (* blocking *) val get : int -> int (* not blocking *) val tryget : int -> int option val giveback : int -> unit (* Low level *) type request = | Hello of Flags.priority | Get of int | TryGet of int | GiveBack of int | Ping type response = | Tokens of int | Noluck | Pong of int * int * int (* cur, max, pid *) val connect : string -> Unix.file_descr option exception ParseError (* Intended to be used with input_line and output_string *) val parse_request : string -> request val parse_response : string -> response val print_request : request -> string val print_response : response -> string coq-8.6/stm/proofBlockDelimiter.mli0000644000175000017500000000343413022274260016404 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Goal.goal -> Goal.goal list -> bool val is_focused_goal_simple : Stateid.t -> [ `Simple of Goal.goal list | `Not ] type 'a until = [ `Stop | `Found of Stm.static_block_declaration | `Cont of 'a ] (* Simpler function to crawl the document backward to detect the block. * ?init is the entry point of the document view if not given *) val crawl : Stm.document_view -> ?init:Stm.document_node option -> ('a -> Stm.document_node -> 'a until) -> 'a -> Stm.static_block_declaration option (* Dummy value for static_block_declaration when no real value is needed *) val unit_val : Stm.DynBlockData.t (* Bullets *) val of_bullet_val : Vernacexpr.bullet -> Stm.DynBlockData.t val to_bullet_val : Stm.DynBlockData.t -> Vernacexpr.bullet coq-8.6/tactics/0000755000175000017500000000000013022274260012565 5ustar garesgarescoq-8.6/tactics/tactics.ml0000644000175000017500000060220213022274260014553 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* user_err_loc (Loc.ghost, "", print_retype_error e) open Goptions (* Option for 8.2 compatibility *) let dependent_propositions_elimination = ref true let use_dependent_propositions_elimination () = !dependent_propositions_elimination && Flags.version_strictly_greater Flags.V8_2 let _ = declare_bool_option { optsync = true; optdepr = false; optname = "dependent-propositions-elimination tactic"; optkey = ["Dependent";"Propositions";"Elimination"]; optread = (fun () -> !dependent_propositions_elimination) ; optwrite = (fun b -> dependent_propositions_elimination := b) } let _ = declare_bool_option { optsync = true; optdepr = false; optname = "trigger bugged context matching compatibility"; optkey = ["Tactic";"Compat";"Context"]; optread = (fun () -> !Flags.tactic_context_compat) ; optwrite = (fun b -> Flags.tactic_context_compat := b) } let apply_solve_class_goals = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = true; Goptions.optname = "Perform typeclass resolution on apply-generated subgoals."; Goptions.optkey = ["Typeclass";"Resolution";"After";"Apply"]; Goptions.optread = (fun () -> !apply_solve_class_goals); Goptions.optwrite = (fun a -> apply_solve_class_goals:=a); } let clear_hyp_by_default = ref false let use_clear_hyp_by_default () = !clear_hyp_by_default let _ = declare_bool_option { optsync = true; optdepr = false; optname = "default clearing of hypotheses after use"; optkey = ["Default";"Clearing";"Used";"Hypotheses"]; optread = (fun () -> !clear_hyp_by_default) ; optwrite = (fun b -> clear_hyp_by_default := b) } (* Compatibility option useful in developments using apply intensively in ltac code *) let universal_lemma_under_conjunctions = ref false let accept_universal_lemma_under_conjunctions () = !universal_lemma_under_conjunctions let _ = declare_bool_option { optsync = true; optdepr = false; optname = "trivial unification in tactics applying under conjunctions"; optkey = ["Universal";"Lemma";"Under";"Conjunction"]; optread = (fun () -> !universal_lemma_under_conjunctions) ; optwrite = (fun b -> universal_lemma_under_conjunctions := b) } (* Shrinking of abstract proofs. *) let shrink_abstract = ref true let _ = declare_bool_option { optsync = true; optdepr = true; optname = "shrinking of abstracted proofs"; optkey = ["Shrink"; "Abstract"]; optread = (fun () -> !shrink_abstract) ; optwrite = (fun b -> shrink_abstract := b) } (* The following boolean governs what "intros []" do on examples such as "forall x:nat*nat, x=x"; if true, it behaves as "intros [? ?]"; if false, it behaves as "intro H; case H; clear H" for fresh H. Kept as false for compatibility. *) let bracketing_last_or_and_intro_pattern = ref true let use_bracketing_last_or_and_intro_pattern () = !bracketing_last_or_and_intro_pattern && Flags.version_strictly_greater Flags.V8_4 let _ = declare_bool_option { optsync = true; optdepr = false; optname = "bracketing last or-and introduction pattern"; optkey = ["Bracketing";"Last";"Introduction";"Pattern"]; optread = (fun () -> !bracketing_last_or_and_intro_pattern); optwrite = (fun b -> bracketing_last_or_and_intro_pattern := b) } (*********************************************) (* Tactics *) (*********************************************) (******************************************) (* Primitive tactics *) (******************************************) (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) let unsafe_intro env store decl b = let open Context.Named.Declaration in Refine.refine ~unsafe:true { run = begin fun sigma -> let ctx = named_context_val env in let nctx = push_named_context_val decl ctx in let inst = List.map (mkVar % get_id) (named_context env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar (get_id decl)) b in let Sigma (ev, sigma, p) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in Sigma (mkNamedLambda_or_LetIn decl ev, sigma, p) end } let introduction ?(check=true) id = let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let hyps = named_context_val (Proofview.Goal.env gl) in let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in let () = if check && mem_named_context_val id hyps then errorlabstrm "Tactics.introduction" (str "Variable " ++ pr_id id ++ str " is already declared.") in match kind_of_term (whd_evar sigma concl) with | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b | _ -> raise (RefinerError IntroNeedsProduct) end } let refine = Tacmach.refine let convert_concl ?(check=true) ty k = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.raw_concl gl in Refine.refine ~unsafe:true { run = begin fun sigma -> let Sigma ((), sigma, p) = if check then begin let sigma = Sigma.to_evar_map sigma in ignore (Typing.unsafe_type_of env sigma ty); let sigma,b = Reductionops.infer_conv env sigma ty conclty in if not b then error "Not convertible."; Sigma.Unsafe.of_pair ((), sigma) end else Sigma.here () sigma in let Sigma (x, sigma, q) = Evarutil.new_evar env sigma ~principal:true ~store ty in let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in Sigma (ans, sigma, p +> q) end } end } let convert_hyp ?(check=true) d = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty end } end } let convert_concl_no_check = convert_concl ~check:false let convert_hyp_no_check = convert_hyp ~check:false let convert_gen pb x y = Proofview.Goal.enter { enter = begin fun gl -> try let sigma, b = Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y in if b then Proofview.Unsafe.tclEVARS sigma else Tacticals.New.tclFAIL 0 (str "Not convertible") with (* Reduction.NotConvertible *) _ -> (** FIXME: Sometimes an anomaly is raised from conversion *) Tacticals.New.tclFAIL 0 (str "Not convertible") end } let convert x y = convert_gen Reduction.CONV x y let convert_leq x y = convert_gen Reduction.CUMUL x y let clear_dependency_msg env sigma id = function | Evarutil.OccurHypInSimpleClause None -> pr_id id ++ str " is used in conclusion." | Evarutil.OccurHypInSimpleClause (Some id') -> pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str"." | Evarutil.EvarTypingBreak ev -> str "Cannot remove " ++ pr_id id ++ strbrk " without breaking the typing of " ++ Printer.pr_existential env sigma ev ++ str"." let error_clear_dependency env sigma id err = errorlabstrm "" (clear_dependency_msg env sigma id err) let replacing_dependency_msg env sigma id = function | Evarutil.OccurHypInSimpleClause None -> str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion." | Evarutil.OccurHypInSimpleClause (Some id') -> str "Cannot change " ++ pr_id id ++ strbrk ", it is used in hypothesis " ++ pr_id id' ++ str"." | Evarutil.EvarTypingBreak ev -> str "Cannot change " ++ pr_id id ++ strbrk " without breaking the typing of " ++ Printer.pr_existential env sigma ev ++ str"." let error_replacing_dependency env sigma id err = errorlabstrm "" (replacing_dependency_msg env sigma id err) (* This tactic enables the user to remove hypotheses from the signature. * Some care is taken to prevent him from removing variables that are * subsequently used in other hypotheses or in the conclusion of the * goal. *) let clear_gen fail = function | [] -> Proofview.tclUNIT () | ids -> Proofview.Goal.s_enter { s_enter = begin fun gl -> let ids = List.fold_right Id.Set.add ids Id.Set.empty in (** clear_hyps_in_evi does not require nf terms *) let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let evdref = ref sigma in let (hyps, concl) = try clear_hyps_in_evi env evdref (named_context_val env) concl ids with Evarutil.ClearDependencyError (id,err) -> fail env sigma id err in let env = reset_with_named_context hyps env in let tac = Refine.refine ~unsafe:true { run = fun sigma -> Evarutil.new_evar env sigma ~principal:true concl } in Sigma.Unsafe.of_pair (tac, !evdref) end } let clear ids = clear_gen error_clear_dependency ids let clear_for_replacing ids = clear_gen error_replacing_dependency ids let apply_clear_request clear_flag dft c = let check_isvar c = if not (isVar c) then error "keep/clear modifiers apply only to hypothesis names." in let doclear = match clear_flag with | None -> dft && isVar c | Some true -> check_isvar c; true | Some false -> false in if doclear then clear [destVar c] else Tacticals.New.tclIDTAC (* Moving hypotheses *) let move_hyp id dest = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let ty = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in let sign = named_context_val env in let sign' = move_hyp_in_named_context id dest sign in let env = reset_with_named_context sign' env in Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty end } end } (* Renaming hypotheses *) let rename_hyp repl = let open Context.Named.Declaration in let fold accu (src, dst) = match accu with | None -> None | Some (srcs, dsts) -> if Id.Set.mem src srcs then None else if Id.Set.mem dst dsts then None else let srcs = Id.Set.add src srcs in let dsts = Id.Set.add dst dsts in Some (srcs, dsts) in let init = Some (Id.Set.empty, Id.Set.empty) in let dom = List.fold_left fold init repl in match dom with | None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping") | Some (src, dst) -> Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in let concl = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in (** Check that we do not mess variables *) let fold accu decl = Id.Set.add (get_id decl) accu in let vars = List.fold_left fold Id.Set.empty hyps in let () = if not (Id.Set.subset src vars) then let hyp = Id.Set.choose (Id.Set.diff src vars) in raise (RefinerError (NoSuchHyp hyp)) in let mods = Id.Set.diff vars src in let () = try let elt = Id.Set.choose (Id.Set.inter dst mods) in CErrors.errorlabstrm "" (pr_id elt ++ str " is already used") with Not_found -> () in (** All is well *) let make_subst (src, dst) = (src, mkVar dst) in let subst = List.map make_subst repl in let subst c = Vars.replace_vars subst c in let map decl = decl |> map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) |> map_constr subst in let nhyps = List.map map hyps in let nconcl = subst concl in let nctx = Environ.val_of_named_context nhyps in let instance = List.map (mkVar % get_id) hyps in Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance end } end } (**************************************************************) (* Fresh names *) (**************************************************************) let fresh_id_in_env avoid id env = next_ident_away_in_goal id (avoid@ids_of_named_context (named_context env)) let fresh_id avoid id gl = fresh_id_in_env avoid id (pf_env gl) let new_fresh_id avoid id gl = fresh_id_in_env avoid id (Proofview.Goal.env gl) let id_of_name_with_default id = function | Anonymous -> id | Name id -> id let default_id_of_sort s = if Sorts.is_small s then default_small_ident else default_type_ident let default_id env sigma decl = let open Context.Rel.Declaration in match decl with | LocalAssum (name,t) -> let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in id_of_name_with_default dft name | LocalDef (name,b,_) -> id_of_name_using_hdchar env b name (* Non primitive introduction tactics are treated by intro_then_gen There is possibly renaming, with possibly names to avoid and possibly a move to do after the introduction *) type name_flag = | NamingAvoid of Id.t list | NamingBasedOn of Id.t * Id.t list | NamingMustBe of Loc.t * Id.t let naming_of_name = function | Anonymous -> NamingAvoid [] | Name id -> NamingMustBe (dloc,id) let find_name mayrepl decl naming gl = match naming with | NamingAvoid idl -> (* this case must be compatible with [find_intro_names] below. *) let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in new_fresh_id idl (default_id env sigma decl) gl | NamingBasedOn (id,idl) -> new_fresh_id idl id gl | NamingMustBe (loc,id) -> (* When name is given, we allow to hide a global name *) let ids_of_hyps = Tacmach.New.pf_ids_of_hyps gl in let id' = next_ident_away id ids_of_hyps in if not mayrepl && not (Id.equal id' id) then user_err_loc (loc,"",pr_id id ++ str" is already used."); id (**************************************************************) (* Cut rule *) (**************************************************************) let assert_before_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENLAST (Proofview.V82.tactic (fun gl -> try Tacmach.internal_cut b id t gl with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) end } let assert_before_gen b naming t = assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ()) let assert_before na = assert_before_gen false (naming_of_name na) let assert_before_replacing id = assert_before_gen true (NamingMustBe (dloc,id)) let assert_after_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENFIRST (Proofview.V82.tactic (fun gl -> try Tacmach.internal_cut_rev b id t gl with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) end } let assert_after_gen b naming t = assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ())) let assert_after na = assert_after_gen false (naming_of_name na) let assert_after_replacing id = assert_after_gen true (NamingMustBe (dloc,id)) (**************************************************************) (* Fixpoints and CoFixpoints *) (**************************************************************) let rec mk_holes : type r s. _ -> r Sigma.t -> (s, r) Sigma.le -> _ -> (_, s) Sigma.sigma = fun env sigma p -> function | [] -> Sigma ([], sigma, p) | arg :: rem -> let Sigma (arg, sigma, q) = Evarutil.new_evar env sigma arg in let Sigma (rem, sigma, r) = mk_holes env sigma (p +> q) rem in Sigma (arg :: rem, sigma, r) let rec check_mutind env sigma k cl = match kind_of_term (strip_outer_cast cl) with | Prod (na, c1, b) -> if Int.equal k 1 then try let ((sp, _), u), _ = find_inductive env sigma c1 in (sp, u) with Not_found -> error "Cannot do a fixpoint on a non inductive type." else let open Context.Rel.Declaration in check_mutind (push_rel (LocalAssum (na, c1)) env) sigma (pred k) b | _ -> error "Not enough products." (* Refine as a fixpoint *) let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let (sp, u) = check_mutind env sigma n concl in let firsts, lasts = List.chop j rest in let all = firsts @ (f, n, concl) :: lasts in let rec mk_sign sign = function | [] -> sign | (f, n, ar) :: oth -> let open Context.Named.Declaration in let (sp', u') = check_mutind env sigma n ar in if not (eq_mind sp sp') then error "Fixpoints should be on the same mutual inductive declaration."; if mem_named_context_val f sign then errorlabstrm "Logic.prim_refiner" (str "Name " ++ pr_id f ++ str " already used in the environment"); mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine { run = begin fun sigma -> let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl (List.map pi3 all) in let ids = List.map pi1 all in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in let funnames = Array.of_list (List.map (fun i -> Name i) ids) in let typarray = Array.of_list (List.map pi3 all) in let bodies = Array.of_list evs in let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in Sigma (oterm, sigma, p) end } end } let fix ido n = match ido with | None -> Proofview.Goal.enter { enter = begin fun gl -> let name = Pfedit.get_current_proof_name () in let id = new_fresh_id [] name gl in mutual_fix id n [] 0 end } | Some id -> mutual_fix id n [] 0 let rec check_is_mutcoind env sigma cl = let b = whd_all env sigma cl in match kind_of_term b with | Prod (na, c1, b) -> let open Context.Rel.Declaration in check_is_mutcoind (push_rel (LocalAssum (na,c1)) env) sigma b | _ -> try let _ = find_coinductive env sigma b in () with Not_found -> error "All methods must construct elements in coinductive types." (* Refine as a cofixpoint *) let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let firsts,lasts = List.chop j others in let all = firsts @ (f, concl) :: lasts in List.iter (fun (_, c) -> check_is_mutcoind env sigma c) all; let rec mk_sign sign = function | [] -> sign | (f, ar) :: oth -> let open Context.Named.Declaration in if mem_named_context_val f sign then error "Name already used in the environment."; mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine { run = begin fun sigma -> let (ids, types) = List.split all in let Sigma (evs, sigma, p) = mk_holes nenv sigma Sigma.refl types in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in let funnames = Array.of_list (List.map (fun i -> Name i) ids) in let typarray = Array.of_list types in let bodies = Array.of_list evs in let oterm = Term.mkCoFix (0, (funnames, typarray, bodies)) in Sigma (oterm, sigma, p) end } end } let cofix ido = match ido with | None -> Proofview.Goal.enter { enter = begin fun gl -> let name = Pfedit.get_current_proof_name () in let id = new_fresh_id [] name gl in mutual_cofix id [] 0 end } | Some id -> mutual_cofix id [] 0 (**************************************************************) (* Reduction and conversion tactics *) (**************************************************************) type tactic_reduction = env -> evar_map -> constr -> constr let pf_reduce_decl redfun where decl gl = let open Context.Named.Declaration in let redfun' = Tacmach.New.pf_apply redfun gl in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); LocalAssum (id,redfun' ty) | LocalDef (id,b,ty) -> let b' = if where != InHypTypeOnly then redfun' b else b in let ty' = if where != InHypValueOnly then redfun' ty else ty in LocalDef (id,b',ty') (* Possibly equip a reduction with the occurrences mentioned in an occurrence clause *) let error_illegal_clause () = error "\"at\" clause not supported in presence of an occurrence clause." let error_illegal_non_atomic_clause () = error "\"at\" clause not supported in presence of a non atomic \"in\" clause." let error_occurrences_not_unsupported () = error "Occurrences not supported for this reduction tactic." let bind_change_occurrences occs = function | None -> None | Some c -> Some (Redexpr.out_with_occurrences (occs,c)) let bind_red_expr_occurrences occs nbcl redexp = let has_at_clause = function | Unfold l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l | Pattern l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l | Simpl (_,Some (occl,_)) -> occl != AllOccurrences | _ -> false in if occs == AllOccurrences then if nbcl > 1 && has_at_clause redexp then error_illegal_non_atomic_clause () else redexp else match redexp with | Unfold (_::_::_) -> error_illegal_clause () | Unfold [(occl,c)] -> if occl != AllOccurrences then error_illegal_clause () else Unfold [(occs,c)] | Pattern (_::_::_) -> error_illegal_clause () | Pattern [(occl,c)] -> if occl != AllOccurrences then error_illegal_clause () else Pattern [(occs,c)] | Simpl (f,Some (occl,c)) -> if occl != AllOccurrences then error_illegal_clause () else Simpl (f,Some (occs,c)) | CbvVm (Some (occl,c)) -> if occl != AllOccurrences then error_illegal_clause () else CbvVm (Some (occs,c)) | CbvNative (Some (occl,c)) -> if occl != AllOccurrences then error_illegal_clause () else CbvNative (Some (occs,c)) | Red _ | Hnf | Cbv _ | Lazy _ | Cbn _ | ExtraRedExpr _ | Fold _ | Simpl (_,None) | CbvVm None | CbvNative None -> error_occurrences_not_unsupported () | Unfold [] | Pattern [] -> assert false (* The following two tactics apply an arbitrary reduction function either to the conclusion or to a certain hypothesis *) let reduct_in_concl (redfun,sty) = Proofview.Goal.nf_enter { enter = begin fun gl -> convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty end } let reduct_in_hyp ?(check=false) redfun (id,where) = Proofview.Goal.nf_enter { enter = begin fun gl -> convert_hyp ~check (pf_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl) end } let revert_cast (redfun,kind as r) = if kind == DEFAULTcast then (redfun,REVERTcast) else r let reduct_option ?(check=false) redfun = function | Some id -> reduct_in_hyp ~check (fst redfun) id | None -> reduct_in_concl (revert_cast redfun) (** Tactic reduction modulo evars (for universes essentially) *) let pf_e_reduce_decl redfun where decl gl = let open Context.Named.Declaration in let sigma = Proofview.Goal.sigma gl in let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma c in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = redfun sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> let Sigma (b', sigma, p) = if where != InHypTypeOnly then redfun sigma b else Sigma.here b sigma in let Sigma (ty', sigma, q) = if where != InHypValueOnly then redfun sigma ty else Sigma.here ty sigma in Sigma (LocalDef (id, b', ty'), sigma, p +> q) let e_reduct_in_concl ~check (redfun, sty) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in Sigma (convert_concl ~check c' sty, sigma, p) end } let e_reduct_in_hyp ?(check=false) redfun (id, where) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let Sigma (decl', sigma, p) = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in Sigma (convert_hyp ~check decl', sigma, p) end } let e_reduct_option ?(check=false) redfun = function | Some id -> e_reduct_in_hyp ~check (fst redfun) id | None -> e_reduct_in_concl ~check (revert_cast redfun) (** Versions with evars to maintain the unification of universes resulting from conversions. *) let e_change_in_concl (redfun,sty) = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in Sigma (convert_concl_no_check c sty, sigma, p) end } let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = let open Context.Named.Declaration in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> let Sigma (b', sigma, p) = if where != InHypTypeOnly then (redfun true).e_redfun env sigma b else Sigma.here b sigma in let Sigma (ty', sigma, q) = if where != InHypValueOnly then (redfun false).e_redfun env sigma ty else Sigma.here ty sigma in Sigma (LocalDef (id,b',ty'), sigma, p +> q) let e_change_in_hyp redfun (id,where) = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in let Sigma (c, sigma, p) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in Sigma (convert_hyp c, sigma, p) end } type change_arg = Pattern.patvar_map -> constr Sigma.run let make_change_arg c pats = { run = fun sigma -> Sigma.here (replace_vars (Id.Map.bindings pats) c) sigma } 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 let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in if not b then if isSort (whd_all env sigma t1) && isSort (whd_all env sigma t2) then (mayneedglobalcheck := true; sigma) else errorlabstrm "convert-check-hyp" (str "Types are incompatible.") else sigma end else if not (isSort (whd_all 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 = { e_redfun = begin fun env sigma c -> let Sigma (t', sigma, p) = t.run sigma in let sigma = Sigma.to_evar_map sigma in 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.Unsafe.of_pair (t', sigma) end } (* Use cumulativity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb deep t where = { e_redfun = begin fun env sigma c -> let mayneedglobalcheck = ref false in let Sigma (c, sigma, p) = match where with | None -> (change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty)).e_redfun env sigma c | Some occl -> (e_contextually false occl (fun subst -> change_and_check Reduction.CONV mayneedglobalcheck true (t subst))).e_redfun env sigma c in if !mayneedglobalcheck then begin try ignore (Typing.unsafe_type_of env (Sigma.to_evar_map sigma) c) with e when catchable_exception e -> error "Replacement would lead to an ill-typed term." end; Sigma (c, sigma, p) end } let change_in_concl occl t = e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) let change_in_hyp occl t id = e_change_in_hyp (fun x -> change_on_subterm Reduction.CONV x t occl) id let change_option occl t = function | Some id -> change_in_hyp occl t id | None -> change_in_concl occl t let change chg c cls = Proofview.Goal.enter { enter = begin fun gl -> let cls = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in Tacticals.New.tclMAP (function | OnHyp (id,occs,where) -> change_option (bind_change_occurrences occs chg) c (Some (id,where)) | OnConcl occs -> change_option (bind_change_occurrences occs chg) c None) cls end } let change_concl t = change_in_concl None (make_change_arg t) (* Pour usage interne (le niveau User est pris en compte par reduce) *) let red_in_concl = reduct_in_concl (red_product,REVERTcast) let red_in_hyp = reduct_in_hyp red_product let red_option = reduct_option (red_product,REVERTcast) let hnf_in_concl = reduct_in_concl (hnf_constr,REVERTcast) let hnf_in_hyp = reduct_in_hyp hnf_constr let hnf_option = reduct_option (hnf_constr,REVERTcast) let simpl_in_concl = reduct_in_concl (simpl,REVERTcast) let simpl_in_hyp = reduct_in_hyp simpl let simpl_option = reduct_option (simpl,REVERTcast) let normalise_in_concl = reduct_in_concl (compute,REVERTcast) let normalise_in_hyp = reduct_in_hyp compute let normalise_option = reduct_option (compute,REVERTcast) let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast) let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast) (* The main reduction function *) let reduction_clause redexp cl = let nbcl = List.length cl in List.map (function | OnHyp (id,occs,where) -> (Some (id,where), bind_red_expr_occurrences occs nbcl redexp) | OnConcl occs -> (None, bind_red_expr_occurrences occs nbcl redexp)) cl let reduce redexp cl = let trace () = Pp.(hov 2 (Pptactic.pr_atomic_tactic (Global.env()) (TacReduce (redexp,cl)))) in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter { enter = begin fun gl -> let cl' = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in let redexps = reduction_clause redexp cl' in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in Tacticals.New.tclMAP (fun (where,redexp) -> e_reduct_option ~check (Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp) where) redexps end } end (* Unfolding occurrences of a constant *) let unfold_constr = function | ConstRef sp -> unfold_in_concl [AllOccurrences,EvalConstRef sp] | VarRef id -> unfold_in_concl [AllOccurrences,EvalVarRef id] | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.") (*******************************************) (* Introduction tactics *) (*******************************************) (* Returns the names that would be created by intros, without doing intros. This function is supposed to be compatible with an iteration of [find_name] above. As [default_id] checks the sort of the type to build hyp names, we maintain an environment to be able to type dependent hyps. *) let find_intro_names ctxt gl = let _, res = List.fold_right (fun decl acc -> let env,idl = acc in let name = fresh_id idl (default_id env gl.sigma decl) gl in let newenv = push_rel decl env in (newenv,(name::idl))) ctxt (pf_env gl , []) in List.rev res let build_intro_tac id dest tac = match dest with | MoveLast -> Tacticals.New.tclTHEN (introduction id) (tac id) | dest -> Tacticals.New.tclTHENLIST [introduction id; move_hyp id dest; tac id] let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let concl = nf_evar (Tacmach.New.project gl) concl in match kind_of_term concl with | Prod (name,t,u) when not dep_flag || (dependent (mkRel 1) u) -> let name = find_name false (LocalAssum (name,t)) name_flag gl in build_intro_tac name move_flag tac | LetIn (name,b,t,u) when not dep_flag || (dependent (mkRel 1) u) -> let name = find_name false (LocalDef (name,b,t)) name_flag gl in build_intro_tac name move_flag tac | _ -> begin if not force_flag then Proofview.tclZERO (RefinerError IntroNeedsProduct) (* Note: red_in_concl includes betaiotazeta and this was like *) (* this since at least V6.3 (a pity *) (* that intro do betaiotazeta only when reduction is needed; and *) (* probably also a pity that intro does zeta *) else Proofview.tclUNIT () end <*> Proofview.tclORELSE (Tacticals.New.tclTHEN hnf_in_concl (intro_then_gen name_flag move_flag false dep_flag tac)) begin function (e, info) -> match e with | RefinerError IntroNeedsProduct -> Tacticals.New.tclZEROMSG (str "No product even after head-reduction.") | e -> Proofview.tclZERO ~info e end end } let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ()) let intro_mustbe_force id = intro_gen (NamingMustBe (dloc,id)) MoveLast true false let intro_using id = intro_gen (NamingBasedOn (id,[])) MoveLast false false let intro_then = intro_then_gen (NamingAvoid []) MoveLast false false let intro = intro_gen (NamingAvoid []) MoveLast false false let introf = intro_gen (NamingAvoid []) MoveLast true false let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false let intro_move_avoid idopt avoid hto = match idopt with | None -> intro_gen (NamingAvoid avoid) hto true false | Some id -> intro_gen (NamingMustBe (dloc,id)) hto true false let intro_move idopt hto = intro_move_avoid idopt [] hto (**** Multiple introduction tactics ****) let rec intros_using = function | [] -> Proofview.tclUNIT() | str::l -> Tacticals.New.tclTHEN (intro_using str) (intros_using l) let intros = Tacticals.New.tclREPEAT intro let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = let rec aux n ids = (* Note: we always use the bound when there is one for "*" and "**" *) if (match bound with None -> true | Some (_,p) -> n < p) then Proofview.tclORELSE begin intro_then_gen name_flag move_flag false dep_flag (fun id -> aux (n+1) (id::ids)) end begin function (e, info) -> match e with | RefinerError IntroNeedsProduct -> tac ids | e -> Proofview.tclZERO ~info e end else tac ids in aux n [] let get_next_hyp_position id gl = let open Context.Named.Declaration in let rec aux = function | [] -> raise (RefinerError (NoSuchHyp id)) | decl :: right -> if Id.equal (get_id decl) id then match right with decl::_ -> MoveBefore (get_id decl) | [] -> MoveLast else aux right in aux (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let get_previous_hyp_position id gl = let open Context.Named.Declaration in let rec aux dest = function | [] -> raise (RefinerError (NoSuchHyp id)) | decl :: right -> let hyp = get_id decl in if Id.equal hyp id then dest else aux (MoveAfter hyp) right in aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let intro_replacing id = Proofview.Goal.enter { enter = begin fun gl -> let next_hyp = get_next_hyp_position id gl in Tacticals.New.tclTHENLIST [ clear_for_replacing [id]; introduction id; move_hyp id next_hyp; ] end } (* We have e.g. [x, y, y', x', y'' |- forall y y' y'', G] and want to reintroduce y, y,' y''. Note that we have to clear y, y' and y'' before introducing y because y' or y'' can e.g. depend on old y. *) (* This version assumes that replacement is actually possible *) (* (ids given in the introduction order) *) (* We keep a sub-optimality in cleaing for compatibility with *) (* the behavior of inversion *) let intros_possibly_replacing ids = let suboptimal = true in Proofview.Goal.enter { enter = begin fun gl -> let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN (Tacticals.New.tclMAP (fun id -> Tacticals.New.tclTRY (clear_for_replacing [id])) (if suboptimal then ids else List.rev ids)) (Tacticals.New.tclMAP (fun (id,pos) -> Tacticals.New.tclORELSE (intro_move (Some id) pos) (intro_using id)) posl) end } (* This version assumes that replacement is actually possible *) let intros_replacing ids = Proofview.Goal.enter { enter = begin fun gl -> let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN (clear_for_replacing ids) (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl) end } (* User-level introduction tactics *) let lookup_hypothesis_as_renamed env ccl = function | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n | NamedHyp id -> Detyping.lookup_name_as_displayed env ccl id let lookup_hypothesis_as_renamed_gen red h gl = let env = Proofview.Goal.env gl in let rec aux ccl = match lookup_hypothesis_as_renamed env ccl h with | None when red -> let (redfun, _) = Redexpr.reduction_of_red_expr env (Red true) in let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) ccl in aux c | x -> x in try aux (Proofview.Goal.concl gl) with Redelimination -> None let is_quantified_hypothesis id gl = match lookup_hypothesis_as_renamed_gen false (NamedHyp id) gl with | Some _ -> true | None -> false let msg_quantified_hypothesis = function | NamedHyp id -> str "quantified hypothesis named " ++ pr_id id | AnonHyp n -> pr_nth n ++ str " non dependent hypothesis" let depth_of_quantified_hypothesis red h gl = match lookup_hypothesis_as_renamed_gen red h gl with | Some depth -> depth | None -> errorlabstrm "lookup_quantified_hypothesis" (str "No " ++ msg_quantified_hypothesis h ++ strbrk " in current goal" ++ (if red then strbrk " even after head-reduction" else mt ()) ++ str".") let intros_until_gen red h = Proofview.Goal.nf_enter { enter = begin fun gl -> let n = depth_of_quantified_hypothesis red h gl in Tacticals.New.tclDO n (if red then introf else intro) end } let intros_until_id id = intros_until_gen false (NamedHyp id) let intros_until_n_gen red n = intros_until_gen red (AnonHyp n) let intros_until = intros_until_gen true let intros_until_n = intros_until_n_gen true let tclCHECKVAR id = Proofview.Goal.enter { enter = begin fun gl -> let _ = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in Proofview.tclUNIT () end } let try_intros_until_id_check id = Tacticals.New.tclORELSE (intros_until_id id) (tclCHECKVAR id) let try_intros_until tac = function | NamedHyp id -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (tac id) | AnonHyp n -> Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHypId tac) let rec intros_move = function | [] -> Proofview.tclUNIT () | (hyp,destopt) :: rest -> Tacticals.New.tclTHEN (intro_gen (NamingMustBe (dloc,hyp)) destopt false false) (intros_move rest) let run_delayed env sigma c = Sigma.run sigma { Sigma.run = fun sigma -> c.delayed env sigma } (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; Pretyping.use_hook = Some solve_by_implicit_tactic; Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true } let onOpenInductionArg env sigma tac = function | clear_flag,ElimOnConstr f -> let (cbl, sigma') = run_delayed env sigma f in let pending = (sigma,sigma') in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma') (tac clear_flag (pending,cbl)) | clear_flag,ElimOnAnonHyp n -> Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHyp (fun c -> Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let pending = (sigma,sigma) in tac clear_flag (pending,(c,NoBindings)) end })) | clear_flag,ElimOnIdent (_,id) -> (* A quantified hypothesis *) Tacticals.New.tclTHEN (try_intros_until_id_check id) (Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let pending = (sigma,sigma) in tac clear_flag (pending,(mkVar id,NoBindings)) end }) let onInductionArg tac = function | clear_flag,ElimOnConstr cbl -> tac clear_flag cbl | clear_flag,ElimOnAnonHyp n -> Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHyp (fun c -> tac clear_flag (c,NoBindings))) | clear_flag,ElimOnIdent (_,id) -> (* A quantified hypothesis *) Tacticals.New.tclTHEN (try_intros_until_id_check id) (tac clear_flag (mkVar id,NoBindings)) let map_destruction_arg f sigma = function | clear_flag,ElimOnConstr g -> let sigma,x = f sigma g in (sigma, (clear_flag,ElimOnConstr x)) | clear_flag,ElimOnAnonHyp n as x -> (sigma,x) | clear_flag,ElimOnIdent id as x -> (sigma,x) let finish_delayed_evar_resolution with_evars env sigma f = let ((c, lbind), sigma') = run_delayed env sigma f in let pending = (sigma,sigma') in let sigma' = Sigma.Unsafe.of_evar_map sigma' in let flags = tactic_infer_flags with_evars in let Sigma (c, sigma', _) = finish_evar_resolution ~flags env sigma' (pending,c) in (Sigma.to_evar_map sigma', (c, lbind)) let with_no_bindings (c, lbind) = if lbind != NoBindings then error "'with' clause not supported here."; c let force_destruction_arg with_evars env sigma c = map_destruction_arg (finish_delayed_evar_resolution with_evars env) sigma c (****************************************) (* tactic "cut" (actually modus ponens) *) (****************************************) let normalize_cut = false let cut c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_nf_concl gl in let is_sort = try (** Backward compat: ensure that [c] is well-typed. *) let typ = Typing.unsafe_type_of env sigma c in let typ = whd_all env sigma typ in match kind_of_term typ with | Sort _ -> true | _ -> false with e when Pretype_errors.precatchable_exception e -> false in if is_sort then let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in Refine.refine ~unsafe:true { run = begin fun h -> let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in let Sigma (x, h, q) = Evarutil.new_evar env h c in let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in Sigma (f, h, p +> q) end } else Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") end } let error_uninstantiated_metas t clenv = let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta") in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".") let check_unresolved_evars_of_metas sigma clenv = (* This checks that Metas turned into Evars by *) (* Refiner.pose_all_metas_as_evars are resolved *) List.iter (fun (mv,b) -> match b with | Clval (_,(c,_),_) -> (match kind_of_term c.rebus with | Evar (evk,_) when Evd.is_undefined clenv.evd evk && not (Evd.mem sigma evk) -> error_uninstantiated_metas (mkMeta mv) clenv | _ -> ()) | _ -> ()) (meta_list clenv.evd) let do_replace id = function | NamingMustBe (_,id') when Option.equal Id.equal id (Some id') -> true | _ -> false (* For a clenv expressing some lemma [C[?1:T1,...,?n:Tn] : P] and some goal [G], [clenv_refine_in] returns [n+1] subgoals, the [n] last ones (resp [n] first ones if [sidecond_first] is [true]) being the [Ti] and the first one (resp last one) being [G] whose hypothesis [id] is replaced by P using the proof given by [tac] *) let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) targetid id sigma0 clenv tac = let clenv = Clenvtac.clenv_pose_dependent_evars with_evars clenv in let clenv = if with_classes then { clenv with evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd } else clenv in let new_hyp_typ = clenv_type clenv in if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; if not with_evars && occur_meta new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in let exact_tac = Proofview.V82.tactic (Tacmach.refine_no_check new_hyp_prf) in let naming = NamingMustBe (dloc,targetid) in let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS (clear_metas clenv.evd)) (if sidecond_first then Tacticals.New.tclTHENFIRST (assert_before_then_gen with_clear naming new_hyp_typ tac) exact_tac else Tacticals.New.tclTHENLAST (assert_after_then_gen with_clear naming new_hyp_typ tac) exact_tac) (********************************************) (* Elimination tactics *) (********************************************) let last_arg c = match kind_of_term c with | App (f,cl) -> Array.last cl | _ -> anomaly (Pp.str "last_arg") let nth_arg i c = if Int.equal i (-1) then last_arg c else match kind_of_term c with | App (f,cl) -> cl.(i) | _ -> anomaly (Pp.str "nth_arg") let index_of_ind_arg t = let rec aux i j t = match kind_of_term t with | Prod (_,t,u) -> (* heuristic *) if isInd (fst (decompose_app t)) then aux (Some j) (j+1) u else aux i (j+1) u | _ -> match i with | Some i -> i | None -> error "Could not find inductive argument of elimination scheme." in aux None 0 t let enforce_prop_bound_names rename tac = let open Context.Rel.Declaration in match rename with | Some (isrec,nn) when Namegen.use_h_based_elimination_names () -> (* Rename dependent arguments in Prop with name "H" *) (* so as to avoid having hypothesis such as "t:True", "n:~A" when calling *) (* elim or induction with schemes built by Indrec.build_induction_scheme *) let rec aux env sigma i t = if i = 0 then t else match kind_of_term t with | Prod (Name _ as na,t,t') -> let very_standard = true in let na = if Retyping.get_sort_family_of env sigma t = InProp then (* "very_standard" says that we should have "H" names only, but this would break compatibility even more... *) let s = match Namegen.head_name t with | Some id when not very_standard -> string_of_id id | _ -> "" in Name (add_suffix Namegen.default_prop_ident s) else na in mkProd (na,t,aux (push_rel (LocalAssum (na,t)) env) sigma (i-1) t') | Prod (Anonymous,t,t') -> mkProd (Anonymous,t,aux (push_rel (LocalAssum (Anonymous,t)) env) sigma (i-1) t') | LetIn (na,c,t,t') -> mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t') | _ -> print_int i; Feedback.msg_notice (print_constr t); assert false in let rename_branch i = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let t = Proofview.Goal.concl gl in change_concl (aux env sigma i t) end } in (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) tac (Array.map rename_branch nn) | _ -> tac let rec contract_letin_in_lam_header c = match kind_of_term c with | Lambda (x,t,c) -> mkLambda (x,t,contract_letin_in_lam_header c) | LetIn (x,b,t,c) -> contract_letin_in_lam_header (subst1 b c) | _ -> c let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) rename i (elim, elimty, bindings) indclause = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header elim in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = (match kind_of_term (nth_arg i elimclause.templval.rebus) with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" (str "The type of elimination clause is not well-formed.")) in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in enforce_prop_bound_names rename (Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags) end } (* * Elimination tactic with bindings and using an arbitrary * elimination constant called elimc. This constant should end * with a clause (x:I)(P .. ), where P is a bound variable. * The term c is of type t, which is a product ending with a type * matching I, lbindc are the expected terms for c arguments *) type eliminator = { elimindex : int option; (* None = find it automatically *) elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) elimbody : constr with_bindings } let general_elim_clause_gen elimtac indclause elim = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (elimc,lbindelimc) = elim.elimbody in let elimt = Retyping.get_type_of env sigma elimc in let i = match elim.elimindex with None -> index_of_ind_arg elimt | Some i -> i in elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause end } let general_elim with_evars clear_flag (c, lbindc) elim = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ct = Retyping.get_type_of env sigma c in let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in let elimtac = elimination_clause_scheme with_evars in let indclause = make_clenv_binding env sigma (c, t) lbindc in let sigma = meta_merge sigma (clear_metas indclause.evd) in Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.tclTHEN (general_elim_clause_gen elimtac indclause elim) (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c) end } (* Case analysis tactics *) let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in let sort = Tacticals.New.elimination_sort_of_goal gl in let Sigma (elim, sigma, p) = if occur_term c concl then build_case_analysis_scheme env sigma mind true sort else build_case_analysis_scheme_default env sigma mind sort in let tac = (general_elim with_evars clear_flag (c,lbindc) {elimindex = None; elimbody = (elim,NoBindings); elimrename = Some (false, constructors_nrealdecls (fst mind))}) in Sigma (tac, sigma, p) end } let general_case_analysis with_evars clear_flag (c,lbindc as cx) = match kind_of_term c with | Var id when lbindc == NoBindings -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (general_case_analysis_in_context with_evars clear_flag cx) | _ -> general_case_analysis_in_context with_evars clear_flag cx let simplest_case c = general_case_analysis false None (c,NoBindings) let simplest_ecase c = general_case_analysis true None (c,NoBindings) (* Elimination tactic with bindings but using the default elimination * constant associated with the type. *) exception IsNonrec let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Decl_kinds.BiFinite let find_ind_eliminator ind s gl = let gr = lookup_eliminator ind s in let evd, c = Tacmach.New.pf_apply Evd.fresh_global gl gr in evd, c let find_eliminator c gl = let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_unsafe_type_of gl c) in if is_nonrec ind then raise IsNonrec; let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in evd, {elimindex = None; elimbody = (c,NoBindings); elimrename = Some (true, constructors_nrealdecls ind)} let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE (Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma, elim = find_eliminator c gl in let tac = (general_elim with_evars clear_flag cx elim) in Sigma.Unsafe.of_pair (tac, sigma) end }) begin function (e, info) -> match e with | IsNonrec -> (* For records, induction principles aren't there by default anymore. Instead, we do a case analysis. *) general_case_analysis with_evars clear_flag cx | e -> Proofview.tclZERO ~info e end let elim_in_context with_evars clear_flag c = function | Some elim -> general_elim with_evars clear_flag c {elimindex = Some (-1); elimbody = elim; elimrename = None} | None -> default_elim with_evars clear_flag c let elim with_evars clear_flag (c,lbindc as cx) elim = match kind_of_term c with | Var id when lbindc == NoBindings -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (elim_in_context with_evars clear_flag cx elim) | _ -> elim_in_context with_evars clear_flag cx elim (* The simplest elimination tactic, with no substitutions at all. *) let simplest_elim c = default_elim false None (c,NoBindings) (* Elimination in hypothesis *) (* Typically, elimclause := (eq_ind ?x ?P ?H ?y ?Heq : ?P ?y) indclause : forall ..., hyps -> a=b (to take place of ?Heq) id : phi(a) (to take place of ?H) and the result is to overwrite id with the proof of phi(b) but this generalizes to any elimination scheme with one constructor (e.g. it could replace id:A->B->C by id:C, knowing A/\B) *) let clenv_fchain_in id ?(flags=elim_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))) let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) id rename i (elim, elimty, bindings) indclause = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header elim in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = destMeta (nth_arg i elimclause.templval.rebus) in let hypmv = try match List.remove Int.equal indmv (clenv_independent elimclause) with | [a] -> a | _ -> failwith "" with Failure _ -> errorlabstrm "elimination_clause" (str "The type of elimination clause is not well-formed.") in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in let hyp = mkVar id in let hyp_typ = Retyping.get_type_of env sigma hyp in let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in if Term.eq_constr hyp_typ new_hyp_typ then errorlabstrm "general_rewrite_in" (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id id sigma elimclause'' (fun id -> Proofview.tclUNIT ()) end } let general_elim_clause with_evars flags id c e = let elim = match id with | None -> elimination_clause_scheme with_evars ~with_classes:true ~flags | Some id -> elimination_in_clause_scheme with_evars ~flags id in general_elim_clause_gen elim c e (* Apply a tactic below the products of the conclusion of a lemma *) type conjunction_status = | DefinedRecord of constant option list | NotADefinedRecordUseScheme of constr let make_projection env sigma params cstr sign elim i n c u = let open Context.Rel.Declaration in let elim = match elim with | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) let decl = List.nth cstr.cs_args i in let t = get_type decl in let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> b in let branch = it_mkLambda_or_LetIn b cstr.cs_args in if (* excludes dependent projection types *) noccur_between 1 (n-i-1) t (* to avoid surprising unifications, excludes flexible projection types or lambda which will be instantiated by Meta/Evar *) && not (isEvar (fst (whd_betaiota_stack sigma t))) && (accept_universal_lemma_under_conjunctions () || not (isRel t)) then let t = lift (i+1-n) t in let abselim = beta_applist (elim,params@[t;branch]) in let c = beta_applist (abselim, [mkApp (c, Context.Rel.to_extended_vect 0 sign)]) in Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else None | DefinedRecord l -> (* goes from left to right when i increases! *) match List.nth l i with | Some proj -> let args = Context.Rel.to_extended_vect 0 sign in let proj = if Environ.is_projection proj env then mkProj (Projection.make proj false, mkApp (c, args)) else mkApp (mkConstU (proj,u), Array.append (Array.of_list params) [|mkApp (c, args)|]) in let app = it_mkLambda_or_LetIn proj sign in let t = Retyping.get_type_of env sigma app in Some (app, t) | None -> None in elim let descend_in_conjunctions avoid tac (err, info) c = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try let t = Retyping.get_type_of env sigma c in let ((ind,u),t) = reduce_to_quantified_ind env sigma t in let sign,ccl = decompose_prod_assum t in match match_with_tuple ccl with | Some (_,_,isrec) -> let n = (constructors_nrealargs ind).(0) in let sort = Tacticals.New.elimination_sort_of_goal gl in let IndType (indf,_) = find_rectype env sigma ccl in let (_,inst), params = dest_ind_family indf in let cstr = (get_constructors env indf).(0) in let elim = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (elim, _, _) = build_case_analysis_scheme env sigma (ind,u) false sort in NotADefinedRecordUseScheme elim in Tacticals.New.tclORELSE0 (Tacticals.New.tclFIRST (List.init n (fun i -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match make_projection env sigma params cstr sign elim i n c u with | None -> Tacticals.New.tclFAIL 0 (mt()) | Some (p,pt) -> Tacticals.New.tclTHENS (assert_before_gen false (NamingAvoid avoid) pt) [Proofview.V82.tactic (refine p); (* Might be ill-typed due to forbidden elimination. *) Tacticals.New.onLastHypId (tac (not isrec))] end }))) (Proofview.tclZERO ~info err) | None -> Proofview.tclZERO ~info err with RefinerError _|UserError _ -> Proofview.tclZERO ~info err end } (****************************************************) (* Resolution tactics *) (****************************************************) let solve_remaining_apply_goals = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in if !apply_solve_class_goals then try let env = Proofview.Goal.env gl in let evd = Sigma.to_evar_map sigma in let concl = Proofview.Goal.concl gl in if Typeclasses.is_class_type evd concl then let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in let tac = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c' h } in Sigma.Unsafe.of_pair (tac, evd') else Sigma.here (Proofview.tclUNIT ()) sigma with Not_found -> Sigma.here (Proofview.tclUNIT ()) sigma else Sigma.here (Proofview.tclUNIT ()) sigma end } let tclORELSEOPT t k = Proofview.tclORELSE t (fun e -> match k e with | None -> let (e, info) = e in Proofview.tclZERO ~info e | Some tac -> tac) let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let flags = if with_delta then default_unify_flags () else default_no_delta_unify_flags () in (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) let concl_nprod = nb_prod_modulo_zeta concl in let rec try_main_apply with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in let try_apply thm_ty nprod = try let n = nb_prod_modulo_zeta thm_ty - nprod in if n<0 then error "Applied theorem has not enough premisses."; let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars ~flags with exn when catchable_exception exn -> Proofview.tclZERO exn in let rec try_red_apply thm_ty (exn0, info) = try (* Try to head-reduce the conclusion of the theorem *) let red_thm = try_red_product env sigma thm_ty in tclORELSEOPT (try_apply red_thm concl_nprod) (function (e, info) -> match e with | PretypeError _|RefinerError _|UserError _|Failure _ -> Some (try_red_apply red_thm (exn0, info)) | _ -> None) with Redelimination -> (* Last chance: if the head is a variable, apply may try second order unification *) let info = Loc.add_loc info loc in let tac = if with_destruct then descend_in_conjunctions [] (fun b id -> Tacticals.New.tclTHEN (try_main_apply b (mkVar id)) (clear [id])) (exn0, info) c else Proofview.tclZERO ~info exn0 in if not (Int.equal concl_nprod 0) then tclORELSEOPT (try_apply thm_ty 0) (function (e, info) -> match e with | PretypeError _|RefinerError _|UserError _|Failure _-> Some tac | _ -> None) else tac in tclORELSEOPT (try_apply thm_ty0 concl_nprod) (function (e, info) -> match e with | PretypeError _|RefinerError _|UserError _|Failure _ -> Some (try_red_apply thm_ty0 (e, info)) | _ -> None) end } in Tacticals.New.tclTHENLIST [ try_main_apply with_destruct c; solve_remaining_apply_goals; apply_clear_request clear_flag (use_clear_hyp_by_default ()) c ] end } let rec apply_with_bindings_gen b e = function | [] -> Proofview.tclUNIT () | [k,cb] -> general_apply b b e k cb | (k,cb)::cbl -> Tacticals.New.tclTHENLAST (general_apply b b e k cb) (apply_with_bindings_gen b e cbl) let apply_with_delayed_bindings_gen b e l = let one k (loc, f) = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (cb, sigma) = run_delayed env sigma f in Tacticals.New.tclWITHHOLES e (general_apply b b e k (loc,cb)) sigma end } in let rec aux = function | [] -> Proofview.tclUNIT () | [k,f] -> one k f | (k,f)::cbl -> Tacticals.New.tclTHENLAST (one k f) (aux cbl) in aux l let apply_with_bindings cb = apply_with_bindings_gen false false [None,(dloc,cb)] let eapply_with_bindings cb = apply_with_bindings_gen false true [None,(dloc,cb)] let apply c = apply_with_bindings_gen false false [None,(dloc,(c,NoBindings))] let eapply c = apply_with_bindings_gen false true [None,(dloc,(c,NoBindings))] let apply_list = function | c::l -> apply_with_bindings (c,ImplicitBindings l) | _ -> assert false (* [apply_in hyp c] replaces hyp : forall y1, ti -> t hyp : rho(u) ======================== with ============ and the ======= goal goal rho(ti) assuming that [c] has type [forall x1..xn -> t' -> u] for some [t] unifiable with [t'] with unifier [rho] *) let find_matching_clause unifier clause = let rec find clause = try unifier clause with e when catchable_exception e -> try find (clenv_push_prod clause) with NotExtensibleClause -> failwith "Cannot apply" in find clause 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 ~with_univs:false mv ~flags clause) innerclause) with Failure _ -> None in try List.find_map f ordered_metas with Not_found -> error "Unable to unify." let apply_in_once_main flags innerclause env sigma (d,lbind) = let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> let e = CErrors.push e in try aux (clenv_push_prod clause) with NotExtensibleClause -> iraise e in aux (make_clenv_binding env sigma (d,thm) lbind) let apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,(d,lbind))) tac = let open Context.Rel.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let flags = if with_delta then default_unify_flags () else default_no_delta_unify_flags () in let t' = Tacmach.New.pf_get_hyp_typ id gl in let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in let rec aux idstoclear with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try let clause = apply_in_once_main flags innerclause env sigma (c,lbind) in clenv_refine_in ~sidecond_first with_evars targetid id sigma clause (fun id -> Tacticals.New.tclTHENLIST [ apply_clear_request clear_flag false c; clear idstoclear; tac id ]) with e when with_destruct && CErrors.noncritical e -> let (e, info) = CErrors.push e in (descend_in_conjunctions [targetid] (fun b id -> aux (id::idstoclear) b (mkVar id)) (e, info) c) end } in aux [] with_destruct d end } let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,f)) tac = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (c, sigma) = run_delayed env sigma f in Tacticals.New.tclWITHHOLES with_evars (apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,c)) tac) sigma end } (* A useful resolution tactic which, if c:A->B, transforms |- C into |- B -> C and |- A ------------------- Gamma |- c : A -> B Gamma |- ?2 : A ---------------------------------------- Gamma |- B Gamma |- ?1 : B -> C ----------------------------------------------------- Gamma |- ? : C Ltac lapply c := let ty := check c in match eval hnf in ty with ?A -> ?B => cut B; [ idtac | apply c ] end. *) let cut_and_apply c = Proofview.Goal.nf_enter { enter = begin fun gl -> match kind_of_term (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in Refine.refine { run = begin fun sigma -> let typ = mkProd (Anonymous, c2, concl) in let Sigma (f, sigma, p) = Evarutil.new_evar env sigma typ in let Sigma (x, sigma, q) = Evarutil.new_evar env sigma c1 in let ans = mkApp (f, [|mkApp (c, [|x|])|]) in Sigma (ans, sigma, p +> q) end } | _ -> error "lapply needs a non-dependent product." end } (********************************************************************) (* Exact tactics *) (********************************************************************) (* let convert_leqkey = Profile.declare_profile "convert_leq";; *) (* let convert_leq = Profile.profile3 convert_leqkey convert_leq *) (* let refine_no_checkkey = Profile.declare_profile "refine_no_check";; *) (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) let exact_no_check c = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } let exact_check c = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in (** We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let sigma, ct = Typing.type_of env sigma c in let tac = Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c) in Sigma.Unsafe.of_pair (tac, sigma) end } let cast_no_check cast c = Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in exact_no_check (Term.mkCast (c, cast, concl)) end } let vm_cast_no_check c = cast_no_check Term.VMcast c let native_cast_no_check c = cast_no_check Term.NATIVEcast c let exact_proof c = let open Tacmach.New in Proofview.Goal.nf_enter { enter = begin fun gl -> Refine.refine { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (pf_concl gl) in let sigma = Evd.merge_universe_context sigma ctx in Sigma.Unsafe.of_pair (c, sigma) end } end } let assumption = let open Context.Named.Declaration in let rec arec gl only_eq = function | [] -> if only_eq then let hyps = Proofview.Goal.hyps gl in arec gl false hyps else Tacticals.New.tclZEROMSG (str "No such assumption.") | decl::rest -> let t = get_type decl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let (sigma, is_same_type) = if only_eq then (sigma, Constr.equal t concl) else let env = Proofview.Goal.env gl in infer_conv env sigma t concl in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> exact_no_check (mkVar (get_id decl)) else arec gl only_eq rest in let assumption_tac = { enter = begin fun gl -> let hyps = Proofview.Goal.hyps gl in arec gl true hyps end } in Proofview.Goal.nf_enter assumption_tac (*****************************************************************) (* Modification of a local context *) (*****************************************************************) let on_the_bodies = function | [] -> assert false | [id] -> str " depends on the body of " ++ pr_id id | l -> str " depends on the bodies of " ++ pr_sequence pr_id l exception DependsOnBody of Id.t option let check_is_type env sigma ty = let evdref = ref sigma in try let _ = Typing.e_sort_of env evdref ty in !evdref with e when CErrors.noncritical e -> raise (DependsOnBody None) let check_decl env sigma decl = let open Context.Named.Declaration in let ty = get_type decl in let evdref = ref sigma in try let _ = Typing.e_sort_of env evdref ty in let _ = match decl with | LocalAssum _ -> () | LocalDef (_,c,_) -> Typing.e_check env evdref c ty in !evdref with e when CErrors.noncritical e -> let id = get_id decl in raise (DependsOnBody (Some id)) let clear_body ids = let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let sigma = Tacmach.New.project gl in let ctx = named_context env in let map = function | LocalAssum (id,t) as decl -> let () = if List.mem_f Id.equal id ids then errorlabstrm "" (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") in decl | LocalDef (id,_,t) as decl -> if List.mem_f Id.equal id ids then LocalAssum (id, t) else decl in let ctx = List.map map ctx in let base_env = reset_context env in let env = push_named_context ctx base_env in let check = try let check (env, sigma, seen) decl = (** Do no recheck hypotheses that do not depend *) let sigma = if not seen then sigma else if List.exists (fun id -> occur_var_in_decl env id decl) ids then check_decl env sigma decl else sigma in let seen = seen || List.mem_f Id.equal (get_id decl) ids in (push_named decl env, sigma, seen) in let (env, sigma, _) = List.fold_left check (base_env, sigma, false) (List.rev ctx) in let sigma = if List.exists (fun id -> occur_var env id concl) ids then check_is_type env sigma concl else sigma in Proofview.Unsafe.tclEVARS sigma with DependsOnBody where -> let msg = match where with | None -> str "Conclusion" ++ on_the_bodies ids | Some id -> str "Hypothesis " ++ pr_id id ++ on_the_bodies ids in Tacticals.New.tclZEROMSG msg in check <*> Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma ~principal:true concl end } end } let clear_wildcards ids = Tacticals.New.tclMAP (fun (loc, id) -> clear [id]) ids (* Takes a list of booleans, and introduces all the variables * quantified in the goal which are associated with a value * true in the boolean list. *) let rec intros_clearing = function | [] -> Proofview.tclUNIT () | (false::tl) -> Tacticals.New.tclTHEN intro (intros_clearing tl) | (true::tl) -> Tacticals.New.tclTHENLIST [ intro; Tacticals.New.onLastHypId (fun id -> clear [id]); intros_clearing tl] (* Keeping only a few hypotheses *) let keep hyps = let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in let cl,_ = fold_named_context_reverse (fun (clear,keep) decl -> let hyp = get_id decl in if Id.List.mem hyp hyps || List.exists (occur_var_in_decl env hyp) keep || occur_var env hyp ccl then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (Proofview.Goal.env gl) in clear cl end } (*********************************) (* Basic generalization tactics *) (*********************************) (* Given a type [T] convertible to [forall x1..xn:A1..An(x1..xn-1), G(x1..xn)] and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)], this generalizes [hyps |- goal] into [hyps |- T] *) let apply_type newcl args = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in Refine.refine { run = begin fun sigma -> let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newcl in Sigma (applist (ev, args), sigma, p) end } end } (* Given a context [hyps] with domain [x1..xn], possibly with let-ins, and well-typed in the current goal, [bring_hyps hyps] generalizes [ctxt |- G(x1..xn] into [ctxt |- forall hyps, G(x1..xn)] *) let bring_hyps hyps = if List.is_empty hyps then Tacticals.New.tclIDTAC else Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let concl = Tacmach.New.pf_nf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.of_list (Context.Named.to_instance hyps) in Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newcl in Sigma (mkApp (ev, args), sigma, p) end } end } let revert hyps = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in (bring_hyps ctx) <*> (clear hyps) end } (************************) (* Introduction tactics *) (************************) let check_number_of_constructors expctdnumopt i nconstr = if Int.equal i 0 then error "The constructors are numbered starting from 1."; begin match expctdnumopt with | Some n when not (Int.equal n nconstr) -> errorlabstrm "Tactics.check_number_of_constructors" (str "Not an inductive goal with " ++ int n ++ str (String.plural n " constructor") ++ str ".") | _ -> () end; if i > nconstr then error "Not enough constructors." let constructor_tac with_evars expctdnumopt i lbind = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let cl = Tacmach.New.pf_nf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in let (mind,redcl) = reduce_to_quantified_ind cl in let nconstr = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; let Sigma (cons, sigma, p) = Sigma.fresh_constructor_instance (Proofview.Goal.env gl) sigma (fst mind, i) in let cons = mkConstructU cons in let apply_tac = general_apply true false with_evars None (dloc,(cons,lbind)) in let tac = (Tacticals.New.tclTHENLIST [ convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) in Sigma (tac, sigma, p) end } let one_constructor i lbind = constructor_tac false None i lbind (* Try to apply the constructor of the inductive definition followed by a tactic t given as an argument. Should be generalize in Constructor (Fun c : I -> tactic) *) let rec tclANY tac = function | [] -> Tacticals.New.tclZEROMSG (str "No applicable tactic.") | arg :: l -> Tacticals.New.tclORD (tac arg) (fun () -> tclANY tac l) let any_constructor with_evars tacopt = let t = match tacopt with None -> Proofview.tclUNIT () | Some t -> t in let tac i = Tacticals.New.tclTHEN (constructor_tac with_evars None i NoBindings) t in Proofview.Goal.enter { enter = begin fun gl -> let cl = Tacmach.New.pf_nf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in let mind = fst (reduce_to_quantified_ind cl) in let nconstr = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; tclANY tac (List.interval 1 nconstr) end } let left_with_bindings with_evars = constructor_tac with_evars (Some 2) 1 let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2 let split_with_bindings with_evars l = Tacticals.New.tclMAP (constructor_tac with_evars (Some 1) 1) l let left = left_with_bindings false let simplest_left = left NoBindings let right = right_with_bindings false let simplest_right = right NoBindings let split = constructor_tac false (Some 1) 1 let simplest_split = split NoBindings (*****************************) (* Decomposing introductions *) (*****************************) (* Rewriting function for rewriting one hypothesis at the time *) let (forward_general_rewrite_clause, general_rewrite_clause) = Hook.make () (* Rewriting function for substitution (x=t) everywhere at the same time *) let (forward_subst_one, subst_one) = Hook.make () let error_unexpected_extra_pattern loc bound pat = let _,nb = Option.get bound in let s1,s2,s3 = match pat with | IntroNaming (IntroIdentifier _) -> "name", (String.plural nb " introduction pattern"), "no" | _ -> "introduction pattern", "", "none" in user_err_loc (loc,"",str "Unexpected " ++ str s1 ++ str " (" ++ (if Int.equal nb 0 then (str s3 ++ str s2) else (str "at most " ++ int nb ++ str s2)) ++ spc () ++ str (if Int.equal nb 1 then "was" else "were") ++ strbrk " expected in the branch).") let intro_decomp_eq_function = ref (fun _ -> failwith "Not implemented") let declare_intro_decomp_eq f = intro_decomp_eq_function := f let my_find_eq_data_decompose gl t = try Some (find_eq_data_decompose gl t) with e when is_anomaly e (* Hack in case equality is not yet defined... one day, maybe, known equalities will be dynamically registered *) -> None | Constr_matching.PatternMatchingFailure -> None let intro_decomp_eq loc l thin tac id = Proofview.Goal.nf_enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in match my_find_eq_data_decompose gl t with | Some (eq,u,eq_args) -> !intro_decomp_eq_function (fun n -> tac ((dloc,id)::thin) (Some (true,n)) l) (eq,t,eq_args) (c, t) | None -> Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") end } let intro_or_and_pattern loc with_evars bracketed ll thin tac id = Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in let branchsigns = compute_constructor_signatures false ind in let nv_with_let = Array.map List.length branchsigns in let ll = fix_empty_or_and_pattern (Array.length branchsigns) ll in let ll = get_and_check_or_and_pattern loc ll branchsigns in Tacticals.New.tclTHENLASTn (Tacticals.New.tclTHEN (simplest_ecase c) (clear [id])) (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) nv_with_let ll) end } let rewrite_hyp_then assert_style with_evars thin l2r id tac = let rew_on l2r = Hook.get forward_general_rewrite_clause l2r with_evars (mkVar id,NoBindings) in let subst_on l2r x rhs = Hook.get forward_subst_one true x (id,rhs,l2r) in let clear_var_and_eq id' = clear [id';id] in let early_clear id' thin = List.filter (fun (_,id) -> not (Id.equal id id')) thin in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_all = Tacmach.New.pf_apply whd_all gl in let t = whd_all (type_of (mkVar id)) in let eqtac, thin = match match_with_equality_type t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar lhs && not (occur_var env (destVar lhs) rhs) then let id' = destVar lhs in subst_on l2r id' rhs, early_clear id' thin else if not l2r && isVar rhs && not (occur_var env (destVar rhs) lhs) then let id' = destVar rhs in subst_on l2r id' lhs, early_clear id' thin else Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin | Some (hdcncl,[c]) -> let l2r = not l2r in (* equality of the form eq_true *) if isVar c then let id' = destVar c in Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq id'), early_clear id' thin else Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin | _ -> Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin in (* Skip the side conditions of the rewriting step *) Tacticals.New.tclTHENFIRST eqtac (tac thin) end } let prepare_naming loc = function | IntroIdentifier id -> NamingMustBe (loc,id) | IntroAnonymous -> NamingAvoid [] | IntroFresh id -> NamingBasedOn (id,[]) let rec explicit_intro_names = function | (_, IntroForthcoming _) :: l -> explicit_intro_names l | (_, IntroNaming (IntroIdentifier id)) :: l -> id :: explicit_intro_names l | (_, IntroAction (IntroOrAndPattern l)) :: l' -> let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll) | (_, IntroAction (IntroInjection l)) :: l' -> explicit_intro_names (l@l') | (_, IntroAction (IntroApplyOn (c,pat))) :: l' -> explicit_intro_names (pat::l') | (_, (IntroNaming (IntroAnonymous | IntroFresh _) | IntroAction (IntroWildcard | IntroRewrite _))) :: l -> explicit_intro_names l | [] -> [] let wild_id = Id.of_string "_tmp" let rec list_mem_assoc_right id = function | [] -> false | (x,id')::l -> Id.equal id id' || list_mem_assoc_right id l let check_thin_clash_then id thin avoid tac = if list_mem_assoc_right id thin then let newid = next_ident_away (add_suffix id "'") avoid in let thin = List.map (on_snd (fun id' -> if Id.equal id id' then newid else id')) thin in Tacticals.New.tclTHEN (rename_hyp [id,newid]) (tac thin) else tac thin let make_tmp_naming avoid l = function (* In theory, we could use a tmp id like "wild_id" for all actions but we prefer to avoid it to avoid this kind of "ugly" names *) (* Alternatively, we could have called check_thin_clash_then on IntroAnonymous, but at the cost of a "renaming"; Note that in the case of IntroFresh, we should use check_thin_clash_then anyway to prevent the case of an IntroFresh precisely using the wild_id *) | IntroWildcard -> NamingBasedOn (wild_id,avoid@explicit_intro_names l) | pat -> NamingAvoid(avoid@explicit_intro_names ((dloc,IntroAction pat)::l)) let fit_bound n = function | None -> true | Some (use_bound,n') -> not use_bound || n = n' let exceed_bound n = function | None -> false | Some (use_bound,n') -> use_bound && n >= n' (* We delay thinning until the completion of the whole intros tactic to ensure that dependent hypotheses are cleared in the right dependency order (see bug #1000); we use fresh names, not used in the tactic, for the hyps to clear *) (* In [intro_patterns_core b avoid ids thin destopt bound n tac patl]: [b]: compatibility flag, if false at toplevel, do not complete incomplete trailing toplevel or_and patterns (as in "intros []", see [bracketing_last_or_and_intro_pattern]) [avoid]: names to avoid when creating an internal name [ids]: collect introduced names for possible use by the [tac] continuation [thin]: collect names to erase at the end [destopt]: position in the context where to introduce the hypotheses [bound]: number of pending intros to do in the current or-and pattern, with remembering of [b] flag if at toplevel [n]: number of introduction done in the current or-and pattern [tac]: continuation tactic [patl]: introduction patterns to interpret *) let rec intro_patterns_core with_evars b avoid ids thin destopt bound n tac = function | [] when fit_bound n bound -> tac ids thin | [] -> (* Behave as IntroAnonymous *) intro_patterns_core with_evars b avoid ids thin destopt bound n tac [dloc,IntroNaming IntroAnonymous] | (loc,pat) :: l -> if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else match pat with | IntroForthcoming onlydeps -> intro_forthcoming_then_gen (NamingAvoid (avoid@explicit_intro_names l)) destopt onlydeps n bound (fun ids -> intro_patterns_core with_evars b avoid ids thin destopt bound (n+List.length ids) tac l) | IntroAction pat -> intro_then_gen (make_tmp_naming avoid l pat) destopt true false (intro_pattern_action loc with_evars (b || not (List.is_empty l)) false pat thin destopt (fun thin bound' -> intro_patterns_core with_evars b avoid ids thin destopt bound' 0 (fun ids thin -> intro_patterns_core with_evars b avoid ids thin destopt bound (n+1) tac l))) | IntroNaming pat -> intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound (n+1) tac l (* Pi-introduction rule, used backwards *) and intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound n tac l = match pat with | IntroIdentifier id -> check_thin_clash_then id thin avoid (fun thin -> intro_then_gen (NamingMustBe (loc,id)) destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l)) | IntroAnonymous -> intro_then_gen (NamingAvoid (avoid@explicit_intro_names l)) destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) | IntroFresh id -> (* todo: avoid thinned names to interfere with generation of fresh name *) intro_then_gen (NamingBasedOn (id, avoid@explicit_intro_names l)) destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) and intro_pattern_action loc with_evars b style pat thin destopt tac id = match pat with | IntroWildcard -> tac ((loc,id)::thin) None [] | IntroOrAndPattern ll -> intro_or_and_pattern loc with_evars b ll thin tac id | IntroInjection l' -> intro_decomp_eq loc l' thin tac id | IntroRewrite l2r -> rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None []) | IntroApplyOn (f,(loc,pat)) -> let naming,tac_ipat = prepare_intros_loc loc with_evars (IntroIdentifier id) destopt pat in let doclear = if naming = NamingMustBe (loc,id) then Proofview.tclUNIT () (* apply_in_once do a replacement *) else clear [id] in let f = { delayed = fun env sigma -> let Sigma (c, sigma, p) = f.delayed env sigma in Sigma ((c, NoBindings), sigma, p) } in apply_in_delayed_once false true true with_evars naming id (None,(loc,f)) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros_loc loc with_evars dft destopt = function | IntroNaming ipat -> prepare_naming loc ipat, (fun id -> move_hyp id destopt) | IntroAction ipat -> prepare_naming loc dft, (let tac thin bound = intro_patterns_core with_evars true [] [] thin destopt bound 0 (fun _ l -> clear_wildcards l) in fun id -> intro_pattern_action loc with_evars true true ipat [] destopt tac id) | IntroForthcoming _ -> user_err_loc (loc,"",str "Introduction pattern for one hypothesis expected.") let intro_patterns_bound_to with_evars n destopt = intro_patterns_core with_evars true [] [] [] destopt (Some (true,n)) 0 (fun _ l -> clear_wildcards l) let intro_patterns_to with_evars destopt = intro_patterns_core with_evars (use_bracketing_last_or_and_intro_pattern ()) [] [] [] destopt None 0 (fun _ l -> clear_wildcards l) let intro_pattern_to with_evars destopt pat = intro_patterns_to with_evars destopt [dloc,pat] let intro_patterns with_evars = intro_patterns_to with_evars MoveLast (* Implements "intros" *) let intros_patterns with_evars = function | [] -> intros | l -> intro_patterns_to with_evars MoveLast l (**************************) (* Forward reasoning *) (**************************) let prepare_intros with_evars dft destopt = function | None -> prepare_naming dloc dft, (fun _id -> Proofview.tclUNIT ()) | Some (loc,ipat) -> prepare_intros_loc loc with_evars dft destopt ipat let ipat_of_name = function | Anonymous -> None | Name id -> Some (dloc, IntroNaming (IntroIdentifier id)) let head_ident c = let c = fst (decompose_app ((strip_lam_assum c))) in if isVar c then Some (destVar c) else None let assert_as first hd ipat t = let naming,tac = prepare_intros false IntroAnonymous MoveLast ipat in let repl = do_replace hd naming in let tac = if repl then (fun id -> Proofview.tclUNIT ()) else tac in if first then assert_before_then_gen repl naming t tac else assert_after_then_gen repl naming t tac (* apply in as *) let general_apply_in sidecond_first with_delta with_destruct with_evars 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 Proofview.Goal.enter { enter = begin fun gl -> let destopt = if with_evars then MoveLast (* evars would depend on the whole context *) else get_previous_hyp_position id gl in let naming,ipat_tac = prepare_intros with_evars (IntroIdentifier id) destopt ipat in let lemmas_target, last_lemma_target = let last,first = List.sep_last lemmas in List.map (fun lem -> (NamingMustBe (dloc,id),lem)) first, (naming,last) in (* We chain apply_in_once, ending with an intro pattern *) List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id end } (* if sidecond_first then (* Skip the side conditions of the applied lemma *) Tacticals.New.tclTHENLAST (tclMAPLAST tac lemmas_target) (ipat_tac id) else Tacticals.New.tclTHENFIRST (tclMAPFIRST tac lemmas_target) (ipat_tac id) *) let apply_in simple with_evars id lemmas ipat = let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, { delayed = fun _ sigma -> Sigma.here l sigma })) lemmas in general_apply_in false simple simple with_evars 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 *) (*****************************) (* Implementation without generalisation: abbrev will be lost in hyps in *) (* in the extracted proof *) let decode_hyp = function | None -> MoveLast | Some id -> MoveAfter id (* [letin_tac b (... abstract over c ...) gl] transforms [...x1:T1(c),...,x2:T2(c),... |- G(c)] into [...x:T;Heqx:(x=c);x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is false or [...x:=c:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is true *) let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let Sigma (t, sigma, p) = match ty with | Some t -> Sigma.here t sigma | None -> let t = typ_of env sigma c in let sigma, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env (Sigma.to_evar_map sigma) t in Sigma.Unsafe.of_pair (c, sigma) in let Sigma ((newcl, eq_tac), sigma, q) = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl | IntroFresh heq_base -> new_fresh_id [id] heq_base gl | IntroIdentifier id -> id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in let sigma = Sigma.to_evar_map sigma in let sigma, _ = Typing.type_of env sigma term in let ans = term, Tacticals.New.tclTHEN (intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false) (clear_body [heq;id]) in Sigma.Unsafe.of_pair (ans, sigma) | None -> Sigma.here (mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) sigma in let tac = Tacticals.New.tclTHENLIST [ convert_concl_no_check newcl DEFAULTcast; intro_gen (NamingMustBe (dloc,id)) (decode_hyp lastlhyp) true false; Tacticals.New.tclMAP convert_hyp_no_check depdecls; eq_tac ] in Sigma (tac, sigma, p +> q) end } let insert_before decls lasthyp env = let open Context.Named.Declaration in match lasthyp with | None -> push_named_context decls env | Some id -> Environ.fold_named_context (fun _ d env -> let env = if Id.equal id (get_id d) then push_named_context decls env else env in push_named d env) ~init:(reset_context env) env (* unsafe *) let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let open Context.Named.Declaration in let t = match ty with Some t -> t | _ -> typ_of env sigma c in let decl = if dep then LocalDef (id,c,t) else LocalAssum (id,t) in match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> fresh_id_in_env [id] (add_prefix "Heq" id) env | IntroFresh heq_base -> fresh_id_in_env [id] heq_base env | IntroIdentifier id -> if List.mem id (ids_of_named_context (named_context env)) then user_err_loc (loc,"",pr_id id ++ str" is already used."); id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store ccl in Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r) | None -> let newenv = insert_before [decl] lastlhyp env in let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in Sigma (mkNamedLetIn id c t x, sigma, p) let letin_tac with_eq id c ty occs = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let abs = AbstractExact (id,c,ty,occs,true) in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in (* We keep the original term to match but record the potential side-effects of unifying universes. *) let Sigma (c, sigma, p) = match res with | None -> Sigma.here c sigma | Some (Sigma (_, sigma, p)) -> Sigma (c, sigma, p) in let tac = letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty in Sigma (tac, sigma, p) end } let letin_pat_tac with_eq id c occs = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let check t = true in let abs = AbstractPattern (false,check,id,c,occs,false) in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in let Sigma (c, sigma, p) = match res with | None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c | Some res -> res in let tac = (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) in Sigma (tac, sigma, p) end } (* Tactics "pose proof" (usetac=None) and "assert"/"enough" (otherwise) *) let forward b usetac ipat c = match usetac with | None -> Proofview.Goal.enter { enter = begin fun gl -> let t = Tacmach.New.pf_get_type_of gl c in let hd = head_ident c in Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (exact_no_check c) end } | Some tac -> let tac = match tac with | None -> Tacticals.New.tclIDTAC | Some tac -> Tacticals.New.tclCOMPLETE tac in if b then Tacticals.New.tclTHENFIRST (assert_as b None ipat c) tac else Tacticals.New.tclTHENS3PARTS (assert_as b None ipat c) [||] tac [|Tacticals.New.tclIDTAC|] let pose_proof na c = forward true None (ipat_of_name na) c let assert_by na t tac = forward true (Some (Some tac)) (ipat_of_name na) t let enough_by na t tac = forward false (Some (Some tac)) (ipat_of_name na) t (***************************) (* Generalization tactics *) (***************************) (* Compute a name for a generalization *) let generalized_name c t ids cl = function | Name id as na -> if Id.List.mem id ids then errorlabstrm "" (pr_id id ++ str " is already used."); na | Anonymous -> match kind_of_term c with | Var id -> (* Keep the name even if not occurring: may be used by intros later *) Name id | _ -> if noccurn 1 cl then Anonymous else (* On ne s'etait pas casse la tete : on avait pris pour nom de variable la premiere lettre du type, meme si "c" avait ete une constante dont on aurait pu prendre directement le nom *) named_hd (Global.env()) t Anonymous (* Abstract over [c] in [forall x1:A1(c)..xi:Ai(c).T(c)] producing [forall x, x1:A1(x1), .., xi:Ai(x). T(x)] with all [c] abtracted in [Ai] but only those at [occs] in [T] *) let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let open Context.Rel.Declaration in let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t ids cl' na in let decl = match b with | None -> LocalAssum (na,t) | Some b -> LocalDef (na,b,t) in mkProd_or_LetIn decl cl', sigma' let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let env = Tacmach.pf_env gl in let ids = Tacmach.pf_ids_of_hyps gl in let sigma, t = Typing.type_of env sigma c in generalize_goal_gen env sigma ids i o t cl let old_generalize_dep ?(with_let=false) c gl = let open Context.Named.Declaration in let env = pf_env gl in let sign = pf_hyps gl in let init_ids = ids_of_named_context (Global.named_context()) in let seek (d:Context.Named.Declaration.t) (toquant:Context.Named.t) = if List.exists (fun d' -> occur_var_in_decl env (get_id d') d) toquant || dependent_in_decl c d then d::toquant else toquant in let to_quantify = Context.Named.fold_outside seek sign ~init:[] in let to_quantify_rev = List.rev to_quantify in let qhyps = List.map get_id to_quantify_rev in let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in let tothin' = match kind_of_term c with | Var id when mem_named_context_val id (val_of_named_context sign) && not (Id.List.mem id init_ids) -> id::tothin | _ -> tothin in let cl' = it_mkNamedProd_or_LetIn (Tacmach.pf_concl gl) to_quantify in let body = if with_let then match kind_of_term c with | Var id -> Tacmach.pf_get_hyp gl id |> get_value | _ -> None else None in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in (** Check that the generalization is indeed well-typed *) let (evd, _) = Typing.type_of env evd cl'' in let args = Context.Named.to_instance to_quantify_rev in tclTHENLIST [tclEVARS evd; Proofview.V82.of_tactic (apply_type cl'' (if Option.is_empty body then c::args else args)); Proofview.V82.of_tactic (clear (List.rev tothin'))] gl let generalize_dep ?(with_let = false) c = Proofview.V82.tactic (old_generalize_dep ~with_let c) (** *) let generalize_gen_let lconstr = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let newcl, evd = List.fold_right_i (Tacmach.New.of_old generalize_goal gl) 0 lconstr (Tacmach.New.pf_concl gl,Tacmach.New.project gl) in let (evd, _) = Typing.type_of env evd newcl in let map ((_, c, b),_) = if Option.is_empty b then Some c else None in let tac = apply_type newcl (List.map_filter map lconstr) in Sigma.Unsafe.of_pair (tac, evd) end } let new_generalize_gen_let lconstr = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in let newcl, sigma, args = List.fold_right_i (fun i ((_,c,b),_ as o) (cl, sigma, args) -> let sigma, t = Typing.type_of env sigma c in let args = if Option.is_empty b then c :: args else args in let cl, sigma = generalize_goal_gen env sigma ids i o t cl in (cl, sigma, args)) 0 lconstr (concl, sigma, []) in let tac = Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true newcl in Sigma ((applist (ev, args)), sigma, p) end } in Sigma.Unsafe.of_pair (tac, sigma) end } let generalize_gen lconstr = generalize_gen_let (List.map (fun (occs_c,na) -> let (occs,c) = Redexpr.out_with_occurrences occs_c in (occs,c,None),na) lconstr) let new_generalize_gen lconstr = new_generalize_gen_let (List.map (fun ((occs,c),na) -> (occs,c,None),na) lconstr) let generalize l = new_generalize_gen_let (List.map (fun c -> ((AllOccurrences,c,None),Anonymous)) l) (* Faudra-t-il une version avec plusieurs args de generalize_dep ? Cela peut-être troublant de faire "Generalize Dependent H n" dans "n:nat; H:n=n |- P(n)" et d'échouer parce que H a disparu après la généralisation dépendante par n. let quantify lconstr = List.fold_right (fun com tac -> tclTHEN tac (tactic_com generalize_dep c)) lconstr tclIDTAC *) (* Modifying/Adding an hypothesis *) let specialize (c,lbind) ipat = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let sigma, term = if lbind == NoBindings then let sigma = Typeclasses.resolve_typeclasses env sigma in sigma, nf_evar sigma c else let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma c) lbind in let flags = { (default_unify_flags ()) with resolve_evars = true } in let clause = clenv_unify_meta_types ~flags clause in let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in let rec chk = function | [] -> [] | t::l -> if occur_meta t then [] else t :: chk l in let tstack = chk tstack in let term = applist(thd,List.map (nf_evar clause.evd) tstack) in if occur_meta term then errorlabstrm "" (str "Cannot infer an instance for " ++ pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ str "."); clause.evd, term in let typ = Retyping.get_type_of env sigma term in let tac = match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> (* Like assert (id:=id args) but with the concept of specialization *) let naming,tac = prepare_intros false (IntroIdentifier id) MoveLast ipat in let repl = do_replace (Some id) naming in Tacticals.New.tclTHENFIRST (assert_before_then_gen repl naming typ tac) (exact_no_check term) | _ -> match ipat with | None -> (* Like generalize with extra support for "with" bindings *) (* even though the "with" bindings forces full application *) Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term) | Some (loc,ipat) -> (* Like pose proof with extra support for "with" bindings *) (* even though the "with" bindings forces full application *) let naming,tac = prepare_intros_loc loc false IntroAnonymous MoveLast ipat in Tacticals.New.tclTHENFIRST (assert_before_then_gen false naming typ tac) (exact_no_check term) in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac end } (*****************************) (* Ad hoc unfold *) (*****************************) (* The two following functions should already exist, but found nowhere *) (* Unfolds x by its definition everywhere *) let unfold_body x = let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> (** We normalize the given hypothesis immediately. *) let env = Proofview.Goal.env (Proofview.Goal.assume gl) in let xval = match Environ.lookup_named x env with | LocalAssum _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") | LocalDef (_,xval,_) -> xval in Tacticals.New.afterHyp x begin fun aft -> let hl = List.fold_right (fun decl cl -> (get_id decl, InHyp) :: cl) aft [] in let rfun _ _ c = replace_vars [x, xval] c in let reducth h = reduct_in_hyp rfun h in let reductc = reduct_in_concl (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] end end } (* Either unfold and clear if defined or simply clear if not a definition *) let expand_hyp id = Tacticals.New.tclTRY (unfold_body id) <*> clear [id] (*****************************) (* High-level induction *) (*****************************) (* * A "natural" induction tactic * - [H0:T0, ..., Hi:Ti, hyp0:P->I(args), Hi+1:Ti+1, ..., Hn:Tn |-G] is the goal - [hyp0] is the induction hypothesis - we extract from [args] the variables which are not rigid parameters of the inductive type, this is [indvars] (other terms are forgotten); - we look for all hyps depending of [hyp0] or one of [indvars]: this is [dephyps] of types [deptyps] respectively - [statuslist] tells for each hyps in [dephyps] after which other hyp fixed in the context they must be moved (when induction is done) - [hyp0succ] is the name of the hyp fixed in the context after which to move the subterms of [hyp0succ] in the i-th branch where it is supposed to be the i-th constructor of the inductive type. Strategy: (cf in [induction_with_atomization_of_ind_arg]) - requantify and clear all [dephyps] - apply induction on [hyp0] - clear those of [indvars] that are variables and [hyp0] - in the i-th subgoal, intro the arguments of the i-th constructor of the inductive type after [hyp0succ] (done in [induct_discharge]) let the induction hypotheses on top of the hyps because they may depend on variables between [hyp0] and the top. A counterpart is that the dep hyps programmed to be intro-ed on top must now be intro-ed after the induction hypotheses - move each of [dephyps] at the right place following the [statuslist] *) let warn_unused_intro_pattern = CWarnings.create ~name:"unused-intro-pattern" ~category:"tactics" (fun names -> strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (fst (run_delayed (Global.env()) Evd.empty c)))) names) let check_unused_names names = if not (List.is_empty names) && Flags.is_verbose () then warn_unused_intro_pattern names let intropattern_of_name gl avoid = function | Anonymous -> IntroNaming IntroAnonymous | Name id -> IntroNaming (IntroIdentifier (new_fresh_id avoid id gl)) let rec consume_pattern avoid na isdep gl = function | [] -> ((dloc, intropattern_of_name gl avoid na), []) | (loc,IntroForthcoming true)::names when not isdep -> consume_pattern avoid na isdep gl names | (loc,IntroForthcoming _)::names as fullpat -> let avoid = avoid@explicit_intro_names names in ((loc,intropattern_of_name gl avoid na), fullpat) | (loc,IntroNaming IntroAnonymous)::names -> let avoid = avoid@explicit_intro_names names in ((loc,intropattern_of_name gl avoid na), names) | (loc,IntroNaming (IntroFresh id'))::names -> let avoid = avoid@explicit_intro_names names in ((loc,IntroNaming (IntroIdentifier (new_fresh_id avoid id' gl))), names) | pat::names -> (pat,names) let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) = let tophyp = match tophyp with None -> MoveLast | Some hyp -> MoveAfter hyp in let newlstatus = (* if some IH has taken place at the top of hyps *) List.map (function (hyp,MoveLast) -> (hyp,tophyp) | x -> x) lstatus in Tacticals.New.tclTHEN (intros_move rstatus) (intros_move newlstatus) let dest_intro_patterns with_evars avoid thin dest pat tac = intro_patterns_core with_evars true avoid [] thin dest None 0 tac pat let safe_dest_intro_patterns with_evars avoid thin dest pat tac = Proofview.tclORELSE (dest_intro_patterns with_evars avoid thin dest pat tac) begin function (e, info) -> match e with | UserError ("move_hyp",_) -> (* May happen e.g. with "destruct x using s" with an hypothesis which is morally an induction hypothesis to be "MoveLast" if known as such but which is considered instead as a subterm of a constructor to be move at the place of x. *) dest_intro_patterns with_evars avoid thin MoveLast pat tac | e -> Proofview.tclZERO ~info e end type elim_arg_kind = RecArg | IndArg | OtherArg type recarg_position = | AfterFixedPosition of Id.t option (* None = top of context *) let update_dest (recargdests,tophyp as dests) = function | [] -> dests | hyp::_ -> (match recargdests with | AfterFixedPosition None -> AfterFixedPosition (Some hyp) | x -> x), (match tophyp with None -> Some hyp | x -> x) let get_recarg_dest (recargdests,tophyp) = match recargdests with | AfterFixedPosition None -> MoveLast | AfterFixedPosition (Some id) -> MoveAfter id (* Current policy re-introduces recursive arguments of destructed variable at the place of the original variable while induction hypothesese are introduced at the top of the context. Since in the general case of an inductive scheme, the induction hypotheses can arrive just after the recursive arguments (e.g. as in "forall t1:tree, P t1 -> forall t2:tree, P t2 -> P (node t1 t2)", we need to update the position for t2 after "P t1" is introduced if ever t2 had to be introduced at the top of the context). *) let induct_discharge with_evars dests avoid' tac (avoid,ra) names = let avoid = avoid @ avoid' in let rec peel_tac ra dests names thin = match ra with | (RecArg,_,deprec,recvarname) :: (IndArg,_,depind,hyprecname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (recpat,names) = match names with | [loc,IntroNaming (IntroIdentifier id) as pat] -> let id' = next_ident_away (add_prefix "IH" id) avoid in (pat, [dloc, IntroNaming (IntroIdentifier id')]) | _ -> consume_pattern avoid (Name recvarname) deprec gl names in let dest = get_recarg_dest dests in dest_intro_patterns with_evars avoid thin dest [recpat] (fun ids thin -> Proofview.Goal.enter { enter = begin fun gl -> let (hyprec,names) = consume_pattern avoid (Name hyprecname) depind gl names in dest_intro_patterns with_evars avoid thin MoveLast [hyprec] (fun ids' thin -> peel_tac ra' (update_dest dests ids') names thin) end }) end } | (IndArg,_,dep,hyprecname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = consume_pattern avoid (Name hyprecname) dep gl names in dest_intro_patterns with_evars avoid thin MoveLast [pat] (fun ids thin -> peel_tac ra' (update_dest dests ids) names thin) end } | (RecArg,_,dep,recvarname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (pat,names) = consume_pattern avoid (Name recvarname) dep gl names in let dest = get_recarg_dest dests in dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) end } | (OtherArg,_,dep,_) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (pat,names) = consume_pattern avoid Anonymous dep gl names in let dest = get_recarg_dest dests in safe_dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) end } | [] -> check_unused_names names; Tacticals.New.tclTHEN (clear_wildcards thin) (tac dests) in peel_tac ra dests names [] (* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas 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 sigma = Sigma.to_evar_map sigma in 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 = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in 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_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 args' avoid = if Int.equal i nparams then let t = applist (hd, params@args) in Tacticals.New.tclTHEN (change_in_hyp None (make_change_arg t) (hyp0,InHypTypeOnly)) (tac avoid) 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') -> (* 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) (c::args') (id::avoid) | _ -> 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) (c'::args') avoid else (* We reason blindly on the term and do as if it were generalizable, ignoring the constraints coming from its structure *) let id = match kind_of_term c with | Var id -> id | _ -> let type_of = Tacmach.New.pf_unsafe_type_of gl in id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in 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) (mkVar x::args') (x::avoid)) in atomize_one (List.length argl) [] [] [] end } (* [cook_sign] builds the lists [beforetoclear] (preceding the ind. var.) and [aftertoclear] (coming after the ind. var.) of hyps that must be erased, the lists of hyps to be generalize [decldeps] on the goal together with the places [(lstatus,rstatus)] where to re-intro them after induction. To know where to re-intro the dep hyp, we remember the name of the hypothesis [lhyp] after which (if the dep hyp is more recent than [hyp0]) or [rhyp] before which (if older than [hyp0]) its equivalent must be moved when the induction has been applied. Since computation of dependencies and [rhyp] is from more ancient (on the right) to more recent hyp (on the left) but the computation of [lhyp] progresses from the other way, [cook_hyp] is in two passes (an alternative would have been to write an higher-order algorithm). We use references to reduce the accumulation of arguments. To summarize, the situation looks like this Goal(n,x) -| H6:(Q n); x:A; H5:True; H4:(le O n); H3:(P n); H2:True; n:nat Left Right Induction hypothesis is H4 ([hyp0]) Variable parameters of (le O n) is the singleton list with "n" ([indvars]) The dependent hyps are H3 and H6 ([dephyps]) For H3 the memorized places are H5 ([lhyp]) and H2 ([rhyp]) because these names are among the hyp which are fixed through the induction For H6 the neighbours are None ([lhyp]) and H5 ([rhyp]) For H3, because on the right of H4, we remember rhyp (here H2) For H6, because on the left of H4, we remember lhyp (here None) For H4, we remember lhyp (here H5) The right neighbour is then translated into the left neighbour because move_hyp tactic needs the name of the hyp _after_ which we move the hyp to move. But, say in the 2nd subgoal of the hypotheses, the goal will be (m:nat)((P m)->(Q m)->(Goal m)) -> (P Sm)-> (Q Sm)-> (Goal Sm) ^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^ both go where H4 was goes where goes where H3 was H6 was We have to intro and move m and the recursive hyp first, but then where to move H3 ??? Only the hyp on its right is relevant, but we have to translate it into the name of the hyp on the left Note: this case where some hyp(s) in [dephyps] has(have) the same left neighbour as [hyp0] is the only problematic case with right neighbours. For the other cases (e.g. an hyp H1:(R n) between n and H2 would have posed no problem. But for uniformity, we decided to use the right hyp for all hyps on the right of H4. Other solutions are welcome PC 9 fev 06: Adapted to accept multi argument principle with no main arg hyp. hyp0 is now optional, meaning that it is possible that there is no main induction hypotheses. In this case, we consider the last "parameter" (in [indvars]) as the limit between "left" and "right", BUT it must be included in indhyps. Other solutions are still welcome *) exception Shunt of Id.t move_location let cook_sign hyp0_opt inhyps indvars env = (* First phase from L to R: get [toclear], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) let open Context.Named.Declaration in let toclear = ref [] in let avoid = ref [] in let decldeps = ref [] in let ldeps = ref [] in let rstatus = ref [] in let lstatus = ref [] in let before = ref true in let maindep = ref false in let seek_deps env decl rhyp = let hyp = get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then begin before:=false; (* Note that if there was no main induction hypotheses, then hyp is one of indvars too *) toclear := hyp::!toclear; MoveFirst (* fake value *) end else if Id.List.mem hyp indvars then begin (* The variables in indvars are such that they don't occur any more after generalization, so declare them to clear. *) toclear := hyp::!toclear; rhyp end else let dephyp0 = List.is_empty inhyps && (Option.cata (fun id -> occur_var_in_decl env id decl) false hyp0_opt) in let depother = List.is_empty inhyps && (List.exists (fun id -> occur_var_in_decl env id decl) indvars || List.exists (fun decl' -> occur_var_in_decl env (get_id decl') decl) !decldeps) in if not (List.is_empty inhyps) && Id.List.mem hyp inhyps || dephyp0 || depother then begin decldeps := decl::!decldeps; avoid := hyp::!avoid; maindep := dephyp0 || !maindep; if !before then begin toclear := hyp::!toclear; rstatus := (hyp,rhyp)::!rstatus end else begin toclear := hyp::!toclear; ldeps := hyp::!ldeps (* status computed in 2nd phase *) end; MoveBefore hyp end else MoveBefore hyp in let _ = fold_named_context seek_deps env ~init:MoveFirst in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) let compute_lstatus lhyp decl = let hyp = get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then raise (Shunt lhyp); if Id.List.mem hyp !ldeps then begin lstatus := (hyp,lhyp)::!lstatus; lhyp end else if Id.List.mem hyp !toclear then lhyp else MoveAfter hyp in try let _ = fold_named_context_reverse compute_lstatus ~init:MoveLast env in raise (Shunt MoveLast) (* ?? FIXME *) with Shunt lhyp0 -> let lhyp0 = match lhyp0 with | MoveLast -> None | MoveAfter hyp -> Some hyp | _ -> assert false in let statuslists = (!lstatus,List.rev !rstatus) in let recargdests = AfterFixedPosition (if Option.is_empty hyp0_opt then None else lhyp0) in (statuslists, (recargdests,None), !toclear, !decldeps, !avoid, !maindep) (* The general form of an induction principle is the following: forall prm1 prm2 ... prmp, (induction parameters) forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates) branch1, branch2, ... , branchr, (branches of the principle) forall (x1:Ti_1) (x2:Ti_2) ... (xni:Ti_ni), (induction arguments) (HI: I prm1..prmp x1...xni) (optional main induction arg) -> (Qi x1...xni HI (f prm1...prmp x1...xni)).(conclusion) ^^ ^^^^^^^^^^^^^^^^^^^^^^^^ optional optional argument added if even if HI principle generated by functional present above induction, only if HI does not exist [indarg] [farg] HI is not present when the induction principle does not come directly from an inductive type (like when it is generated by functional induction for example). HI is present otherwise BUT may not appear in the conclusion (dependent principle). HI and (f...) cannot be both present. Principles taken from functional induction have the final (f...).*) (* [rel_contexts] and [rel_declaration] actually contain triples, and lists are actually in reverse order to fit [compose_prod]. *) type elim_scheme = { elimc: constr with_bindings option; elimt: types; indref: global_reference option; params: Context.Rel.t; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (* number of parameters *) predicates: Context.Rel.t; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) npredicates: int; (* Number of predicates *) branches: Context.Rel.t; (* branchr,...,branch1 *) nbranches: int; (* Number of branches *) args: Context.Rel.t; (* (xni, Ti_ni) ... (x1, Ti_1) *) nargs: int; (* number of arguments *) indarg: Context.Rel.Declaration.t option; (* Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) concl: types; (* Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) } let empty_scheme = { elimc = None; elimt = mkProp; indref = None; params = []; nparams = 0; predicates = []; npredicates = 0; branches = []; nbranches = 0; args = []; nargs = 0; indarg = None; concl = mkProp; indarg_in_concl = false; farg_in_concl = false; } let make_base n id = if Int.equal n 0 || Int.equal n 1 then id else (* This extends the name to accept new digits if it already ends with *) (* digits *) Id.of_string (atompart_of_id (make_ident (Id.to_string id) (Some 0))) (* Builds two different names from an optional inductive type and a number, also deals with a list of names to avoid. If the inductive type is None, then hyprecname is IHi where i is a number. *) let make_up_names n ind_opt cname = let is_hyp = String.equal (atompart_of_id cname) "H" in let base = Id.to_string (make_base n cname) in let ind_prefix = "IH" in let base_ind = if is_hyp then match ind_opt with | None -> Id.of_string ind_prefix | Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id) else add_prefix ind_prefix cname in let hyprecname = make_base n base_ind in let avoid = if Int.equal n 1 (* Only one recursive argument *) || Int.equal n 0 then [] else (* Forbid to use cname, cname0, hyprecname and hyprecname0 *) (* in order to get names such as f1, f2, ... *) let avoid = (make_ident (Id.to_string hyprecname) None) :: (make_ident (Id.to_string hyprecname) (Some 0)) :: [] in if not (String.equal (atompart_of_id cname) "H") then (make_ident base (Some 0)) :: (make_ident base None) :: avoid else avoid in Id.of_string base, hyprecname, avoid let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in errorlabstrm "Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") let glob = Universes.constr_of_global let coq_eq = lazy (glob (Coqlib.build_coq_eq ())) let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ())) let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq") let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl") let mkEq t x y = mkApp (Lazy.force coq_eq, [| t; x; y |]) let mkRefl t x = mkApp (Lazy.force coq_eq_refl, [| t; x |]) let mkHEq t x u y = mkApp (Lazy.force coq_heq, [| t; x; u; y |]) let mkHRefl t x = mkApp (Lazy.force coq_heq_refl, [| t; x |]) let lift_togethern n l = let l', _ = List.fold_right (fun x (acc, n) -> (lift n x :: acc, succ n)) l ([], n) in l' let lift_list l = List.map (lift 1) l let ids_of_constr ?(all=false) vars c = let rec aux vars c = match kind_of_term c with | Var id -> Id.Set.add id vars | App (f, args) -> (match kind_of_term f with | Construct ((ind,_),_) | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in Array.fold_left_from (if all then 0 else mib.Declarations.mind_nparams) aux vars args | _ -> fold_constr aux vars c) | _ -> fold_constr aux vars c in aux vars c let decompose_indapp f args = match kind_of_term f with | Construct ((ind,_),_) | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in let first = mib.Declarations.mind_nparams_rec in let pars, args = Array.chop first args in mkApp (f, pars), args | _ -> f, args let mk_term_eq env sigma ty t ty' t' = let sigma = Sigma.to_evar_map sigma in if Reductionops.is_conv env sigma ty ty' then mkEq ty t t', mkRefl ty' t' else mkHEq ty t ty' t', mkHRefl ty' t' let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = let open Context.Rel.Declaration in Refine.refine { run = begin fun sigma -> let eqslen = List.length eqs in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) let abshypeq, abshypt = if dep then let eq, refl = mk_term_eq (push_rel_context ctx env) sigma (lift 1 c) (mkRel 1) typ (mkVar id) in mkProd (Anonymous, eq, lift 1 concl), [| refl |] else concl, [||] in (* 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 -> LocalAssum (Anonymous, x)) eqs) in let decl = match body with | None -> LocalAssum (Name id, c) | Some body -> LocalDef (Name id, body, c) in (* Abstract by the "generalized" hypothesis. *) let genarg = mkProd_or_LetIn decl abseqs in (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn genarg ctx in (* The goal will become this product. *) let Sigma (genc, sigma, p) = Evarutil.new_evar env sigma ~principal:true 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 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 (* Finally, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) Sigma (mkApp (appeqs, abshypt), sigma, p) end } let hyps_of_vars env sign nogen hyps = let open Context.Named.Declaration in if Id.Set.is_empty hyps then [] else let (_,lh) = Context.Named.fold_inside (fun (hs,hl) d -> let x = get_id d in if Id.Set.mem x nogen then (hs,hl) else if Id.Set.mem x hs then (hs,x::hl) else let xvars = global_vars_set_of_decl env d in if not (Id.Set.is_empty (Id.Set.diff xvars hs)) then (Id.Set.add x hs, x :: hl) else (hs, hl)) ~init:(hyps,[]) sign in lh exception Seen let linear vars args = let seen = ref vars in try Array.iter (fun i -> let rels = ids_of_constr ~all:true Id.Set.empty i in let seen' = Id.Set.fold (fun id acc -> if Id.Set.mem id acc then raise Seen else Id.Set.add id acc) rels !seen in seen := seen') args; true with Seen -> false let is_defined_variable env id = let open Context.Named.Declaration in lookup_named id env |> is_local_def let abstract_args gl generalize_vars dep id defined f args = let open Context.Rel.Declaration in let sigma = ref (Tacmach.project gl) in let env = Tacmach.pf_env gl in let concl = Tacmach.pf_concl gl in let dep = dep || dependent (mkVar id) concl in let avoid = ref [] in let get_id name = let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in avoid := id :: !avoid; id in (* Build application generalized w.r.t. the argument plus the necessary eqs. From env |- c : forall G, T and args : G we build (T[G'], G' : ctx, env ; G' |- args' : G, eqs := G'_i = G_i, refls : G' = G, vars to generalize) eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) *) let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = let name, ty, arity = let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in let decl = List.hd rel in get_name decl, get_type decl, c in let argty = Tacmach.pf_unsafe_type_of gl arg in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in let () = sigma := sigma' in let lenctx = List.length ctx in let liftargty = lift lenctx argty in let leq = constr_cmp Reduction.CUMUL liftargty ty in match kind_of_term arg with | Var id when not (is_defined_variable env id) && leq && not (Id.Set.mem id nongenvars) -> (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, Id.Set.add id nongenvars, Id.Set.remove id vars, env) | _ -> let name = get_id name in let decl = LocalAssum (Name name, ty) in let ctx = decl :: ctx in let c' = mkApp (lift 1 c, [|mkRel 1|]) in let args = arg :: args in let liftarg = lift (List.length ctx) arg in let eq, refl = if leq then mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl (lift (-lenctx) ty) arg else mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg in let eqs = eq :: lift_list eqs in let refls = refl :: refls in let argvars = ids_of_constr vars arg in (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, nongenvars, Id.Set.union argvars vars, env) in let f', args' = decompose_indapp f args in let dogen, f', args' = let parvars = ids_of_constr ~all:true Id.Set.empty f' in if not (linear parvars args') then true, f, args else match Array.findi (fun i x -> not (isVar x) || is_defined_variable env (destVar x)) args' with | None -> false, f', args' | Some nonvar -> let before, after = Array.chop nonvar args' in true, mkApp (f', before), after in if dogen then let tyf' = Tacmach.pf_unsafe_type_of gl f' in let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' in let args, refls = List.rev args, List.rev refls in let vars = if generalize_vars then let nogen = Id.Set.add id nogen in hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars else [] in let body, c' = if defined then Some c', Retyping.get_type_of ctxenv !sigma c' else None, c' in let typ = Tacmach.pf_get_hyp_typ gl id in let tac = make_abstract_generalize (pf_env gl) id typ concl dep ctx body c' eqs args refls in let tac = Proofview.Unsafe.tclEVARS !sigma <*> tac in Some (tac, dep, succ (List.length ctx), vars) else None let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Coqlib.check_required_library Coqlib.jmeq_module_name; let (f, args, def, id, oldid) = let oldid = Tacmach.New.pf_get_new_id id gl in match Tacmach.New.pf_get_hyp id gl with | LocalAssum (_,t) -> let f, args = decompose_app t in (f, args, false, id, oldid) | LocalDef (_,t,_) -> let f, args = decompose_app t in (f, args, true, id, oldid) in if List.is_empty args then Proofview.tclUNIT () else let args = Array.of_list args in let newc = Tacmach.New.of_old (fun gl -> abstract_args gl generalize_vars force_dep id def f args) gl in match newc with | None -> Proofview.tclUNIT () | Some (tac, dep, n, vars) -> let tac = if dep then Tacticals.New.tclTHENLIST [ tac; rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; generalize_dep ~with_let:true (mkVar oldid)] else Tacticals.New.tclTHENLIST [ tac; clear [id]; Tacticals.New.tclDO n intro] in if List.is_empty vars then tac else Tacticals.New.tclTHEN tac (Tacticals.New.tclFIRST [revert vars ; Tacticals.New.tclMAP (fun id -> Tacticals.New.tclTRY (generalize_dep ~with_let:true (mkVar id))) vars]) end } let rec compare_upto_variables x y = if (isVar x || isRel x) && (isVar y || isRel y) then true else compare_constr compare_upto_variables x y let specialize_eqs id gl = let open Context.Rel.Declaration in let env = Tacmach.pf_env gl in let ty = Tacmach.pf_get_hyp_typ gl id in let evars = ref (project gl) in let unif env evars c1 c2 = compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2 in let rec aux in_eqs ctx acc ty = match kind_of_term ty with | Prod (na, t, b) -> (match kind_of_term t with | App (eq, [| eqty; x; y |]) when Term.eq_constr (Lazy.force coq_eq) eq -> let c = if noccur_between 1 (List.length ctx) x then y else x in let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty | App (heq, [| eqty; x; eqty'; y |]) when Term.eq_constr heq (Lazy.force coq_heq) -> let eqt, c = if noccur_between 1 (List.length ctx) x then eqty', y else eqty, x in let pt = mkApp (Lazy.force coq_heq, [| eqt; c; eqt; c |]) in let p = mkApp (Lazy.force coq_heq_refl, [| eqt; c |]) in if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty | _ -> if in_eqs then acc, in_eqs, ctx, ty else let e = e_new_evar (push_rel_context ctx env) evars t in aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) | t -> acc, in_eqs, ctx, ty in let acc, worked, ctx, ty = aux false [] (mkVar id) ty in let ctx' = nf_rel_context_evar !evars ctx in let ctx'' = List.map (function | LocalDef (n,k,t) when isEvar k -> LocalAssum (n,t) | decl -> decl) ctx' in let ty' = it_mkProd_or_LetIn ty ctx'' in let acc' = it_mkLambda_or_LetIn acc ctx'' in let ty' = Tacred.whd_simpl env !evars ty' and acc' = Tacred.whd_simpl env !evars acc' in let ty' = Evarutil.nf_evar !evars ty' in if worked then tclTHENFIRST (Tacmach.internal_cut true id ty') (Proofview.V82.of_tactic (exact_no_check ((* refresh_universes_strict *) acc'))) gl else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl let specialize_eqs id = Proofview.Goal.nf_enter { enter = begin fun gl -> let msg = str "Specialization not allowed on dependent hypotheses" in Proofview.tclOR (clear [id]) (fun _ -> Tacticals.New.tclZEROMSG msg) >>= fun () -> Proofview.V82.tactic (specialize_eqs id) end } let occur_rel n c = let res = not (noccurn n c) in res (* This function splits the products of the induction scheme [elimt] into four parts: - branches, easily detectable (they are not referred by rels in the subterm) - what was found before branches (acc1) that is: parameters and predicates - what was found after branches (acc3) that is: args and indarg if any if there is no branch, we try to fill in acc3 with args/indargs. We also return the conclusion. *) let decompose_paramspred_branch_args elimt = let open Context.Rel.Declaration in let rec cut_noccur elimt acc2 = match kind_of_term elimt with | Prod(nme,tpe,elimt') -> let hd_tpe,_ = decompose_app ((strip_prod_assum tpe)) in if not (occur_rel 1 elimt') && isRel hd_tpe then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt | _ -> error_ind_scheme "" in let rec cut_occur elimt acc1 = match kind_of_term elimt with | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c (LocalAssum (nme,tpe)::acc1) | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl | App(_, _) | Rel _ -> acc1,[],[],elimt | _ -> error_ind_scheme "" in let acc1, acc2 , acc3, ccl = cut_occur elimt [] in (* Particular treatment when dealing with a dependent empty type elim scheme: if there is no branch, then acc1 contains all hyps which is wrong (acc1 should contain parameters and predicate only). This happens for an empty type (See for example Empty_set_ind, as False would actually be ok). Then we must find the predicate of the conclusion to separate params_pred from args. We suppose there is only one predicate here. *) match acc2 with | [] -> let hyps,ccl = decompose_prod_assum elimt in let hd_ccl_pred,_ = decompose_app ccl in begin match kind_of_term hd_ccl_pred with | Rel i -> let acc3,acc1 = List.chop (i-1) hyps in acc1 , [] , acc3 , ccl | _ -> error_ind_scheme "" end | _ -> acc1, acc2 , acc3, ccl let exchange_hd_app subst_hd t = let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args) (* Builds an elim_scheme from its type and calling form (const+binding). We first separate branches. We obtain branches, hyps before (params + preds), hyps after (args <+ indarg if present>) and conclusion. Then we proceed as follows: - separate parameters and predicates in params_preds. For that we build: forall (x1:Ti_1)(xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY x1...xni HI/farg ^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^ optional opt Free rels appearing in this term are parameters (branches should not appear, and the only predicate would have been Qi but we replaced it by DUMMY). We guess this heuristic catches all params. TODO: generalize to the case where args are merged with branches (?) and/or where several predicates are cited in the conclusion. - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *) let compute_elim_sig ?elimc elimt = let open Context.Rel.Declaration in let params_preds,branches,args_indargs,conclusion = decompose_paramspred_branch_args elimt in let ccl = exchange_hd_app (mkVar (Id.of_string "__QI_DUMMY__")) conclusion in let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in let nparams = Int.Set.cardinal (free_rels concl_with_args) in let preds,params = List.chop (List.length params_preds - nparams) params_preds in (* A first approximation, further analysis will tweak it *) let res = ref { empty_scheme with (* This fields are ok: *) elimc = elimc; elimt = elimt; concl = conclusion; predicates = preds; npredicates = List.length preds; branches = branches; nbranches = List.length branches; farg_in_concl = isApp ccl && isApp (last_arg ccl); params = params; nparams = nparams; (* all other fields are unsure at this point. Including these:*) args = args_indargs; nargs = List.length args_indargs; } in try (* Order of tests below is important. Each of them exits if successful. *) (* 1- First see if (f x...) is in the conclusion. *) if !res.farg_in_concl then begin res := { !res with indarg = None; indarg_in_concl = false; farg_in_concl = true }; raise Exit end; (* 2- If no args_indargs (=!res.nargs at this point) then no indarg *) if Int.equal !res.nargs 0 then raise Exit; (* 3- Look at last arg: is it the indarg? *) ignore ( match List.hd args_indargs with | LocalDef (hiname,_,hi) -> error_ind_scheme "" | LocalAssum (hiname,hi) -> let hi_ind, hi_args = decompose_app hi in let hi_is_ind = (* hi est d'un type globalisable *) match kind_of_term hi_ind with | Ind (mind,_) -> true | Var _ -> true | Const _ -> true | Construct _ -> true | _ -> false in let hi_args_enough = (* hi a le bon nbre d'arguments *) Int.equal (List.length hi_args) (List.length params + !res.nargs -1) in (* FIXME: Ces deux tests ne sont pas suffisants. *) if not (hi_is_ind && hi_args_enough) then raise Exit (* No indarg *) else (* Last arg is the indarg *) res := {!res with indarg = Some (List.hd !res.args); indarg_in_concl = occur_rel 1 ccl; args = List.tl !res.args; nargs = !res.nargs - 1; }; raise Exit); raise Exit(* exit anyway *) with Exit -> (* Ending by computing indref: *) match !res.indarg with | None -> !res (* No indref *) | Some (LocalDef _) -> error_ind_scheme "" | Some (LocalAssum (_,ind)) -> let indhd,indargs = decompose_app ind in try {!res with indref = Some (global_of_constr indhd) } with e when CErrors.noncritical e -> error "Cannot find the inductive type of the inductive scheme." let compute_scheme_signature scheme names_info ind_type_guess = let open Context.Rel.Declaration in let f,l = decompose_app scheme.concl in (* Vérifier que les arguments de Qi sont bien les xi. *) let cond, check_concl = match scheme.indarg with | Some (LocalDef _) -> error "Strange letin, cannot recognize an induction scheme." | None -> (* Non standard scheme *) let cond hd = Term.eq_constr hd ind_type_guess && not scheme.farg_in_concl in (cond, fun _ _ -> ()) | Some (LocalAssum (_,ind)) -> (* Standard scheme from an inductive type *) let indhd,indargs = decompose_app ind in let cond hd = Term.eq_constr hd indhd in let check_concl is_pred p = (* Check again conclusion *) let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f == IndArg in let ind_is_ok = List.equal Term.eq_constr (List.lastn scheme.nargs indargs) (Context.Rel.to_extended_list 0 scheme.args) in if not (ccl_arg_ok && ind_is_ok) then error_ind_scheme "the conclusion of" in (cond, check_concl) in let is_pred n c = let hd = fst (decompose_app c) in match kind_of_term hd with | Rel q when n < q && q <= n+scheme.npredicates -> IndArg | _ when cond hd -> RecArg | _ -> OtherArg in let rec check_branch p c = match kind_of_term c with | Prod (_,t,c) -> (is_pred p t, true, dependent (mkRel 1) c) :: check_branch (p+1) c | LetIn (_,_,_,c) -> (OtherArg, false, dependent (mkRel 1) c) :: check_branch (p+1) c | _ when is_pred p c == IndArg -> [] | _ -> raise Exit in let rec find_branches p lbrch = match lbrch with | LocalAssum (_,t) :: brs -> (try let lchck_brch = check_branch p t in let n = List.fold_left (fun n (b,_,_) -> if b == RecArg then n+1 else n) 0 lchck_brch in let recvarname, hyprecname, avoid = make_up_names n scheme.indref names_info in let namesign = List.map (fun (b,is_assum,dep) -> (b,is_assum,dep,if b == IndArg then hyprecname else recvarname)) lchck_brch in (avoid,namesign) :: find_branches (p+1) brs with Exit-> error_ind_scheme "the branches of") | LocalDef _ :: _ -> error_ind_scheme "the branches of" | [] -> check_concl is_pred p; [] in Array.of_list (find_branches 0 (List.rev scheme.branches)) (* Check that the elimination scheme has a form similar to the elimination schemes built by Coq. Schemes may have the standard form computed from an inductive type OR (feb. 2006) a non standard form. That is: with no main induction argument and with an optional extra final argument of the form (f x y ...) in the conclusion. In the non standard case, naming of generated hypos is slightly different. *) let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = let scheme = compute_elim_sig ~elimc:elimc elimt in evd, (compute_scheme_signature scheme names_info ind_type_guess, scheme) let guess_elim isrec dep s hyp0 gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in let mind,_ = Tacmach.New.pf_reduce_to_quantified_ind gl tmptyp0 in let evd, elimc = if isrec && not (is_nonrec (fst mind)) then find_ind_eliminator (fst mind) s gl else let env = Tacmach.New.pf_env gl in let sigma = Sigma.Unsafe.of_evar_map (Tacmach.New.project gl) in if use_dependent_propositions_elimination () && dep then let Sigma (ind, sigma, _) = build_case_analysis_scheme env sigma mind true s in (Sigma.to_evar_map sigma, ind) else let Sigma (ind, sigma, _) = build_case_analysis_scheme_default env sigma mind s in (Sigma.to_evar_map sigma, ind) in let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in evd, ((elimc, NoBindings), elimt), mkIndU mind let given_elim hyp0 (elimc,lbind as e) gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in Tacmach.New.project gl, (e, Tacmach.New.pf_unsafe_type_of gl elimc), ind_type_guess type scheme_signature = (Id.t list * (elim_arg_kind * bool * bool * Id.t) list) array type eliminator_source = | ElimUsing of (eliminator * types) * scheme_signature | ElimOver of bool * Id.t let find_induction_type isrec elim hyp0 gl = let scheme,elim = match elim with | None -> let sort = Tacticals.New.elimination_sort_of_goal gl in let _, (elimc,elimt),_ = guess_elim isrec (* dummy: *) true sort hyp0 gl in let scheme = compute_elim_sig ~elimc elimt in (* We drop the scheme waiting to know if it is dependent *) scheme, ElimOver (isrec,hyp0) | Some e -> let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in let scheme = compute_elim_sig ~elimc elimt in if Option.is_empty scheme.indarg then error "Cannot find induction type"; let indsign = compute_scheme_signature scheme hyp0 ind_guess in let elim = ({elimindex = Some(-1); elimbody = elimc; elimrename = None},elimt) in scheme, ElimUsing (elim,indsign) in match scheme.indref with | None -> error_ind_scheme "" | Some ref -> ref, scheme.nparams, elim let get_elim_signature elim hyp0 gl = compute_elim_signature (given_elim hyp0 elim gl) hyp0 let is_functional_induction elimc gl = let scheme = compute_elim_sig ~elimc (Tacmach.New.pf_unsafe_type_of gl (fst elimc)) in (* The test is not safe: with non-functional induction on non-standard induction scheme, this may fail *) Option.is_empty scheme.indarg (* Wait the last moment to guess the eliminator so as to know if we need a dependent one or not *) let get_eliminator elim dep s gl = let open Context.Rel.Declaration in match elim with | ElimUsing (elim,indsign) -> Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in let branchlengthes = List.map (fun d -> assert (is_local_assum d); pi1 (decompose_prod_letin (get_type d))) (List.rev s.branches) in evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l (* Instantiate all meta variables of elimclause using lid, some elts of lid are parameters (first ones), the other are arguments. Returns the clause obtained. *) let recolle_clenv i params args elimclause gl = let _,arr = destApp elimclause.templval.rebus in let lindmv = Array.map (fun x -> match kind_of_term x with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" (str "The type of the elimination clause is not well-formed.")) arr in let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in (* parameters correspond to first elts of lid. *) let clauses_params = List.map_i (fun i id -> mkVar id , pf_get_hyp_typ id gl, lindmv.(i)) 0 params in let clauses_args = List.map_i (fun i id -> mkVar id , pf_get_hyp_typ id gl, lindmv.(k+i)) 0 args in let clauses = clauses_params@clauses_args in (* iteration of clenv_fchain with all infos we have. *) List.fold_right (fun e acc -> let x,y,i = e in (* from_n (Some 0) means that x should be taken "as is" without trying to unify (which would lead to trying to apply it to evars if y is a product). *) let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from_n gl (Some 0) (x,y)) gl in let elimclause' = clenv_fchain ~with_univs:false i acc indclause in elimclause') (List.rev clauses) elimclause (* Unification of the goal and the principle applied to meta variables: (elimc ?i ?j ?k...?l). This solves partly meta variables (and may produce new ones). Then refine with the resulting term with holes. *) let induction_tac with_evars params indvars elim = Proofview.Goal.nf_enter { enter = begin fun gl -> let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in let i = match i with None -> index_of_ind_arg elimt | Some i -> i in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) let elimc = contract_letin_in_lam_header elimc in let elimc = mkCast (elimc, DEFAULTcast, elimt) in let elimclause = pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in (* elimclause' is built from elimclause by instanciating all args and params. *) let elimclause' = recolle_clenv i params indvars elimclause gl in (* one last resolution (useless?) *) let resolved = Tacmach.New.of_old (clenv_unique_resolver ~flags:(elim_flags ()) elimclause') gl in enforce_prop_bound_names rename (Clenvtac.clenv_refine with_evars resolved) end } (* Apply induction "in place" taking into account dependent hypotheses from the context, replacing the main hypothesis on which induction applies with the induction hypotheses *) let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_tac = let open Context.Named.Declaration in Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let concl = Tacmach.New.pf_nf_concl gl in let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env in let dep_in_concl = Option.cata (fun id -> occur_var env id concl) false hyp0 in let dep = dep_in_hyps || dep_in_concl in let tmpcl = it_mkNamedProd_or_LetIn concl deps in let s = Retyping.get_sort_family_of env sigma tmpcl in let deps_cstr = List.fold_left (fun a decl -> if is_local_assum decl then (mkVar (get_id decl))::a else a) [] deps in let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in let branchletsigns = let f (_,is_not_let,_,_) = is_not_let in Array.map (fun (_,l) -> List.map f l) indsign in let names = compute_induction_names branchletsigns names in let tac = (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) (Tacticals.New.tclTHENLIST [ (* Generalize dependent hyps (but not args) *) if deps = [] then Proofview.tclUNIT () else apply_type tmpcl deps_cstr; (* side-conditions in elim (resp case) schemes come last (resp first) *) induct_tac elim; Tacticals.New.tclMAP expand_hyp toclear; ]) (Array.map2 (induct_discharge with_evars lhyp0 avoid (re_intro_dependent_hypotheses statuslists)) indsign names) in Sigma.Unsafe.of_pair (tac, sigma) end } let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps = Proofview.Goal.enter { enter = begin fun gl -> let elim_info = find_induction_type isrec elim hyp0 (Proofview.Goal.assume gl) in atomize_param_of_ind_then elim_info hyp0 (fun indvars -> apply_induction_in_context with_evars (Some hyp0) inhyps (pi3 elim_info) indvars names (fun elim -> induction_tac with_evars [] [hyp0] elim)) end } let msg_not_right_number_induction_arguments scheme = str"Not the right number of induction arguments (expected " ++ pr_enum (fun x -> x) [ if scheme.farg_in_concl then str "the function name" else mt(); if scheme.nparams != 0 then int scheme.nparams ++ str (String.plural scheme.nparams " parameter") else mt (); if scheme.nargs != 0 then int scheme.nargs ++ str (String.plural scheme.nargs " argument") else mt ()] ++ str ")." (* Induction on a list of induction arguments. Analyze the elim scheme (which is mandatory for multiple ind args), check that all parameters and arguments are given (mandatory too). Main differences with induction_from_context is that there is no main induction argument. On the other hand, all args and params must be given, so we help a bit the unifier by making the "pattern" by hand before calling induction_tac *) let induction_without_atomization isrec with_evars elim names lid = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma, (indsign,scheme) = get_elim_signature elim (List.hd lid) gl in let nargs_indarg_farg = scheme.nargs + (if scheme.farg_in_concl then 1 else 0) in if not (Int.equal (List.length lid) (scheme.nparams + nargs_indarg_farg)) then Tacticals.New.tclZEROMSG (msg_not_right_number_induction_arguments scheme) else let indvars,lid_params = List.chop nargs_indarg_farg lid in (* terms to patternify we must patternify indarg or farg if present in concl *) let realindvars = List.rev (if scheme.farg_in_concl then List.tl indvars else indvars) in let lidcstr = List.map mkVar (List.rev indvars) in let params = List.rev lid_params in let indvars = (* Temporary hack for compatibility, while waiting for better analysis of the form of induction schemes: a scheme like gt_wf_rec was taken as a functional scheme with no parameters, but by chance, because of the addition of at least hyp0 for cook_sign, it behaved as if there was a real induction arg. *) if indvars = [] then [List.hd lid_params] else indvars in let induct_tac elim = Tacticals.New.tclTHENLIST [ (* pattern to make the predicate appear. *) reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl; (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all possible holes using arguments given by the user (but the functional one). *) (* FIXME: Tester ca avec un principe dependant et non-dependant *) induction_tac with_evars params realindvars elim; ] in let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in apply_induction_in_context with_evars None [] elim indvars names induct_tac end } (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls = Proofview.Goal.nf_enter { enter = begin fun gl -> let open Context.Named.Declaration in if occur_var (Tacmach.New.pf_env gl) id (Tacmach.New.pf_concl gl) && cls.concl_occs == NoOccurrences then errorlabstrm "" (str "Conclusion must be mentioned: it depends on " ++ pr_id id ++ str "."); match cls.onhyps with | Some hyps -> let to_erase d = let id' = get_id d in if Id.List.mem id' inhyps then (* if selected, do not erase *) None else (* erase if not selected and dependent on id or selected hyps *) let test id = occur_var_in_decl (Tacmach.New.pf_env gl) id d in if List.exists test (id::inhyps) then Some id' else None in let ids = List.map_filter to_erase (Proofview.Goal.hyps gl) in clear ids | None -> Proofview.tclUNIT () end } let use_bindings env sigma elim must_be_closed (c,lbind) typ = let sigma = Sigma.to_evar_map sigma in let typ = if elim == None then (* w/o an scheme, the term has to be applied at least until obtaining an inductive type (even though the arity might be known only by pattern-matching, as in the case of a term of the form "nat_rect ?A ?o ?s n", with ?A to be inferred by matching. *) let sign,t = splay_prod env sigma typ in it_mkProd t sign else (* Otherwise, we exclude the case of an induction argument in an explicitly functional type. Henceforth, we can complete the pattern until it has as type an atomic type (even though this atomic type can hide a functional type, for which the "using" clause has a scheme). *) typ in let rec find_clause typ = try let indclause = make_clenv_binding env sigma (c,typ) lbind in if must_be_closed && occur_meta (clenv_value indclause) then error "Need a fully applied argument."; (* We lose the possibility of coercions in with-bindings *) let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in Sigma.Unsafe.of_pair (c, sigma) with e when catchable_exception e -> try find_clause (try_red_product env sigma typ) with Redelimination -> raise e in find_clause typ let check_expected_type env sigma (elimc,bl) elimt = (* Compute the expected template type of the term in case a using clause is given *) let sign,_ = splay_prod env sigma elimt in let n = List.length sign in if n == 0 then error "Scheme cannot be applied."; let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in let sigma = solve_evar_clause env sigma true cl bl in let (_,u,_) = destProd cl.cl_concl in fun t -> Evarconv.e_cumul env (ref sigma) t u let check_enough_applied env sigma elim = let sigma = Sigma.to_evar_map sigma in (* A heuristic to decide whether the induction arg is enough applied *) match elim with | None -> (* No eliminator given *) fun u -> let t,_ = decompose_app (whd_all env sigma u) in isInd t | Some elimc -> let elimt = Retyping.get_type_of env sigma (fst elimc) in let scheme = compute_elim_sig ~elimc elimt in match scheme.indref with | None -> (* in the absence of information, do not assume it may be partially applied *) fun _ -> true | Some _ -> (* Last argument is supposed to be the induction argument *) check_expected_type env sigma elimc elimt let guard_no_unifiable = Proofview.guard_no_unifiable >>= function | None -> Proofview.tclUNIT () | Some l -> Proofview.tclZERO (RefinerError (UnresolvedBindings l)) let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in let check = check_enough_applied env sigma elim in let Sigma (c, sigma', p) = use_bindings env sigma elim false (c0,lbind) t0 in let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in match res with | None -> (* pattern not found *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* we restart using bindings after having tried type-class resolution etc. on the term given by the user *) let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in let Sigma (c0, sigma, q) = finish_evar_resolution ~flags env sigma (pending,c0) in let tac = (if isrec then (* Historically, induction has side conditions last *) Tacticals.New.tclTHENFIRST else (* and destruct has side conditions first *) Tacticals.New.tclTHENLAST) (Tacticals.New.tclTHENLIST [ Refine.refine ~unsafe:true { run = begin fun sigma -> let b = not with_evars && with_eq != None in let Sigma (c, sigma, p) = use_bindings env sigma elim b (c0,lbind) t0 in let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in let Sigma (ans, sigma, q) = mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) in Sigma (ans, sigma, p +> q) end }; if with_evars then Proofview.shelve_unifiable else guard_no_unifiable; if is_arg_pure_hyp then Tacticals.New.tclTRY (clear [destVar c0]) else Proofview.tclUNIT (); if isrec then Proofview.cycle (-1) else Proofview.tclUNIT () ]) tac in Sigma (tac, sigma, q) | Some (Sigma (c, sigma', q)) -> (* pattern found *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) let env = reset_with_named_context sign env in let tac = Tacticals.New.tclTHENLIST [ Refine.refine ~unsafe:true { run = begin fun sigma -> mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None end }; tac ] in Sigma (tac, sigma', p +> q) end } let has_generic_occurrences_but_goal cls id env ccl = clause_with_generic_context_selection cls && (* TODO: whd_evar of goal *) (cls.concl_occs != NoOccurrences || not (occur_var env id ccl)) let induction_gen clear_flag isrec with_evars elim ((_pending,(c,lbind)),(eqname,names) as arg) cls = let inhyps = match cls with | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps | _ -> [] in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let ccl = Proofview.Goal.raw_concl gl in let cls = Option.default allHypsAndConcl cls in let t = typ_of env sigma c in let is_arg_pure_hyp = isVar c && not (mem_named_context_val (destVar c) (Global.named_context_val ())) && lbind == NoBindings && not with_evars && Option.is_empty eqname && clear_flag == None && has_generic_occurrences_but_goal cls (destVar c) env ccl in let enough_applied = check_enough_applied env sigma elim t in if is_arg_pure_hyp && enough_applied then (* First case: induction on a variable already in an inductive type and with maximal abstraction over the variable. This is a situation where the induction argument is a clearable variable of the goal w/o occurrence selection and w/o equality kept: no need to generalize *) let id = destVar c in Tacticals.New.tclTHEN (clear_unselected_context id inhyps cls) (induction_with_atomization_of_ind_arg isrec with_evars elim names id inhyps) else (* Otherwise, we look for the pattern, possibly adding missing arguments and declaring the induction argument as a new local variable *) let id = (* Type not the right one if partially applied but anyway for internal use*) let x = id_of_name_using_hdchar (Global.env()) t Anonymous in new_fresh_id [] x gl in let info_arg = (is_arg_pure_hyp, not enough_applied) in pose_induction_arg_then isrec with_evars info_arg elim id arg t inhyps cls (induction_with_atomization_of_ind_arg isrec with_evars elim names id inhyps) end } (* Induction on a list of arguments. First make induction arguments atomic (using letins), then do induction. The specificity here is that all arguments and parameters of the scheme are given (mandatory for the moment), so we don't need to deal with parameters of the inductive type as in induction_gen. *) let induction_gen_l isrec with_evars elim names lc = let newlc = ref [] in let lc = List.map (function | (c,None) -> c | (c,Some(loc,eqname)) -> user_err_loc (loc,"",str "Do not know what to do with " ++ Miscprint.pr_intro_pattern_naming eqname)) lc in let rec atomize_list l = match l with | [] -> Proofview.tclUNIT () | c::l' -> match kind_of_term c with | Var id when not (mem_named_context_val id (Global.named_context_val ())) && not with_evars -> let _ = newlc:= id::!newlc in atomize_list l' | _ -> Proofview.Goal.enter { enter = begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in let x = id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in let id = new_fresh_id [] x gl in let newl' = List.map (replace_term c (mkVar id)) l' in let _ = newlc:=id::!newlc in Tacticals.New.tclTHEN (letin_tac None (Name id) c None allHypsAndConcl) (atomize_list newl') end } in Tacticals.New.tclTHENLIST [ (atomize_list lc); (Proofview.tclUNIT () >>= fun () -> (* ensure newlc has been computed *) induction_without_atomization isrec with_evars elim names !newlc) ] (* Induction either over a term, over a quantified premisse, or over several quantified premisses (like with functional induction principles). TODO: really unify induction with one and induction with several args *) let induction_destruct isrec with_evars (lc,elim) = match lc with | [] -> assert false (* ensured by syntax, but if called inside caml? *) | [c,(eqname,names as allnames),cls] -> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match elim with | Some elim when is_functional_induction elim gl -> (* Standard induction on non-standard induction schemes *) (* will be removable when is_functional_induction will be more clever *) if not (Option.is_empty cls) then error "'in' clause not supported here."; let _,c = force_destruction_arg false env sigma c in onInductionArg (fun _clear_flag c -> induction_gen_l isrec with_evars elim names [with_no_bindings c,eqname]) c | _ -> (* standard induction *) onOpenInductionArg env sigma (fun clear_flag c -> induction_gen clear_flag isrec with_evars elim (c,allnames) cls) c end } | _ -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match elim with | None -> (* Several arguments, without "using" clause *) (* TODO: Do as if the arguments after the first one were called with *) (* "destruct", but selecting occurrences on the initial copy of *) (* the goal *) let (a,b,cl) = List.hd lc in let l = List.tl lc in (* TODO *) Tacticals.New.tclTHEN (onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag isrec with_evars None (a,b) cl) a) (Tacticals.New.tclMAP (fun (a,b,cl) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag false with_evars None (a,b) cl) a end }) l) | Some elim -> (* Several induction hyps with induction scheme *) let lc = List.map (on_pi1 (fun c -> snd (force_destruction_arg false env sigma c))) lc in let newlc = List.map (fun (x,(eqn,names),cls) -> if cls != None then error "'in' clause not yet supported here."; match x with (* FIXME: should we deal with ElimOnIdent? *) | _clear_flag,ElimOnConstr x -> if eqn <> None then error "'eqn' clause not supported here."; (with_no_bindings x,names) | _ -> error "Don't know where to find some argument.") lc in (* Check that "as", if any, is given only on the last argument *) let names,rest = List.sep_last (List.map snd newlc) in if List.exists (fun n -> not (Option.is_empty n)) rest then error "'as' clause with multiple arguments and 'using' clause can only occur last."; let newlc = List.map (fun (x,_) -> (x,None)) newlc in induction_gen_l isrec with_evars elim names newlc end } let induction ev clr c l e = induction_gen clr true ev e (((Evd.empty,Evd.empty),(c,NoBindings)),(None,l)) None let destruct ev clr c l e = induction_gen clr false ev e (((Evd.empty,Evd.empty),(c,NoBindings)),(None,l)) None (* The registered tactic, which calls the default elimination * if no elimination constant is provided. *) (* Induction tactics *) (* This was Induction before 6.3 (induction only in quantified premisses) *) let simple_induct_id s = Tacticals.New.tclTHEN (intros_until_id s) (Tacticals.New.onLastHyp simplest_elim) let simple_induct_nodep n = Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHyp simplest_elim) let simple_induct = function | NamedHyp id -> simple_induct_id id | AnonHyp n -> simple_induct_nodep n (* Destruction tactics *) let simple_destruct_id s = (Tacticals.New.tclTHEN (intros_until_id s) (Tacticals.New.onLastHyp simplest_case)) let simple_destruct_nodep n = (Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHyp simplest_case)) let simple_destruct = function | NamedHyp id -> simple_destruct_id id | AnonHyp n -> simple_destruct_nodep n (* * Eliminations giving the type instead of the proof. * These tactics use the default elimination constant and * no substitutions at all. * May be they should be integrated into Elim ... *) let elim_scheme_type elim t = Proofview.Goal.nf_enter { enter = begin fun gl -> let clause = Tacmach.New.of_old (fun gl -> mk_clenv_type_of gl elim) gl in match kind_of_term (last_arg clause.templval.rebus) with | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t (clenv_meta_type clause mv) clause in Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false | _ -> anomaly (Pp.str "elim_scheme_type") end } let elim_type t = Proofview.Goal.s_enter { s_enter = begin fun gl -> let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) end } let case_type t = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Tacmach.New.pf_env gl in let (ind,t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in let s = Tacticals.New.elimination_sort_of_goal gl in let Sigma (elimc, evd, p) = build_case_analysis_scheme_default env sigma ind s in Sigma (elim_scheme_type elimc t, evd, p) end } (************************************************) (* Tactics related with logic connectives *) (************************************************) (* Reflexivity tactics *) let (forward_setoid_reflexivity, setoid_reflexivity) = Hook.make () let maybe_betadeltaiota_concl allowred gl = let concl = Tacmach.New.pf_nf_concl gl in let sigma = Tacmach.New.project gl in if not allowred then concl else let env = Proofview.Goal.env gl in whd_all env sigma concl let reflexivity_red allowred = Proofview.Goal.enter { enter = begin fun gl -> (* PL: usual reflexivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = maybe_betadeltaiota_concl allowred gl in match match_with_equality_type concl with | None -> Proofview.tclZERO NoEquationFound | Some _ -> one_constructor 1 NoBindings end } let reflexivity = Proofview.tclORELSE (reflexivity_red false) begin function (e, info) -> match e with | NoEquationFound -> Hook.get forward_setoid_reflexivity | e -> Proofview.tclZERO ~info e end let intros_reflexivity = (Tacticals.New.tclTHEN intros reflexivity) (* Symmetry tactics *) (* This tactic first tries to apply a constant named sym_eq, where eq is the name of the equality predicate. If this constant is not defined and the conclusion is a=b, it solves the goal doing (Cut b=a;Intro H;Case H;Constructor 1) *) let (forward_setoid_symmetry, setoid_symmetry) = Hook.make () (* This is probably not very useful any longer *) let prove_symmetry hdcncl eq_kind = let symc = match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp(hdcncl,[|c2;c1|]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp(hdcncl,[|typ;c2;c1|]) | HeterogenousEq (t1,c1,t2,c2) -> mkApp(hdcncl,[|t2;c2;t1;c1|]) in Tacticals.New.tclTHENFIRST (cut symc) (Tacticals.New.tclTHENLIST [ intro; Tacticals.New.onLastHyp simplest_case; one_constructor 1 NoBindings ]) let match_with_equation c = try let res = match_with_equation c in Proofview.tclUNIT res with NoEquationFound -> Proofview.tclZERO NoEquationFound let symmetry_red allowred = Proofview.Goal.enter { enter = begin fun gl -> (* PL: usual symmetry don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = maybe_betadeltaiota_concl allowred gl in match_with_equation concl >>= fun with_eqn -> match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN (convert_concl_no_check concl DEFAULTcast) (Tacticals.New.pf_constr_of_global eq_data.sym apply) | None,eq,eq_kind -> prove_symmetry eq eq_kind end } let symmetry = Proofview.tclORELSE (symmetry_red false) begin function (e, info) -> match e with | NoEquationFound -> Hook.get forward_setoid_symmetry | e -> Proofview.tclZERO ~info e end let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make () let symmetry_in id = Proofview.Goal.enter { enter = begin fun gl -> let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in let sign,t = decompose_prod_assum ctype in Proofview.tclORELSE begin match_with_equation t >>= fun (_,hdcncl,eq) -> let symccl = match eq with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |]) | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in Tacticals.New.tclTHENS (cut (it_mkProd_or_LetIn symccl sign)) [ intro_replacing id; Tacticals.New.tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ] end begin function (e, info) -> match e with | NoEquationFound -> Hook.get forward_setoid_symmetry_in id | e -> Proofview.tclZERO ~info e end end } let intros_symmetry = Tacticals.New.onClause (function | None -> Tacticals.New.tclTHEN intros symmetry | Some id -> symmetry_in id) (* Transitivity tactics *) (* This tactic first tries to apply a constant named eq_trans, where eq is the name of the equality predicate. If this constant is not defined and the conclusion is a=b, it solves the goal doing Cut x1=x2; [Cut x2=x3; [Intros e1 e2; Case e2;Assumption | Idtac] | Idtac] --Eduardo (19/8/97) *) let (forward_setoid_transitivity, setoid_transitivity) = Hook.make () (* This is probably not very useful any longer *) let prove_transitivity hdcncl eq_kind t = Proofview.Goal.enter { enter = begin fun gl -> let (eq1,eq2) = match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |]) | HeterogenousEq (typ1,c1,typ2,c2) -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let type_of = Typing.unsafe_type_of env sigma in let typt = type_of t in (mkApp(hdcncl, [| typ1; c1; typt ;t |]), mkApp(hdcncl, [| typt; t; typ2; c2 |])) in Tacticals.New.tclTHENFIRST (cut eq2) (Tacticals.New.tclTHENFIRST (cut eq1) (Tacticals.New.tclTHENLIST [ Tacticals.New.tclDO 2 intro; Tacticals.New.onLastHyp simplest_case; assumption ])) end } let transitivity_red allowred t = Proofview.Goal.enter { enter = begin fun gl -> (* PL: usual transitivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = maybe_betadeltaiota_concl allowred gl in match_with_equation concl >>= fun with_eqn -> match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN (convert_concl_no_check concl DEFAULTcast) (match t with | None -> Tacticals.New.pf_constr_of_global eq_data.trans eapply | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans (fun trans -> apply_list [trans;t])) | None,eq,eq_kind -> match t with | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.") | Some t -> prove_transitivity eq eq_kind t end } let transitivity_gen t = Proofview.tclORELSE (transitivity_red false t) begin function (e, info) -> match e with | NoEquationFound -> Hook.get forward_setoid_transitivity t | e -> Proofview.tclZERO ~info e end let etransitivity = transitivity_gen None let transitivity t = transitivity_gen (Some t) let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) (* tactical to save as name a subproof such that the generalisation of the current goal, abstracted with respect to the local signature, is solved by tac *) (** d1 is the section variable in the global context, d2 in the goal context *) let interpretable_as_section_decl evd d1 d2 = let open Context.Named.Declaration in match d2, d1 with | LocalDef _, LocalAssum _ -> false | LocalDef (_,b1,t1), LocalDef (_,b2,t2) -> e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2 | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (get_type d2) let rec decompose len c t accu = let open Context.Rel.Declaration in if len = 0 then (c, t, accu) else match kind_of_term c, kind_of_term t with | Lambda (na, u, c), Prod (_, _, t) -> decompose (pred len) c t (LocalAssum (na, u) :: accu) | LetIn (na, b, u, c), LetIn (_, _, _, t) -> decompose (pred len) c t (LocalDef (na, b, u) :: accu) | _ -> assert false let rec shrink ctx sign c t accu = let open Context.Rel.Declaration in match ctx, sign with | [], [] -> (c, t, accu) | p :: ctx, decl :: sign -> if noccurn 1 c && noccurn 1 t then let c = subst1 mkProp c in let t = subst1 mkProp t in shrink ctx sign c t accu else let c = mkLambda_or_LetIn p c in let t = mkProd_or_LetIn p t in let accu = if is_local_assum p then let open Context.Named.Declaration in mkVar (get_id decl) :: accu else accu in shrink ctx sign c t accu | _ -> assert false let shrink_entry sign const = let open Entries in let typ = match const.const_entry_type with | None -> assert false | Some t -> t in (** The body has been forced by the call to [build_constant_by_tactic] *) let () = assert (Future.is_over const.const_entry_body) in let ((body, uctx), eff) = Future.force const.const_entry_body in let (body, typ, ctx) = decompose (List.length sign) body typ [] in let (body, typ, args) = shrink ctx sign body typ [] in let const = { const with const_entry_body = Future.from_val ((body, uctx), eff); const_entry_type = Some typ; } in (const, args) let abstract_subproof id gk tac = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in let open Context.Named.Declaration in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let current_sign = Global.named_context_val () and global_sign = Proofview.Goal.hyps gl in let sigma = Sigma.to_evar_map sigma in let evdref = ref sigma in let sign,secsign = List.fold_right (fun d (s1,s2) -> let id = get_id d in if mem_named_context_val id current_sign && interpretable_as_section_decl evdref (lookup_named_val id current_sign) d then (s1,push_named_context_val d s2) else (Context.Named.add d s1,s2)) global_sign (Context.Named.empty, empty_named_context_val) in let id = next_global_ident_away id (pf_ids_of_hyps gl) in let concl = it_mkNamedProd_or_LetIn (Proofview.Goal.concl gl) sign in let concl = try flush_and_check_evars !evdref concl with Uninstantiated_evar _ -> error "\"abstract\" cannot handle existentials." in let evd, ctx, concl = (* FIXME: should be done only if the tactic succeeds *) let evd, nf = nf_evars_and_universes !evdref in let ctx = Evd.universe_context_set evd in evd, ctx, nf concl in let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac) in let ectx = Evd.evar_universe_context evd in let (const, safe, ectx) = try Pfedit.build_constant_by_tactic ~goal_kind:gk id ectx secsign concl solve_tac with Logic_monad.TacticFailure e as src -> (* if the tactic [tac] fails, it reports a [TacticFailure e], which is an error irrelevant to the proof system (in fact it means that [e] comes from [tac] failing to yield enough success). Hence it reraises [e]. *) let (_, info) = CErrors.push src in iraise (e, info) in let const, args = if !shrink_abstract then shrink_entry sign const else (const, List.rev (Context.Named.to_instance sign)) in let cd = Entries.DefinitionEntry const in let decl = (cd, IsProof Lemma) in let cst () = (** do not compute the implicit arguments, it may be costly *) let () = Impargs.make_implicit_args false in (** ppedrot: seems legit to have abstracted subproofs as local*) Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl in let cst = Impargs.with_implicit_protection cst () in (* let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in *) let lem, ctx = Universes.unsafe_constr_of_global (ConstRef cst) in let evd = Evd.set_universe_context evd ectx in let open Safe_typing in let eff = private_con_of_con (Global.safe_env ()) cst in let effs = add_private eff Entries.(snd (Future.force const.const_entry_body)) in let solve = Proofview.tclEFFECTS effs <*> exact_no_check (applist (lem, args)) in let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in Sigma.Unsafe.of_pair (tac, evd) end } let anon_id = Id.of_string "anonymous" let tclABSTRACT name_op tac = let open Proof_global in let default_gk = (Global, false, Proof Theorem) in let s, gk = match name_op with | Some s -> (try let _, gk, _ = current_proof_statement () in s, gk with NoCurrentProof -> s, default_gk) | None -> let name, gk = try let name, gk, _ = current_proof_statement () in name, gk with NoCurrentProof -> anon_id, default_gk in add_suffix name "_subproof", gk in abstract_subproof s gk tac let unify ?(state=full_transparent_state) x y = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in try let core_flags = { (default_unify_flags ()).core_unify_flags with modulo_delta = state; modulo_conv_on_closed_terms = Some state} in (* What to do on merge and subterm flags?? *) let flags = { (default_unify_flags ()) with core_unify_flags = core_flags; merge_unify_flags = core_flags; subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } } in let sigma = Sigma.to_evar_map sigma in let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in Sigma.Unsafe.of_pair (Proofview.tclUNIT (), sigma) with e when CErrors.noncritical e -> Sigma.here (Tacticals.New.tclFAIL 0 (str"Not unifiable")) sigma end } module Simple = struct (** Simplified version of some of the above tactics *) let intro x = intro_move (Some x) MoveLast let apply c = apply_with_bindings_gen false false [None,(Loc.ghost,(c,NoBindings))] let eapply c = apply_with_bindings_gen false true [None,(Loc.ghost,(c,NoBindings))] let elim c = elim false None (c,NoBindings) None let case c = general_case_analysis false None (c,NoBindings) let apply_in id c = apply_in false false id [None,(Loc.ghost, (c, NoBindings))] None end (** Tacticals defined directly in term of Proofview *) module New = struct open Proofview.Notations let exact_proof c = exact_proof c open Genredexpr open Locus let reduce_after_refine = let onhyps = (** We reduced everywhere in the hyps before 8.6 *) if Flags.version_compare !Flags.compat_version Flags.V8_5 == 0 then None else Some [] in reduce (Lazy {rBeta=true;rMatch=true;rFix=true;rCofix=true; rZeta=false;rDelta=false;rConst=[]}) {onhyps; concl_occs=AllOccurrences } let refine ?unsafe c = Refine.refine ?unsafe c <*> reduce_after_refine end coq-8.6/tactics/dnet.mli0000644000175000017500000001064213022274260014225 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* | Leaf | Node of btree * btree | Node of 'a * 'a *) (** datatype you want to build a dnet on *) module type Datatype = sig (** parametric datatype. ['a] is morally the recursive argument *) type 'a t (** non-recursive mapping of subterms *) val map : ('a -> 'b) -> 'a t -> 'b t val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** non-recursive folding of subterms *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a (** comparison of constructors *) val compare : unit t -> unit t -> int (** for each constructor, is it not-parametric on 'a? *) val terminal : 'a t -> bool (** [choose f w] applies f on ONE of the subterms of w *) val choose : ('a -> 'b) -> 'a t -> 'b end module type S = sig type t (** provided identifier type *) type ident (** provided metavariable type *) type meta (** provided parametrized datastructure *) type 'a structure (** returned sets of solutions *) module Idset : Set.S with type elt=ident (** a pattern is a term where each node can be a unification variable *) type term_pattern = | Term of term_pattern structure | Meta of meta val empty : t (** [add t w i] adds a new association (w,i) in t. *) val add : t -> term_pattern -> ident -> t (** [find_all t] returns all identifiers contained in t. *) val find_all : t -> Idset.t (** [fold_pattern f acc p dn] folds f on each meta of p, passing the meta and the sub-dnet under it. The result includes: - Some set if identifiers were gathered on the leafs of the term - None if the pattern contains no leaf (only Metas at the leafs). *) val fold_pattern : ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a (** [find_match p t] returns identifiers of all terms matching p in t. *) val find_match : term_pattern -> t -> Idset.t (** set operations on dnets *) val inter : t -> t -> t val union : t -> t -> t (** apply a function on each identifier and node of terms in a dnet *) val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t val map_metas : (meta -> meta) -> t -> t end module Make : functor (T:Datatype) -> functor (Ident:Set.OrderedType) -> functor (Meta:Set.OrderedType) -> S with type ident = Ident.t and type meta = Meta.t and type 'a structure = 'a T.t coq-8.6/tactics/hipattern.ml0000644000175000017500000004500313022274260015117 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* 'a option type testing_function = constr -> bool let mkmeta n = Nameops.make_ident "X" (Some n) let meta1 = mkmeta 1 let meta2 = mkmeta 2 let meta3 = mkmeta 3 let meta4 = mkmeta 4 let op2bool = function Some _ -> true | None -> false let match_with_non_recursive_type t = match kind_of_term t with | App _ -> let (hdapp,args) = decompose_app t in (match kind_of_term hdapp with | Ind (ind,u) -> if (Global.lookup_mind (fst ind)).mind_finite == Decl_kinds.CoFinite then Some (hdapp,args) else None | _ -> None) | _ -> None let is_non_recursive_type t = op2bool (match_with_non_recursive_type t) (* Test dependencies *) (* NB: we consider also the let-in case in the following function, since they may appear in types of inductive constructors (see #2629) *) let rec has_nodep_prod_after n c = match kind_of_term c with | Prod (_,_,b) | LetIn (_,_,_,b) -> ( n>0 || not (dependent (mkRel 1) b)) && (has_nodep_prod_after (n-1) b) | _ -> true let has_nodep_prod = has_nodep_prod_after 0 (* A general conjunctive type is a non-recursive with-no-indices inductive type with only one constructor and no dependencies between argument; it is strict if it has the form "Inductive I A1 ... An := C (_:A1) ... (_:An)" *) (* style: None = record; Some false = conjunction; Some true = strict conj *) let is_strict_conjunction = function | Some true -> true | _ -> false let is_lax_conjunction = function | Some false -> true | _ -> false let match_with_one_constructor style onlybinary allow_rec t = let (hdapp,args) = decompose_app t in let res = match kind_of_term hdapp with | Ind ind -> let (mib,mip) = Global.lookup_inductive (fst ind) in if Int.equal (Array.length mip.mind_consnames) 1 && (allow_rec || not (mis_is_recursive (fst ind,mib,mip))) && (Int.equal mip.mind_nrealargs 0) then if is_strict_conjunction style (* strict conjunction *) then let ctx = (prod_assum (snd (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in if List.for_all (fun decl -> let c = get_type decl in is_local_assum decl && isRel c && Int.equal (destRel c) mib.mind_nparams) ctx then Some (hdapp,args) else None else let ctyp = prod_applist mip.mind_nf_lc.(0) args in let cargs = List.map get_type (prod_assum ctyp) in if not (is_lax_conjunction style) || has_nodep_prod ctyp then (* Record or non strict conjunction *) Some (hdapp,List.rev cargs) else None else None | _ -> None in match res with | Some (hdapp, args) when not onlybinary -> res | Some (hdapp, [_; _]) -> res | _ -> None let match_with_conjunction ?(strict=false) ?(onlybinary=false) t = match_with_one_constructor (Some strict) onlybinary false t let match_with_record t = match_with_one_constructor None false false t let is_conjunction ?(strict=false) ?(onlybinary=false) t = op2bool (match_with_conjunction ~strict ~onlybinary t) let is_record t = op2bool (match_with_record t) let match_with_tuple t = let t = match_with_one_constructor None false true t in Option.map (fun (hd,l) -> let ind = destInd hd in let (mib,mip) = Global.lookup_pinductive ind in let isrec = mis_is_recursive (fst ind,mib,mip) in (hd,l,isrec)) t let is_tuple t = op2bool (match_with_tuple t) (* A general disjunction type is a non-recursive with-no-indices inductive type with of which all constructors have a single argument; it is strict if it has the form "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *) let test_strict_disjunction n lc = Array.for_all_i (fun i c -> match (prod_assum (snd (decompose_prod_n_assum n c))) with | [LocalAssum (_,c)] -> isRel c && Int.equal (destRel c) (n - i) | _ -> false) 0 lc let match_with_disjunction ?(strict=false) ?(onlybinary=false) t = let (hdapp,args) = decompose_app t in let res = match kind_of_term hdapp with | Ind (ind,u) -> let car = constructors_nrealargs ind in let (mib,mip) = Global.lookup_inductive ind in if Array.for_all (fun ar -> Int.equal ar 1) car && not (mis_is_recursive (ind,mib,mip)) && (Int.equal mip.mind_nrealargs 0) then if strict then if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then Some (hdapp,args) else None else let cargs = Array.map (fun ar -> pi2 (destProd (prod_applist ar args))) mip.mind_nf_lc in Some (hdapp,Array.to_list cargs) else None | _ -> None in match res with | Some (hdapp,args) when not onlybinary -> res | Some (hdapp,[_; _]) -> res | _ -> None let is_disjunction ?(strict=false) ?(onlybinary=false) t = op2bool (match_with_disjunction ~strict ~onlybinary t) (* An empty type is an inductive type, possible with indices, that has no constructors *) let match_with_empty_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> let (mib,mip) = Global.lookup_pinductive ind in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 0 then Some hdapp else None | _ -> None let is_empty_type t = op2bool (match_with_empty_type t) (* This filters inductive types with one constructor with no arguments; Parameters and indices are allowed *) let match_with_unit_or_eq_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> let (mib,mip) = Global.lookup_pinductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in let zero_args c = Int.equal (nb_prod c) mib.mind_nparams in if Int.equal nconstr 1 && zero_args constr_types.(0) then Some hdapp else None | _ -> None let is_unit_or_eq_type t = op2bool (match_with_unit_or_eq_type t) (* A unit type is an inductive type with no indices but possibly (useless) parameters, and that has no arguments in its unique constructor *) let is_unit_type t = match match_with_conjunction t with | Some (_,[]) -> true | _ -> false (* Checks if a given term is an application of an inductive binary relation R, so that R has only one constructor establishing its reflexivity. *) type equation_kind = | MonomorphicLeibnizEq of constr * constr | PolymorphicLeibnizEq of constr * constr * constr | HeterogenousEq of constr * constr * constr * constr exception NoEquationFound open Glob_term open Decl_kinds open Evar_kinds let mkPattern c = snd (Patternops.pattern_of_glob_constr c) let mkGApp f args = GApp (Loc.ghost, f, args) let mkGHole = GHole (Loc.ghost, QuestionMark (Define false), Misctypes.IntroAnonymous, None) let mkGProd id c1 c2 = GProd (Loc.ghost, Name (Id.of_string id), Explicit, c1, c2) let mkGArrow c1 c2 = GProd (Loc.ghost, Anonymous, Explicit, c1, c2) let mkGVar id = GVar (Loc.ghost, Id.of_string id) let mkGPatVar id = GPatVar(Loc.ghost, (false, Id.of_string id)) let mkGRef r = GRef (Loc.ghost, Lazy.force r, None) let mkGAppRef r args = mkGApp (mkGRef r) args (** forall x : _, _ x x *) let coq_refl_leibniz1_pattern = mkPattern (mkGProd "x" mkGHole (mkGApp mkGHole [mkGVar "x"; mkGVar "x";])) (** forall A:_, forall x:A, _ A x x *) let coq_refl_leibniz2_pattern = mkPattern (mkGProd "A" mkGHole (mkGProd "x" (mkGVar "A") (mkGApp mkGHole [mkGVar "A"; mkGVar "x"; mkGVar "x";]))) (** forall A:_, forall x:A, _ A x A x *) let coq_refl_jm_pattern = mkPattern (mkGProd "A" mkGHole (mkGProd "x" (mkGVar "A") (mkGApp mkGHole [mkGVar "A"; mkGVar "x"; mkGVar "A"; mkGVar "x";]))) open Globnames let is_matching x y = is_matching (Global.env ()) Evd.empty x y let matches x y = matches (Global.env ()) Evd.empty x y let match_with_equation t = if not (isApp t) then raise NoEquationFound; let (hdapp,args) = destApp t in match kind_of_term hdapp with | Ind (ind,u) -> if eq_gr (IndRef ind) glob_eq then Some (build_coq_eq_data()),hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) else if eq_gr (IndRef ind) glob_identity then Some (build_coq_identity_data()),hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) else if eq_gr (IndRef ind) glob_jmeq then Some (build_coq_jmeq_data()),hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) else let (mib,mip) = Global.lookup_inductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 1 then if is_matching coq_refl_leibniz1_pattern constr_types.(0) then None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) else if is_matching coq_refl_leibniz2_pattern constr_types.(0) then None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) else if is_matching coq_refl_jm_pattern constr_types.(0) then None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) else raise NoEquationFound else raise NoEquationFound | _ -> raise NoEquationFound (* Note: An "equality type" is any type with a single argument-free constructor: it captures eq, eq_dep, JMeq, eq_true, etc. but also True/unit which is the degenerate equality type (isomorphic to ()=()); in particular, True/unit are provable by "reflexivity" *) let is_inductive_equality ind = let (mib,mip) = Global.lookup_inductive ind in let nconstr = Array.length mip.mind_consnames in Int.equal nconstr 1 && Int.equal (constructor_nrealargs (ind,1)) 0 let match_with_equality_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args) | _ -> None let is_equality_type t = op2bool (match_with_equality_type t) (* Arrows/Implication/Negation *) (** X1 -> X2 **) let coq_arrow_pattern = mkPattern (mkGArrow (mkGPatVar "X1") (mkGPatVar "X2")) let match_arrow_pattern t = let result = matches coq_arrow_pattern t in match Id.Map.bindings result with | [(m1,arg);(m2,mind)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind) | _ -> anomaly (Pp.str "Incorrect pattern matching") let match_with_imp_term c= match kind_of_term c with | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b) | _ -> None let is_imp_term c = op2bool (match_with_imp_term c) let match_with_nottype t = try let (arg,mind) = match_arrow_pattern t in if is_empty_type mind then Some (mind,arg) else None with PatternMatchingFailure -> None let is_nottype t = op2bool (match_with_nottype t) (* Forall *) let match_with_forall_term c= match kind_of_term c with | Prod (nam,a,b) -> Some (nam,a,b) | _ -> None let is_forall_term c = op2bool (match_with_forall_term c) let match_with_nodep_ind t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> let (mib,mip) = Global.lookup_pinductive ind in if Array.length (mib.mind_packets)>1 then None else let nodep_constr = has_nodep_prod_after mib.mind_nparams in if Array.for_all nodep_constr mip.mind_nf_lc then let params= if Int.equal mip.mind_nrealargs 0 then args else fst (List.chop mib.mind_nparams args) in Some (hdapp,params,mip.mind_nrealargs) else None | _ -> None let is_nodep_ind t=op2bool (match_with_nodep_ind t) let match_with_sigma_type t= let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> let (mib,mip) = Global.lookup_pinductive ind in if Int.equal (Array.length (mib.mind_packets)) 1 && (Int.equal mip.mind_nrealargs 0) && (Int.equal (Array.length mip.mind_consnames)1) && has_nodep_prod_after (mib.mind_nparams+1) mip.mind_nf_lc.(0) then (*allowing only 1 existential*) Some (hdapp,args) else None | _ -> None let is_sigma_type t=op2bool (match_with_sigma_type t) (***** Destructing patterns bound to some theory *) let rec first_match matcher = function | [] -> raise PatternMatchingFailure | (pat,check,build_set)::l when check () -> (try (build_set (),matcher pat) with PatternMatchingFailure -> first_match matcher l) | _::l -> first_match matcher l (*** Equality *) let match_eq eqn (ref, hetero) = let ref = try Lazy.force ref with e when CErrors.noncritical e -> raise PatternMatchingFailure in match kind_of_term eqn with | App (c, [|t; x; y|]) -> if not hetero && is_global ref c then PolymorphicLeibnizEq (t, x, y) else raise PatternMatchingFailure | App (c, [|t; x; t'; x'|]) -> if hetero && is_global ref c then HeterogenousEq (t, x, t', x') else raise PatternMatchingFailure | _ -> raise PatternMatchingFailure let no_check () = true let check_jmeq_loaded () = Library.library_is_loaded Coqlib.jmeq_module let equalities = [(coq_eq_ref, false), no_check, build_coq_eq_data; (coq_jmeq_ref, true), check_jmeq_loaded, build_coq_jmeq_data; (coq_identity_ref, false), no_check, build_coq_identity_data] let find_eq_data eqn = (* fails with PatternMatchingFailure *) let d,k = first_match (match_eq eqn) equalities in let hd,u = destInd (fst (destApp eqn)) in d,u,k let extract_eq_args gl = function | MonomorphicLeibnizEq (e1,e2) -> let t = pf_unsafe_type_of gl e1 in (t,e1,e2) | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2) | HeterogenousEq (t1,e1,t2,e2) -> if pf_conv_x gl t1 t2 then (t1,e1,e2) else raise PatternMatchingFailure let find_eq_data_decompose gl eqn = let (lbeq,u,eq_args) = find_eq_data eqn in (lbeq,u,extract_eq_args gl eq_args) let find_this_eq_data_decompose gl eqn = let (lbeq,u,eq_args) = try (*first_match (match_eq eqn) inversible_equalities*) find_eq_data eqn with PatternMatchingFailure -> errorlabstrm "" (str "No primitive equality found.") in let eq_args = try extract_eq_args gl eq_args with PatternMatchingFailure -> error "Don't know what to do with JMeq on arguments not of same type." in (lbeq,u,eq_args) let match_eq_nf gls eqn (ref, hetero) = let n = if hetero then 4 else 3 in let args = List.init n (fun i -> mkGPatVar ("X" ^ string_of_int (i + 1))) in let pat = mkPattern (mkGAppRef ref args) in match Id.Map.bindings (pf_matches gls pat eqn) with | [(m1,t);(m2,x);(m3,y)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); (t,pf_whd_all gls x,pf_whd_all gls y) | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms") let dest_nf_eq gls eqn = try snd (first_match (match_eq_nf gls eqn) equalities) with PatternMatchingFailure -> error "Not an equality." (*** Sigma-types *) let match_sigma ex = match kind_of_term ex with | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_exist_ref) f -> build_sigma (), (snd (destConstruct f), a, p, car, cdr) | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_existT_ref) f -> build_sigma_type (), (snd (destConstruct f), a, p, car, cdr) | _ -> raise PatternMatchingFailure let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) match_sigma ex (* Pattern "(sig ?1 ?2)" *) let coq_sig_pattern = lazy (mkPattern (mkGAppRef coq_sig_ref [mkGPatVar "X1"; mkGPatVar "X2"])) let match_sigma t = match Id.Map.bindings (matches (Lazy.force coq_sig_pattern) t) with | [(_,a); (_,p)] -> (a,p) | _ -> anomaly (Pp.str "Unexpected pattern") let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t (*** Decidable equalities *) (* The expected form of the goal for the tactic Decide Equality *) (* Pattern "{x=y}+{~(x=y)}" *) (* i.e. "(sumbool (eq ?1 x y) ~(eq ?1 x y))" *) let coq_eqdec ~sum ~rev = lazy ( let eqn = mkGAppRef coq_eq_ref (List.map mkGPatVar ["X1"; "X2"; "X3"]) in let args = [eqn; mkGAppRef coq_not_ref [eqn]] in let args = if rev then List.rev args else args in mkPattern (mkGAppRef sum args) ) (** { ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 } *) let coq_eqdec_inf_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:false (** { ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 } *) let coq_eqdec_inf_rev_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:true (** %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) *) let coq_eqdec_pattern = coq_eqdec ~sum:coq_or_ref ~rev:false (** %coq_or_ref (~ ?X2 = ?X3 :> ?X1) (?X2 = ?X3 :> ?X1) *) let coq_eqdec_rev_pattern = coq_eqdec ~sum:coq_or_ref ~rev:true let op_or = coq_or_ref let op_sum = coq_sumbool_ref let match_eqdec t = let eqonleft,op,subst = try true,op_sum,matches (Lazy.force coq_eqdec_inf_pattern) t with PatternMatchingFailure -> try false,op_sum,matches (Lazy.force coq_eqdec_inf_rev_pattern) t with PatternMatchingFailure -> try true,op_or,matches (Lazy.force coq_eqdec_pattern) t with PatternMatchingFailure -> false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in match Id.Map.bindings subst with | [(_,typ);(_,c1);(_,c2)] -> eqonleft, Universes.constr_of_global (Lazy.force op), c1, c2, typ | _ -> anomaly (Pp.str "Unexpected pattern") (* Patterns "~ ?" and "? -> False" *) let coq_not_pattern = lazy (mkPattern (mkGAppRef coq_not_ref [mkGHole])) let coq_imp_False_pattern = lazy (mkPattern (mkGArrow mkGHole (mkGRef coq_False_ref))) let is_matching_not t = is_matching (Lazy.force coq_not_pattern) t let is_matching_imp_False t = is_matching (Lazy.force coq_imp_False_pattern) t (* Remark: patterns that have references to the standard library must be evaluated lazily (i.e. at the time they are used, not a the time coqtop starts) *) coq-8.6/tactics/tactics.mli0000644000175000017500000004526213022274260014733 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ([`NF],'b) Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) val introduction : ?check:bool -> Id.t -> unit Proofview.tactic val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic val convert_hyp : ?check:bool -> Context.Named.Declaration.t -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic val convert_hyp_no_check : Context.Named.Declaration.t -> unit Proofview.tactic val mutual_fix : Id.t -> int -> (Id.t * int * constr) list -> int -> unit Proofview.tactic val fix : Id.t option -> int -> unit Proofview.tactic val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> unit Proofview.tactic val cofix : Id.t option -> unit Proofview.tactic val convert : constr -> constr -> unit Proofview.tactic val convert_leq : constr -> constr -> unit Proofview.tactic (** {6 Introduction tactics. } *) val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t val fresh_id : Id.t list -> Id.t -> goal sigma -> Id.t val find_intro_names : Context.Rel.t -> goal sigma -> Id.t list val intro : unit Proofview.tactic val introf : unit Proofview.tactic val intro_move : Id.t option -> Id.t move_location -> unit Proofview.tactic val intro_move_avoid : Id.t option -> Id.t list -> Id.t move_location -> unit Proofview.tactic (** [intro_avoiding idl] acts as intro but prevents the new Id.t to belong to [idl] *) val intro_avoiding : Id.t list -> unit Proofview.tactic val intro_replacing : Id.t -> unit Proofview.tactic val intro_using : Id.t -> unit Proofview.tactic val intro_mustbe_force : Id.t -> unit Proofview.tactic val intro_then : (Id.t -> unit Proofview.tactic) -> unit Proofview.tactic val intros_using : Id.t list -> unit Proofview.tactic val intros_replacing : Id.t list -> unit Proofview.tactic val intros_possibly_replacing : Id.t list -> unit Proofview.tactic val intros : unit Proofview.tactic (** [depth_of_quantified_hypothesis b h g] returns the index of [h] in the conclusion of goal [g], up to head-reduction if [b] is [true] *) val depth_of_quantified_hypothesis : bool -> quantified_hypothesis -> ([`NF],'b) Proofview.Goal.t -> int val intros_until : quantified_hypothesis -> unit Proofview.tactic val intros_clearing : bool list -> unit Proofview.tactic (** Assuming a tactic [tac] depending on an hypothesis Id.t, [try_intros_until tac arg] first assumes that arg denotes a quantified hypothesis (denoted by name or by index) and try to introduce it in context before to apply [tac], otherwise assume the hypothesis is already in context and directly apply [tac] *) val try_intros_until : (Id.t -> unit Proofview.tactic) -> quantified_hypothesis -> unit Proofview.tactic (** Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) val onInductionArg : (clear_flag -> constr with_bindings -> unit Proofview.tactic) -> constr with_bindings destruction_arg -> unit Proofview.tactic val force_destruction_arg : evars_flag -> env -> evar_map -> delayed_open_constr_with_bindings destruction_arg -> evar_map * constr with_bindings destruction_arg (** Tell if a used hypothesis should be cleared by default or not *) val use_clear_hyp_by_default : unit -> bool (** {6 Introduction tactics with eliminations. } *) val intro_patterns : evars_flag -> intro_patterns -> unit Proofview.tactic val intro_patterns_to : evars_flag -> Id.t move_location -> intro_patterns -> unit Proofview.tactic val intro_patterns_bound_to : evars_flag -> int -> Id.t move_location -> intro_patterns -> unit Proofview.tactic val intro_pattern_to : evars_flag -> Id.t move_location -> delayed_open_constr intro_pattern_expr -> unit Proofview.tactic (** Implements user-level "intros", with [] standing for "**" *) val intros_patterns : evars_flag -> intro_patterns -> unit Proofview.tactic (** {6 Exact tactics. } *) val assumption : unit Proofview.tactic val exact_no_check : constr -> unit Proofview.tactic val vm_cast_no_check : constr -> unit Proofview.tactic val native_cast_no_check : constr -> unit Proofview.tactic val exact_check : constr -> unit Proofview.tactic val exact_proof : Constrexpr.constr_expr -> unit Proofview.tactic (** {6 Reduction tactics. } *) type tactic_reduction = env -> evar_map -> constr -> constr type change_arg = patvar_map -> constr Sigma.run val make_change_arg : constr -> change_arg val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic val reduct_in_concl : tactic_reduction * cast_kind -> unit Proofview.tactic val change_in_concl : (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic val change_concl : constr -> unit Proofview.tactic val change_in_hyp : (occurrences * constr_pattern) option -> change_arg -> hyp_location -> unit Proofview.tactic val red_in_concl : unit Proofview.tactic val red_in_hyp : hyp_location -> unit Proofview.tactic val red_option : goal_location -> unit Proofview.tactic val hnf_in_concl : unit Proofview.tactic val hnf_in_hyp : hyp_location -> unit Proofview.tactic val hnf_option : goal_location -> unit Proofview.tactic val simpl_in_concl : unit Proofview.tactic val simpl_in_hyp : hyp_location -> unit Proofview.tactic val simpl_option : goal_location -> unit Proofview.tactic val normalise_in_concl : unit Proofview.tactic val normalise_in_hyp : hyp_location -> unit Proofview.tactic val normalise_option : goal_location -> unit Proofview.tactic val normalise_vm_in_concl : unit Proofview.tactic val unfold_in_concl : (occurrences * evaluable_global_reference) list -> unit Proofview.tactic val unfold_in_hyp : (occurrences * evaluable_global_reference) list -> hyp_location -> unit Proofview.tactic val unfold_option : (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic val change : constr_pattern option -> change_arg -> clause -> unit Proofview.tactic val pattern_option : (occurrences * constr) list -> goal_location -> unit Proofview.tactic val reduce : red_expr -> clause -> unit Proofview.tactic val unfold_constr : global_reference -> unit Proofview.tactic (** {6 Modification of the local context. } *) val clear : Id.t list -> unit Proofview.tactic val clear_body : Id.t list -> unit Proofview.tactic val unfold_body : Id.t -> unit Proofview.tactic val keep : Id.t list -> unit Proofview.tactic val apply_clear_request : clear_flag -> bool -> constr -> unit Proofview.tactic val specialize : constr with_bindings -> intro_pattern option -> unit Proofview.tactic val move_hyp : Id.t -> Id.t move_location -> unit Proofview.tactic val rename_hyp : (Id.t * Id.t) list -> unit Proofview.tactic val revert : Id.t list -> unit Proofview.tactic (** {6 Resolution tactics. } *) val apply_type : constr -> constr list -> unit Proofview.tactic val bring_hyps : Context.Named.t -> unit Proofview.tactic val apply : constr -> unit Proofview.tactic val eapply : constr -> unit Proofview.tactic val apply_with_bindings_gen : advanced_flag -> evars_flag -> (clear_flag * constr with_bindings located) list -> unit Proofview.tactic val apply_with_delayed_bindings_gen : advanced_flag -> evars_flag -> (clear_flag * delayed_open_constr_with_bindings located) list -> unit Proofview.tactic val apply_with_bindings : constr with_bindings -> unit Proofview.tactic 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 -> Id.t -> (clear_flag * constr with_bindings located) list -> intro_pattern option -> unit Proofview.tactic val apply_delayed_in : advanced_flag -> evars_flag -> Id.t -> (clear_flag * delayed_open_constr_with_bindings located) list -> intro_pattern option -> unit Proofview.tactic val run_delayed : Environ.env -> evar_map -> 'a delayed_open -> 'a * evar_map (** {6 Elimination tactics. } *) (* The general form of an induction principle is the following: forall prm1 prm2 ... prmp, (induction parameters) forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates) branch1, branch2, ... , branchr, (branches of the principle) forall (x1:Ti_1) (x2:Ti_2) ... (xni:Ti_ni), (induction arguments) (HI: I prm1..prmp x1...xni) (optional main induction arg) -> (Qi x1...xni HI (f prm1...prmp x1...xni)).(conclusion) ^^ ^^^^^^^^^^^^^^^^^^^^^^^^ optional optional even if HI argument added if principle present above generated by functional induction [indarg] [farg] HI is not present when the induction principle does not come directly from an inductive type (like when it is generated by functional induction for example). HI is present otherwise BUT may not appear in the conclusion (dependent principle). HI and (f...) cannot be both present. Principles taken from functional induction have the final (f...). *) (** [rel_contexts] and [rel_declaration] actually contain triples, and lists are actually in reverse order to fit [compose_prod]. *) type elim_scheme = { elimc: constr with_bindings option; elimt: types; indref: global_reference option; params: Context.Rel.t; (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (** number of parameters *) predicates: Context.Rel.t; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) npredicates: int; (** Number of predicates *) branches: Context.Rel.t; (** branchr,...,branch1 *) nbranches: int; (** Number of branches *) args: Context.Rel.t; (** (xni, Ti_ni) ... (x1, Ti_1) *) nargs: int; (** number of arguments *) indarg: Context.Rel.Declaration.t option; (** Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) concl: types; (** Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) indarg_in_concl: bool; (** true if HI appears at the end of conclusion *) farg_in_concl: bool; (** true if (f...) appears at the end of conclusion *) } val compute_elim_sig : ?elimc: constr with_bindings -> types -> elim_scheme (** elim principle with the index of its inductive arg *) type eliminator = { elimindex : int option; (** None = find it automatically *) elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) elimbody : constr with_bindings } val general_elim : evars_flag -> clear_flag -> constr with_bindings -> eliminator -> unit Proofview.tactic val general_elim_clause : evars_flag -> unify_flags -> identifier option -> clausenv -> eliminator -> unit Proofview.tactic val default_elim : evars_flag -> clear_flag -> constr with_bindings -> unit Proofview.tactic val simplest_elim : constr -> unit Proofview.tactic val elim : evars_flag -> clear_flag -> constr with_bindings -> constr with_bindings option -> unit Proofview.tactic val simple_induct : quantified_hypothesis -> unit Proofview.tactic val induction : evars_flag -> clear_flag -> constr -> or_and_intro_pattern option -> constr with_bindings option -> unit Proofview.tactic (** {6 Case analysis tactics. } *) val general_case_analysis : evars_flag -> clear_flag -> constr with_bindings -> unit Proofview.tactic val simplest_case : constr -> unit Proofview.tactic val simple_destruct : quantified_hypothesis -> unit Proofview.tactic val destruct : evars_flag -> clear_flag -> constr -> or_and_intro_pattern option -> constr with_bindings option -> unit Proofview.tactic (** {6 Generic case analysis / induction tactics. } *) (** Implements user-level "destruct" and "induction" *) val induction_destruct : rec_flag -> evars_flag -> (delayed_open_constr_with_bindings destruction_arg * (intro_pattern_naming option * or_and_intro_pattern option) * clause option) list * constr with_bindings option -> unit Proofview.tactic (** {6 Eliminations giving the type instead of the proof. } *) val case_type : types -> unit Proofview.tactic val elim_type : types -> unit Proofview.tactic (** {6 Constructor tactics. } *) val constructor_tac : evars_flag -> int option -> int -> constr bindings -> unit Proofview.tactic val any_constructor : evars_flag -> unit Proofview.tactic option -> unit Proofview.tactic val one_constructor : int -> constr bindings -> unit Proofview.tactic val left : constr bindings -> unit Proofview.tactic val right : constr bindings -> unit Proofview.tactic val split : constr bindings -> unit Proofview.tactic val left_with_bindings : evars_flag -> constr bindings -> unit Proofview.tactic val right_with_bindings : evars_flag -> constr bindings -> unit Proofview.tactic val split_with_bindings : evars_flag -> constr bindings list -> unit Proofview.tactic val simplest_left : unit Proofview.tactic val simplest_right : unit Proofview.tactic val simplest_split : unit Proofview.tactic (** {6 Equality tactics. } *) val setoid_reflexivity : unit Proofview.tactic Hook.t val reflexivity_red : bool -> unit Proofview.tactic val reflexivity : unit Proofview.tactic val intros_reflexivity : unit Proofview.tactic val setoid_symmetry : unit Proofview.tactic Hook.t val symmetry_red : bool -> unit Proofview.tactic val symmetry : unit Proofview.tactic val setoid_symmetry_in : (Id.t -> unit Proofview.tactic) Hook.t val intros_symmetry : clause -> unit Proofview.tactic val setoid_transitivity : (constr option -> unit Proofview.tactic) Hook.t val transitivity_red : bool -> constr option -> unit Proofview.tactic val transitivity : constr -> unit Proofview.tactic val etransitivity : unit Proofview.tactic val intros_transitivity : constr option -> unit Proofview.tactic (** {6 Cut tactics. } *) val assert_before_replacing: Id.t -> types -> unit Proofview.tactic val assert_after_replacing : Id.t -> types -> unit Proofview.tactic val assert_before : Name.t -> types -> unit Proofview.tactic val assert_after : Name.t -> types -> unit Proofview.tactic val assert_as : (* true = before *) bool -> (* optionally tell if a specialization of some hyp: *) identifier option -> intro_pattern option -> constr -> unit Proofview.tactic (** Implements the tactics assert, enough and pose proof; note that "by" applies on the first goal for both assert and enough *) val assert_by : Name.t -> types -> unit Proofview.tactic -> unit Proofview.tactic val enough_by : Name.t -> types -> unit Proofview.tactic -> unit Proofview.tactic val pose_proof : Name.t -> constr -> unit Proofview.tactic (** Common entry point for user-level "assert", "enough" and "pose proof" *) val forward : bool -> unit Proofview.tactic option option -> intro_pattern option -> constr -> unit Proofview.tactic (** Implements the tactic cut, actually a modus ponens rule *) val cut : types -> unit Proofview.tactic (** {6 Tactics for adding local definitions. } *) val letin_tac : (bool * intro_pattern_naming) option -> Name.t -> constr -> types option -> clause -> unit Proofview.tactic (** Common entry point for user-level "set", "pose" and "remember" *) val letin_pat_tac : (bool * intro_pattern_naming) option -> Name.t -> pending_constr -> clause -> unit Proofview.tactic (** {6 Generalize tactics. } *) val generalize : constr list -> unit Proofview.tactic val generalize_gen : (constr Locus.with_occurrences * Name.t) list -> unit Proofview.tactic val new_generalize_gen : ((occurrences * constr) * Name.t) list -> unit Proofview.tactic val generalize_dep : ?with_let:bool (** Don't lose let bindings *) -> constr -> unit Proofview.tactic (** {6 Other tactics. } *) val unify : ?state:Names.transparent_state -> constr -> constr -> unit Proofview.tactic val tclABSTRACT : Id.t option -> unit Proofview.tactic -> unit Proofview.tactic val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Id.t -> unit Proofview.tactic val specialize_eqs : Id.t -> unit Proofview.tactic val general_rewrite_clause : (bool -> evars_flag -> constr with_bindings -> clause -> unit Proofview.tactic) Hook.t val subst_one : (bool -> Id.t -> Id.t * constr * bool -> unit Proofview.tactic) Hook.t val declare_intro_decomp_eq : ((int -> unit Proofview.tactic) -> Coqlib.coq_eq_data * types * (types * constr * constr) -> constr * types -> unit Proofview.tactic) -> unit (** {6 Simple form of basic tactics. } *) module Simple : sig (** Simplified version of some of the above tactics *) val intro : Id.t -> unit Proofview.tactic val apply : constr -> unit Proofview.tactic val eapply : constr -> unit Proofview.tactic val elim : constr -> unit Proofview.tactic val case : constr -> unit Proofview.tactic val apply_in : identifier -> constr -> unit Proofview.tactic end (** {6 Tacticals defined directly in term of Proofview} *) module New : sig val refine : ?unsafe:bool -> constr Sigma.run -> unit Proofview.tactic (** [refine ?unsafe c] is [Refine.refine ?unsafe c] followed by beta-iota-reduction of the conclusion. *) val reduce_after_refine : unit Proofview.tactic (** The reducing tactic called after {!refine}. *) end coq-8.6/tactics/auto.mli0000644000175000017500000000632113022274260014242 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Id.Pred.t val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> ('a, 'r) Proofview.Goal.t -> clausenv * constr (** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic (** [ConclPattern concl pat tacast]: if the term concl matches the pattern pat, (in sense of [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the right values to build a tactic *) val conclPattern : constr -> constr_pattern option -> Genarg.glob_generic_argument -> unit Proofview.tactic (** The Auto tactic *) (** The use of the "core" database can be de-activated by passing "nocore" amongst the databases. *) val auto : ?debug:Tacexpr.debug -> int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** Auto with more delta. *) val new_auto : ?debug:Tacexpr.debug -> int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** auto with default search depth and with the hint database "core" *) val default_auto : unit Proofview.tactic (** auto with all hint databases *) val full_auto : ?debug:Tacexpr.debug -> int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic (** auto with all hint databases and doing delta *) val new_full_auto : ?debug:Tacexpr.debug -> int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic (** auto with default search depth and with all hint databases *) val default_full_auto : unit Proofview.tactic (** The generic form of auto (second arg [None] means all bases) *) val gen_auto : ?debug:Tacexpr.debug -> int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** The hidden version of auto *) val h_auto : ?debug:Tacexpr.debug -> int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** Trivial *) val trivial : ?debug:Tacexpr.debug -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic val gen_trivial : ?debug:Tacexpr.debug -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic val full_trivial : ?debug:Tacexpr.debug -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic val h_trivial : ?debug:Tacexpr.debug -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic coq-8.6/tactics/tactics.mllib0000644000175000017500000000030213022274260015233 0ustar garesgaresDnet Dn Btermdn Tacticals Hipattern Ind_tables Eqschemes Elimschemes Tactics Elim Equality Contradiction Inv Leminv Hints Auto Eauto Class_tactics Tactic_matching Term_dnet Eqdecide Autorewrite coq-8.6/tactics/auto.ml0000644000175000017500000004661313022274260014101 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Int.equal hint.pri 0) l let compute_secvars gl = let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in secvars_of_hyps hyps (* tell auto not to reuse already instantiated metas in unification (for compatibility, since otherwise, apply succeeds oftener) *) open Unification let auto_core_unif_flags_of st1 st2 useeager = { modulo_conv_on_closed_terms = Some st1; use_metas_eagerly_in_conv_on_closed_terms = useeager; use_evars_eagerly_in_conv_on_closed_terms = false; modulo_delta = st2; modulo_delta_types = full_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; frozen_evars = Evar.Set.empty; restrict_conv_on_strict_subterms = false; (* Compat *) modulo_betaiota = false; modulo_eta = true; } let auto_unif_flags_of st1 st2 useeager = let flags = auto_core_unif_flags_of st1 st2 useeager in { core_unify_flags = flags; merge_unify_flags = flags; subterm_unify_flags = { flags with modulo_delta = empty_transparent_state }; allow_K_in_toplevel_higher_order_unification = false; resolve_evars = true } let auto_unif_flags = auto_unif_flags_of full_transparent_state empty_transparent_state false (* Try unification with the precompiled clause, then use registered Apply *) let connect_hint_clenv poly (c, _, ctx) clenv gl = (** [clenv] has been generated by a hint-making function, so the only relevant data in its evarmap is the set of metas. The [evar_reset_evd] function below just replaces the metas of sigma by those coming from the clenv. *) let sigma = Tacmach.New.project gl in let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in (** Still, we need to update the universes *) let clenv, c = if poly then (** Refresh the instance of the hint *) let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in let map c = Vars.subst_univs_level_constr subst c in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in (** Only metas are mentioning the old universes. *) let clenv = { templval = Evd.map_fl map clenv.templval; templtyp = Evd.map_fl map clenv.templtyp; evd = Evd.map_metas map evd; env = Proofview.Goal.env gl; } in clenv, map c else let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in { clenv with evd = evd ; env = Proofview.Goal.env gl }, c in clenv, c let unify_resolve poly flags ((c : raw_hint), clenv) = Proofview.Goal.nf_enter { enter = begin fun gl -> let clenv, c = connect_hint_clenv poly c clenv gl in let clenv = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv gl) gl in Clenvtac.clenv_refine false clenv end } let unify_resolve_nodelta poly h = unify_resolve poly auto_unif_flags h let unify_resolve_gen poly = function | None -> unify_resolve_nodelta poly | Some flags -> unify_resolve poly flags let exact poly (c,clenv) = Proofview.Goal.enter { enter = begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (exact_check c) end } (* Util *) (* Serait-ce possible de compiler d'abord la tactique puis de faire la substitution sans passer par bdize dont l'objectif est de préparer un terme pour l'affichage ? (HH) *) (* Si on enlève le dernier argument (gl) conclPattern est calculé une fois pour toutes : en particulier si Pattern.somatch produit une UserError Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même si après Intros la conclusion matche le pattern. *) (* conclPattern doit échouer avec error car il est rattraper par tclFIRST *) let conclPattern concl pat tac = let constr_bindings env sigma = match pat with | None -> Proofview.tclUNIT Id.Map.empty | Some pat -> try Proofview.tclUNIT (Constr_matching.matches env sigma pat concl) with Constr_matching.PatternMatchingFailure -> Tacticals.New.tclZEROMSG (str "conclPattern") in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in constr_bindings env sigma >>= fun constr_bindings -> let open Genarg in let open Geninterp in let inj c = match val_tag (topwit Constrarg.wit_constr) with | Val.Base tag -> Val.Dyn (tag, c) | _ -> assert false in let fold id c accu = Id.Map.add id (inj c) accu in let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in let ist = { lfun; extra = TacStore.empty } in match tac with | GenArg (Glbwit wit, tac) -> Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) end } (***********************************************************) (** A debugging / verbosity framework for trivial and auto *) (***********************************************************) (** The following options allow to trigger debugging/verbosity without having to adapt the scripts. Note: if Debug and Info are both activated, Debug take precedence. *) let global_debug_trivial = ref false let global_debug_auto = ref false let global_info_trivial = ref false let global_info_auto = ref false let add_option ls refe = let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = String.concat " " ls; Goptions.optkey = ls; Goptions.optread = (fun () -> !refe); Goptions.optwrite = (:=) refe } in () let _ = add_option ["Debug";"Trivial"] global_debug_trivial; add_option ["Debug";"Auto"] global_debug_auto; add_option ["Info";"Trivial"] global_info_trivial; add_option ["Info";"Auto"] global_info_auto let no_dbg () = (Off,0,ref []) let mk_trivial_dbg debug = let d = if debug == Debug || !global_debug_trivial then Debug else if debug == Info || !global_info_trivial then Info else Off in (d,0,ref []) (** Note : we start the debug depth of auto at 1 to distinguish it for trivial (whose depth is 0). *) let mk_auto_dbg debug = let d = if debug == Debug || !global_debug_auto then Debug else if debug == Info || !global_info_auto then Info else Off in (d,1,ref []) let incr_dbg = function (dbg,depth,trace) -> (dbg,depth+1,trace) (** A tracing tactic for debug/info trivial/auto *) let tclLOG (dbg,depth,trace) pp tac = match dbg with | Off -> tac | Debug -> (* For "debug (trivial/auto)", we directly output messages *) let s = String.make depth '*' in Proofview.V82.tactic begin fun gl -> try let out = Proofview.V82.of_tactic tac gl in Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); out with reraise -> let reraise = CErrors.push reraise in Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); iraise reraise end | Info -> (* For "info (trivial/auto)", we store a log trace *) Proofview.V82.tactic begin fun gl -> try let out = Proofview.V82.of_tactic tac gl in trace := (depth, Some pp) :: !trace; out with reraise -> let reraise = CErrors.push reraise in trace := (depth, None) :: !trace; iraise reraise end (** For info, from the linear trace information, we reconstitute the part of the proof tree we're interested in. The last executed tactic comes first in the trace (and it should be a successful one). [depth] is the root depth of the tree fragment we're visiting. [keep] means we're in a successful tree fragment (the very last tactic has been successful). *) let rec cleanup_info_trace depth acc = function | [] -> acc | (d,Some pp) :: l -> cleanup_info_trace d ((d,pp)::acc) l | l -> cleanup_info_trace depth acc (erase_subtree depth l) and erase_subtree depth = function | [] -> [] | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l let pr_info_atom (d,pp) = str (String.make d ' ') ++ pp () ++ str "." let pr_info_trace = function | (Info,_,{contents=(d,Some pp)::l}) -> Feedback.msg_info (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)) | _ -> () let pr_info_nop = function | (Info,_,_) -> Feedback.msg_info (str "idtac.") | _ -> () let pr_dbg_header = function | (Off,_,_) -> () | (Debug,0,_) -> Feedback.msg_debug (str "(* debug trivial: *)") | (Debug,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") | (Info,0,_) -> Feedback.msg_info (str "(* info trivial: *)") | (Info,_,_) -> Feedback.msg_info (str "(* info auto: *)") let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in let tac = delay (fun () -> pr_dbg_header d; tac) >>= fun () -> pr_info_trace d; Proofview.tclUNIT () in let after = delay (fun () -> pr_info_nop d; Proofview.tclUNIT ()) in Tacticals.New.tclORELSE0 tac after (**************************************************************************) (* The Trivial tactic *) (**************************************************************************) (* local_db is a Hint database containing the hypotheses of current goal *) (* Papageno : cette fonction a été pas mal simplifiée depuis que la base de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) let flags_of_state st = auto_unif_flags_of st st false let auto_flags_of_state st = auto_unif_flags_of full_transparent_state st false let hintmap_of secvars hdc concl = match hdc with | None -> Hint_db.map_none ~secvars | Some hdc -> if occur_existential concl then Hint_db.map_existential ~secvars hdc concl else Hint_db.map_auto ~secvars hdc concl let exists_evaluable_reference env = function | EvalConstRef _ -> true | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false let dbg_intro dbg = tclLOG dbg (fun () -> str "intro") intro let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption let rec trivial_fail_db dbg mod_delta db_list local_db = let intro_tac = Tacticals.New.tclTHEN (dbg_intro dbg) ( Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let nf c = Evarutil.nf_evar sigma c in let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in let hyp = Context.Named.Declaration.map_constr nf decl in let hintl = make_resolve_hyp env sigma hyp in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list env sigma hintl local_db) end }) in Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in let secvars = compute_secvars gl in Tacticals.New.tclFIRST ((dbg_assumption dbg)::intro_tac:: (List.map Tacticals.New.tclCOMPLETE (trivial_resolve dbg mod_delta db_list local_db secvars concl))) end } and my_find_search_nodelta db_list local_db secvars hdc concl = List.map (fun hint -> (None,hint)) (List.map_append (hintmap_of secvars hdc concl) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_delta else my_find_search_nodelta and my_find_search_delta db_list local_db secvars hdc concl = let f = hintmap_of secvars hdc concl in if occur_existential concl then List.map_append (fun db -> if Hint_db.use_dn db then let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags,x)) (f db) else let flags = auto_flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags,x)) (f db)) (local_db::db_list) else List.map_append (fun db -> if Hint_db.use_dn db then let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags, x)) (f db) else let (ids, csts as st) = Hint_db.transparent_state db in let flags, l = let l = match hdc with None -> Hint_db.map_none ~secvars db | Some hdc -> if (Id.Pred.is_empty ids && Cpred.is_empty csts) then Hint_db.map_auto ~secvars hdc concl db else Hint_db.map_existential ~secvars hdc concl db in auto_flags_of_state st, l in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=dbname})) = let tactic = function | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl) | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf") | Give_exact (c, cl) -> exact poly (c, cl) | Res_pf_THEN_trivial_fail (c,cl) -> Tacticals.New.tclTHEN (unify_resolve_gen poly flags (c,cl)) (* With "(debug) trivial", we shouldn't end here, and with "debug auto" we don't display the details of inner trivial *) (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db) | Unfold_nth c -> Proofview.V82.tactic (fun gl -> if exists_evaluable_reference (pf_env gl) c then tclPROGRESS (Proofview.V82.of_tactic (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl)) gl else tclFAIL 0 (str"Unbound reference") gl) | Extern tacast -> conclPattern concl p tacast in let pr_hint () = let origin = match dbname with | None -> mt () | Some n -> str " (in " ++ str n ++ str ")" in pr_hint t ++ origin in tclLOG dbg pr_hint (run_hint t tactic) and trivial_resolve dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound cl in Some hdconstr with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) (priority (my_find_search mod_delta db_list local_db secvars head cl)) with Not_found -> [] (** The use of the "core" database can be de-activated by passing "nocore" amongst the databases. *) let trivial ?(debug=Off) lems dbnames = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in let d = mk_trivial_dbg debug in let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (trivial_fail_db d false db_list hints) end } let full_trivial ?(debug=Off) lems = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in let d = mk_trivial_dbg debug in let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (trivial_fail_db d false db_list hints) end } let gen_trivial ?(debug=Off) lems = function | None -> full_trivial ~debug lems | Some l -> trivial ~debug lems l let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l (**************************************************************************) (* The classical Auto tactic *) (**************************************************************************) let possible_resolve dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound cl in Some hdconstr with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) (my_find_search mod_delta db_list local_db secvars head cl) with Not_found -> [] let extend_local_db decl db gl = let env = Tacmach.New.pf_env gl in let sigma = Tacmach.New.project gl in Hint_db.add_list env sigma (make_resolve_hyp env sigma decl) db (* Introduce an hypothesis, then call the continuation tactic [kont] with the hint db extended with the so-obtained hypothesis *) let intro_register dbg kont db = Tacticals.New.tclTHEN (dbg_intro dbg) (Proofview.Goal.enter { enter = begin fun gl -> let extend_local_db decl db = extend_local_db decl db gl in Tacticals.New.onLastDecl (fun decl -> kont (extend_local_db decl db)) end }) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) let search d n mod_delta db_list local_db = let rec search d n local_db = (* spiwack: the test of [n] to 0 must be done independently in each goal. Hence the [tclEXTEND] *) Proofview.tclEXTEND [] begin if Int.equal n 0 then Tacticals.New.tclZEROMSG (str"BOUND 2") else Tacticals.New.tclORELSE0 (dbg_assumption d) (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) ( Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in let secvars = compute_secvars gl in let d' = incr_dbg d in Tacticals.New.tclFIRST (List.map (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) (possible_resolve d mod_delta db_list local_db secvars concl)) end })) end [] in search d n local_db let default_search_depth = ref 5 let delta_auto debug mod_delta n lems dbnames = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in let d = mk_auto_dbg debug in let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (search d n mod_delta db_list hints) end } let delta_auto = if Flags.profile then let key = Profile.declare_profile "delta_auto" in Profile.profile5 key delta_auto else delta_auto let auto ?(debug=Off) n = delta_auto debug false n let new_auto ?(debug=Off) n = delta_auto debug true n let default_auto = auto !default_search_depth [] [] let delta_full_auto ?(debug=Off) mod_delta n lems = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in let d = mk_auto_dbg debug in let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (search d n mod_delta db_list hints) end } let full_auto ?(debug=Off) n = delta_full_auto ~debug false n let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n let default_full_auto = full_auto !default_search_depth [] let gen_auto ?(debug=Off) n lems dbnames = let n = match n with None -> !default_search_depth | Some n -> n in match dbnames with | None -> full_auto ~debug n lems | Some l -> auto ~debug n lems l let h_auto ?(debug=Off) n lems l = gen_auto ~debug n lems l coq-8.6/tactics/autorewrite.mli0000644000175000017500000000427413022274260015651 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* raw_rew_rule list -> unit (** The AutoRewrite tactic. The optional conditions tell rewrite how to handle matching and side-condition solving. Default is Naive: first match in the clause, don't look at the side-conditions to tell if the rewrite succeeded. *) val autorewrite : ?conds:conditions -> unit Proofview.tactic -> string list -> unit Proofview.tactic val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> string list -> unit Proofview.tactic (** Rewriting rules *) type rew_rule = { rew_lemma: constr; rew_type: types; rew_pat: constr; rew_ctx: Univ.universe_context_set; rew_l2r: bool; rew_tac: Genarg.glob_generic_argument option } val find_rewrites : string -> rew_rule list val find_matches : string -> constr -> rew_rule list val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> unit Proofview.tactic val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic val print_rewrite_hintdb : string -> Pp.std_ppcmds open Clenv type hypinfo = { hyp_cl : clausenv; hyp_prf : constr; hyp_ty : types; hyp_car : constr; hyp_rel : constr; hyp_l2r : bool; hyp_left : constr; hyp_right : constr; } val find_applied_relation : bool -> Loc.t -> Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo coq-8.6/tactics/hints.ml0000644000175000017500000015067213022274260014257 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* hd | Proj (p, _) -> mkConst (Projection.constant p) | _ -> raise Bound let head_constr c = try head_constr_bound c with Bound -> error "Bound head variable." let decompose_app_bound t = let t = strip_outer_cast t in let _,ccl = decompose_prod_assum t in let hd,args = decompose_app_vect ccl in match kind_of_term hd with | Const (c,u) -> ConstRef c, args | Ind (i,u) -> IndRef i, args | Construct (c,u) -> ConstructRef c, args | Var id -> VarRef id, args | Proj (p, c) -> ConstRef (Projection.constant p), Array.cons c args | _ -> raise Bound (** Compute the set of section variables that remain in the named context. Starts from the top to the bottom of the context, stops at the first different declaration between the named hyps and the section context. *) let secvars_of_hyps hyps = let secctx = Global.named_context () in let pred, all = List.fold_left (fun (pred,all) decl -> try let _ = Context.Named.lookup (get_id decl) hyps in (* Approximation, it might be an hypothesis reintroduced with same name and unconvertible types, we must allow it currently, as comparing the declarations for syntactic equality is too strong a check (e.g. an unfold in a section variable would make it unusable). *) (Id.Pred.add (get_id decl) pred, all) with Not_found -> (pred, false)) (Id.Pred.empty,true) secctx in if all then Id.Pred.full (* If the whole section context is available *) else pred let empty_hint_info = let open Vernacexpr in { hint_priority = None; hint_pattern = None } (************************************************************************) (* The Type of Constructions Autotactic Hints *) (************************************************************************) type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of Genarg.glob_generic_argument (* Hint Extern *) type 'a hints_path_atom_gen = | PathHints of 'a list (* For forward hints, their names is the list of projections *) | PathAny type hints_path_atom = global_reference hints_path_atom_gen type 'a hints_path_gen = | PathAtom of 'a hints_path_atom_gen | PathStar of 'a hints_path_gen | PathSeq of 'a hints_path_gen * 'a hints_path_gen | PathOr of 'a hints_path_gen * 'a hints_path_gen | PathEmpty | PathEpsilon type pre_hints_path = Libnames.reference hints_path_gen type hints_path = global_reference hints_path_gen type hint_term = | IsGlobRef of global_reference | IsConstr of constr * Univ.universe_context_set type 'a with_uid = { obj : 'a; uid : KerName.t; } type raw_hint = constr * types * Univ.universe_context_set type hint = (raw_hint * clausenv) hint_ast with_uid type 'a with_metadata = { pri : int; (* A number lower is higher priority *) poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) name : hints_path_atom; (* A potential name to refer to the hint *) db : string option; (** The database from which the hint comes *) secvars : Id.Pred.t; (* The set of section variables the hint depends on *) code : 'a; (* the tactic to apply when the concl matches pat *) } type full_hint = hint with_metadata type hint_entry = global_reference option * raw_hint hint_ast with_uid with_metadata type import_level = [ `LAX | `WARN | `STRICT ] let warn_hint : import_level ref = ref `LAX let read_warn_hint () = match !warn_hint with | `LAX -> "Lax" | `WARN -> "Warn" | `STRICT -> "Strict" let write_warn_hint = function | "Lax" -> warn_hint := `LAX | "Warn" -> warn_hint := `WARN | "Strict" -> warn_hint := `STRICT | _ -> error "Only the following flags are accepted: Lax, Warn, Strict." let _ = Goptions.declare_string_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = "behavior of non-imported hints"; Goptions.optkey = ["Loose"; "Hint"; "Behavior"]; Goptions.optread = read_warn_hint; Goptions.optwrite = write_warn_hint; } let fresh_key = let id = Summary.ref ~name:"HINT-COUNTER" 0 in fun () -> let cur = incr id; !id in let lbl = Id.of_string ("_" ^ string_of_int cur) in let kn = Lib.make_kn lbl in let (mp, dir, _) = KerName.repr kn in (** We embed the full path of the kernel name in the label so that the identifier should be unique. This ensures that including two modules together won't confuse the corresponding labels. *) let lbl = Id.of_string_soft (Printf.sprintf "%s#%s#%i" (ModPath.to_string mp) (DirPath.to_string dir) cur) in KerName.make mp dir (Label.of_id lbl) let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) = let d = pri1 - pri2 in if Int.equal d 0 then id2 - id1 else d let pri_order t1 t2 = pri_order_int t1 t2 <= 0 (* Nov 98 -- Papageno *) (* Les Hints sont ré-organisés en plusieurs databases. La table impérative "searchtable", de type "hint_db_table", associe une database (hint_db) à chaque nom. Une hint_db est une table d'association fonctionelle constr -> search_entry Le constr correspond à la constante de tête de la conclusion. Une search_entry est un triplet comprenant : - la liste des tactiques qui n'ont pas de pattern associé - la liste des tactiques qui ont un pattern - un discrimination net borné (Btermdn.t) constitué de tous les patterns de la seconde liste de tactiques *) type stored_data = int * full_hint (* First component is the index of insertion in the table, to keep most recent first semantics. *) module Bounded_net = Btermdn.Make(struct type t = stored_data let compare = pri_order_int end) type search_entry = { sentry_nopat : stored_data list; sentry_pat : stored_data list; sentry_bnet : Bounded_net.t; sentry_mode : hint_mode array list; } let empty_se = { sentry_nopat = []; sentry_pat = []; sentry_bnet = Bounded_net.empty; sentry_mode = []; } let eq_pri_auto_tactic (_, x) (_, y) = KerName.equal x.code.uid y.code.uid let add_tac pat t st se = match pat with | None -> if List.exists (eq_pri_auto_tactic t) se.sentry_nopat then se else { se with sentry_nopat = List.insert pri_order t se.sentry_nopat } | Some pat -> if List.exists (eq_pri_auto_tactic t) se.sentry_pat then se else { se with sentry_pat = List.insert pri_order t se.sentry_pat; sentry_bnet = Bounded_net.add st se.sentry_bnet (pat, t); } let rebuild_dn st se = let dn' = List.fold_left (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t))) Bounded_net.empty se.sentry_pat in { se with sentry_bnet = dn' } let lookup_tacs concl st se = let l' = Bounded_net.lookup st se.sentry_bnet concl in let sl' = List.stable_sort pri_order_int l' in List.merge pri_order_int se.sentry_nopat sl' module Constr_map = Map.Make(RefOrdered) let is_transparent_gr (ids, csts) = function | VarRef id -> Id.Pred.mem id ids | ConstRef cst -> Cpred.mem cst csts | IndRef _ | ConstructRef _ -> false let strip_params env c = match kind_of_term c with | App (f, args) -> (match kind_of_term f with | Const (p,_) -> let cb = lookup_constant p env in (match cb.Declarations.const_proj with | Some pb -> let n = pb.Declarations.proj_npars in if Array.length args > n then mkApp (mkProj (Projection.make p false, args.(n)), Array.sub args (n+1) (Array.length args - (n + 1))) else c | None -> c) | _ -> c) | _ -> c let instantiate_hint env sigma p = let mk_clenv (c, cty, ctx) = let sigma = Evd.merge_context_set univ_flexible sigma ctx in let cl = mk_clenv_from_env env sigma None (c,cty) in {cl with templval = { cl.templval with rebus = strip_params env cl.templval.rebus }; env = empty_env} in let code = match p.code.obj with | Res_pf c -> Res_pf (c, mk_clenv c) | ERes_pf c -> ERes_pf (c, mk_clenv c) | Res_pf_THEN_trivial_fail c -> Res_pf_THEN_trivial_fail (c, mk_clenv c) | Give_exact c -> Give_exact (c, mk_clenv c) | Unfold_nth e -> Unfold_nth e | Extern t -> Extern t in { p with code = { p.code with obj = code } } let hints_path_atom_eq h1 h2 = match h1, h2 with | PathHints l1, PathHints l2 -> List.equal eq_gr l1 l2 | PathAny, PathAny -> true | _ -> false let rec hints_path_eq h1 h2 = match h1, h2 with | PathAtom h1, PathAtom h2 -> hints_path_atom_eq h1 h2 | PathStar h1, PathStar h2 -> hints_path_eq h1 h2 | PathSeq (l1, r1), PathSeq (l2, r2) -> hints_path_eq l1 l2 && hints_path_eq r1 r2 | PathOr (l1, r1), PathOr (l2, r2) -> hints_path_eq l1 l2 && hints_path_eq r1 r2 | PathEmpty, PathEmpty -> true | PathEpsilon, PathEpsilon -> true | _ -> false let path_matches hp hints = let rec aux hp hints k = match hp, hints with | PathAtom _, [] -> false | PathAtom PathAny, (_ :: hints') -> k hints' | PathAtom p, (h :: hints') -> if hints_path_atom_eq p h then k hints' else false | PathStar hp', hints -> k hints || aux hp' hints (fun hints' -> aux hp hints' k) | PathSeq (hp, hp'), hints -> aux hp hints (fun hints' -> aux hp' hints' k) | PathOr (hp, hp'), hints -> aux hp hints k || aux hp' hints k | PathEmpty, _ -> false | PathEpsilon, hints -> k hints in aux hp hints (fun hints' -> true) let rec matches_epsilon = function | PathAtom _ -> false | PathStar _ -> true | PathSeq (p, p') -> matches_epsilon p && matches_epsilon p' | PathOr (p, p') -> matches_epsilon p || matches_epsilon p' | PathEmpty -> false | PathEpsilon -> true let rec is_empty = function | PathAtom _ -> false | PathStar _ -> false | PathSeq (p, p') -> is_empty p || is_empty p' | PathOr (p, p') -> matches_epsilon p && matches_epsilon p' | PathEmpty -> true | PathEpsilon -> false let path_seq p p' = match p, p' with | PathEpsilon, p' -> p' | p, PathEpsilon -> p | p, p' -> PathSeq (p, p') let rec path_derivate hp hint = let rec derivate_atoms hints hints' = match hints, hints' with | gr :: grs, gr' :: grs' when eq_gr gr gr' -> derivate_atoms grs grs' | [], [] -> PathEpsilon | [], hints -> PathEmpty | grs, [] -> PathAtom (PathHints grs) | _, _ -> PathEmpty in match hp with | PathAtom PathAny -> PathEpsilon | PathAtom (PathHints grs) -> (match grs, hint with | h :: _, PathAny -> PathEmpty | hints, PathHints hints' -> derivate_atoms hints hints' | _, _ -> assert false) | PathStar p -> if path_matches p [hint] then hp else PathEpsilon | PathSeq (hp, hp') -> let hpder = path_derivate hp hint in if matches_epsilon hp then PathOr (path_seq hpder hp', path_derivate hp' hint) else if is_empty hpder then PathEmpty else path_seq hpder hp' | PathOr (hp, hp') -> PathOr (path_derivate hp hint, path_derivate hp' hint) | PathEmpty -> PathEmpty | PathEpsilon -> PathEmpty let rec normalize_path h = match h with | PathStar PathEpsilon -> PathEpsilon | PathSeq (PathEmpty, _) | PathSeq (_, PathEmpty) -> PathEmpty | PathSeq (PathEpsilon, p) | PathSeq (p, PathEpsilon) -> normalize_path p | PathOr (PathEmpty, p) | PathOr (p, PathEmpty) -> normalize_path p | PathOr (p, q) -> let p', q' = normalize_path p, normalize_path q in if hints_path_eq p p' && hints_path_eq q q' then h else normalize_path (PathOr (p', q')) | PathSeq (p, q) -> let p', q' = normalize_path p, normalize_path q in if hints_path_eq p p' && hints_path_eq q q' then h else normalize_path (PathSeq (p', q')) | _ -> h let path_derivate hp hint = normalize_path (path_derivate hp hint) let pp_hints_path_atom prg a = match a with | PathAny -> str"_" | PathHints grs -> pr_sequence prg grs let pp_hints_path_gen prg = let rec aux = function | PathAtom pa -> pp_hints_path_atom prg pa | PathStar (PathAtom PathAny) -> str"_*" | PathStar p -> str "(" ++ aux p ++ str")*" | PathSeq (p, p') -> aux p ++ spc () ++ aux p' | PathOr (p, p') -> str "(" ++ aux p ++ spc () ++ str"|" ++ cut () ++ spc () ++ aux p' ++ str ")" | PathEmpty -> str"emp" | PathEpsilon -> str"eps" in aux let pp_hints_path = pp_hints_path_gen pr_global let glob_hints_path_atom p = match p with | PathHints g -> PathHints (List.map Nametab.global g) | PathAny -> PathAny let glob_hints_path = let rec aux = function | PathAtom pa -> PathAtom (glob_hints_path_atom pa) | PathStar p -> PathStar (aux p) | PathSeq (p, p') -> PathSeq (aux p, aux p') | PathOr (p, p') -> PathOr (aux p, aux p') | PathEmpty -> PathEmpty | PathEpsilon -> PathEpsilon in aux let subst_path_atom subst p = match p with | PathAny -> p | PathHints grs -> let gr' gr = fst (subst_global subst gr) in let grs' = List.smartmap gr' grs in if grs' == grs then p else PathHints grs' let rec subst_hints_path subst hp = match hp with | PathAtom p -> let p' = subst_path_atom subst p in if p' == p then hp else PathAtom p' | PathStar p -> let p' = subst_hints_path subst p in if p' == p then hp else PathStar p' | PathSeq (p, q) -> let p' = subst_hints_path subst p in let q' = subst_hints_path subst q in if p' == p && q' == q then hp else PathSeq (p', q') | PathOr (p, q) -> let p' = subst_hints_path subst p in let q' = subst_hints_path subst q in if p' == p && q' == q then hp else PathOr (p', q') | _ -> hp type hint_db_name = string module Hint_db : sig type t val empty : ?name:hint_db_name -> transparent_state -> bool -> t val find : global_reference -> t -> search_entry val map_none : secvars:Id.Pred.t -> t -> full_hint list val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list val map_existential : secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list val map_eauto : secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list val map_auto : secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list val add_one : env -> evar_map -> hint_entry -> t -> t val add_list : env -> evar_map -> hint_entry list -> t -> t val remove_one : global_reference -> t -> t val remove_list : global_reference list -> t -> t val iter : (global_reference option -> hint_mode array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool val transparent_state : t -> transparent_state val set_transparent_state : t -> transparent_state -> t val add_cut : hints_path -> t -> t val add_mode : global_reference -> hint_mode array -> t -> t val cut : t -> hints_path val unfolds : t -> Id.Set.t * Cset.t val fold : (global_reference option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> t -> 'a -> 'a end = struct type t = { hintdb_state : Names.transparent_state; hintdb_cut : hints_path; hintdb_unfolds : Id.Set.t * Cset.t; hintdb_max_id : int; use_dn : bool; hintdb_map : search_entry Constr_map.t; (* A list of unindexed entries starting with an unfoldable constant or with no associated pattern. *) hintdb_nopat : (global_reference option * stored_data) list; hintdb_name : string option; } let next_hint_id db = let h = db.hintdb_max_id in { db with hintdb_max_id = succ db.hintdb_max_id }, h let empty ?name st use_dn = { hintdb_state = st; hintdb_cut = PathEmpty; hintdb_unfolds = (Id.Set.empty, Cset.empty); hintdb_max_id = 0; use_dn = use_dn; hintdb_map = Constr_map.empty; hintdb_nopat = []; hintdb_name = name; } let find key db = try Constr_map.find key db.hintdb_map with Not_found -> empty_se let realize_tac secvars (id,tac) = if Id.Pred.subset tac.secvars secvars then Some tac else (** Warn about no longer typable hint? *) None let match_mode m arg = match m with | ModeInput -> not (occur_existential arg) | ModeNoHeadEvar -> Evarutil.(try ignore(head_evar arg); false with NoHeadEvar -> true) | ModeOutput -> true let matches_mode args mode = Array.length mode == Array.length args && Array.for_all2 match_mode mode args let matches_modes args modes = if List.is_empty modes then true else List.exists (matches_mode args) modes let merge_entry secvars db nopat pat = let h = List.sort pri_order_int (List.map snd db.hintdb_nopat) in let h = List.merge pri_order_int h nopat in let h = List.merge pri_order_int h pat in List.map_filter (realize_tac secvars) h let map_none ~secvars db = merge_entry secvars db [] [] let map_all ~secvars k db = let se = find k db in merge_entry secvars db se.sentry_nopat se.sentry_pat (** Precondition: concl has no existentials *) let map_auto ~secvars (k,args) concl db = let se = find k db in let st = if db.use_dn then (Some db.hintdb_state) else None in let pat = lookup_tacs concl st se in merge_entry secvars db [] pat let map_existential ~secvars (k,args) concl db = let se = find k db in if matches_modes args se.sentry_mode then merge_entry secvars db se.sentry_nopat se.sentry_pat else merge_entry secvars db [] [] (* [c] contains an existential *) let map_eauto ~secvars (k,args) concl db = let se = find k db in if matches_modes args se.sentry_mode then let st = if db.use_dn then Some db.hintdb_state else None in let pat = lookup_tacs concl st se in merge_entry secvars db [] pat else merge_entry secvars db [] [] let is_exact = function | Give_exact _ -> true | _ -> false let is_unfold = function | Unfold_nth _ -> true | _ -> false let addkv gr id v db = let idv = id, { v with db = db.hintdb_name } in let k = match gr with | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr && is_unfold v.code.obj then None else Some gr | None -> None in let dnst = if db.use_dn then Some db.hintdb_state else None in let pat = if not db.use_dn && is_exact v.code.obj then None else v.pat in match k with | None -> let is_present (_, (_, v')) = KerName.equal v.code.uid v'.code.uid in if not (List.exists is_present db.hintdb_nopat) then (** FIXME *) { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } else db | Some gr -> let oval = find gr db in { db with hintdb_map = Constr_map.add gr (add_tac pat idv dnst oval) db.hintdb_map } let rebuild_db st' db = let db' = { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map; hintdb_state = st'; hintdb_nopat = [] } in List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat let add_one env sigma (k, v) db = let v = instantiate_hint env sigma v in let st',db,rebuild = match v.code.obj with | Unfold_nth egr -> let addunf (ids,csts) (ids',csts') = match egr with | EvalVarRef id -> (Id.Pred.add id ids, csts), (Id.Set.add id ids', csts') | EvalConstRef cst -> (ids, Cpred.add cst csts), (ids', Cset.add cst csts') in let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in state, { db with hintdb_unfolds = unfs }, true | _ -> db.hintdb_state, db, false in let db = if db.use_dn && rebuild then rebuild_db st' db else db in let db, id = next_hint_id db in addkv k id v db let add_list env sigma l db = List.fold_left (fun db k -> add_one env sigma k db) db l let remove_sdl p sdl = List.smartfilter p sdl let remove_he st p se = let sl1' = remove_sdl p se.sentry_nopat in let sl2' = remove_sdl p se.sentry_pat in if sl1' == se.sentry_nopat && sl2' == se.sentry_pat then se else rebuild_dn st { se with sentry_nopat = sl1'; sentry_pat = sl2' } let remove_list grs db = let filter (_, h) = match h.name with PathHints [gr] -> not (List.mem_f eq_gr gr grs) | _ -> true in let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in let hintnopat = List.smartfilter (fun (ge, sd) -> filter sd) db.hintdb_nopat in { db with hintdb_map = hintmap; hintdb_nopat = hintnopat } let remove_one gr db = remove_list [gr] db let get_entry se = let h = List.merge pri_order_int se.sentry_nopat se.sentry_pat in List.map snd h let iter f db = let iter_se k se = f (Some k) se.sentry_mode (get_entry se) in f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat); Constr_map.iter iter_se db.hintdb_map let fold f db accu = let accu = f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in Constr_map.fold (fun k se -> f (Some k) se.sentry_mode (get_entry se)) db.hintdb_map accu let transparent_state db = db.hintdb_state let set_transparent_state db st = if db.use_dn then rebuild_db st db else { db with hintdb_state = st } let add_cut path db = { db with hintdb_cut = normalize_path (PathOr (db.hintdb_cut, path)) } let add_mode gr m db = let se = find gr db in let se = { se with sentry_mode = m :: se.sentry_mode } in { db with hintdb_map = Constr_map.add gr se db.hintdb_map } let cut db = db.hintdb_cut let unfolds db = db.hintdb_unfolds let use_dn db = db.use_dn end module Hintdbmap = String.Map type hint_db = Hint_db.t type hint_db_table = hint_db Hintdbmap.t ref (** Initially created hint databases, for typeclasses and rewrite *) let typeclasses_db = "typeclass_instances" let rewrite_db = "rewrite" let auto_init_db = Hintdbmap.add typeclasses_db (Hint_db.empty full_transparent_state true) (Hintdbmap.add rewrite_db (Hint_db.empty cst_full_transparent_state true) Hintdbmap.empty) let searchtable : hint_db_table = ref auto_init_db let statustable = ref KNmap.empty let searchtable_map name = Hintdbmap.find name !searchtable let searchtable_add (name,db) = searchtable := Hintdbmap.add name db !searchtable let current_db_names () = Hintdbmap.domain !searchtable let current_db () = Hintdbmap.bindings !searchtable let current_pure_db () = List.map snd (current_db ()) let error_no_such_hint_database x = errorlabstrm "Hints" (str "No such Hint database: " ++ str x ++ str ".") (**************************************************************************) (* Definition of the summary *) (**************************************************************************) let hints_init : (unit -> unit) ref = ref (fun () -> ()) let add_hints_init f = let init = !hints_init in hints_init := (fun () -> init (); f ()) let init () = searchtable := auto_init_db; statustable := KNmap.empty; !hints_init () let freeze _ = (!searchtable, !statustable) let unfreeze (fs, st) = searchtable := fs; statustable := st let _ = Summary.declare_summary "search" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } (**************************************************************************) (* Auxiliary functions to prepare AUTOHINT objects *) (**************************************************************************) let rec nb_hyp c = match kind_of_term c with | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2 | _ -> 0 (* adding and removing tactics in the search table *) let try_head_pattern c = try head_pattern_bound c with BoundPattern -> error "Bound head variable." let with_uid c = { obj = c; uid = fresh_key () } let secvars_of_idset s = Id.Set.fold (fun id p -> if is_section_variable id then Id.Pred.add id p else p) s Id.Pred.empty let secvars_of_constr env c = secvars_of_idset (global_vars_set env c) let secvars_of_global env gr = secvars_of_idset (vars_of_global_reference env gr) let make_exact_entry env sigma info poly ?(name=PathAny) (c, cty, ctx) = let secvars = secvars_of_constr env c in let cty = strip_outer_cast cty in match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" | _ -> let pat = Patternops.pattern_of_constr env sigma cty in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_exact_entry" in let pri = match info.hint_priority with None -> 0 | Some p -> p in let pat = match info.hint_pattern with | Some pat -> snd pat | None -> pat in (Some hd, { pri; poly; pat = Some pat; name; db = None; secvars; code = with_uid (Give_exact (c, cty, ctx)); }) let make_apply_entry env sigma (eapply,hnf,verbose) info poly ?(name=PathAny) (c, cty, ctx) = let cty = if hnf then hnf_constr env sigma cty else cty in match kind_of_term cty with | Prod _ -> let sigma' = Evd.merge_context_set univ_flexible sigma ctx in let ce = mk_clenv_from_env env sigma' None (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in let pat = Patternops.pattern_of_constr env ce.evd c' in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in let nmiss = List.length (clenv_missing ce) in let secvars = secvars_of_constr env c in let pri = match info.hint_priority with None -> nb_hyp cty + nmiss | Some p -> p in let pat = match info.hint_pattern with | Some p -> snd p | None -> pat in if Int.equal nmiss 0 then (Some hd, { pri; poly; pat = Some pat; name; db = None; secvars; code = with_uid (Res_pf(c,cty,ctx)); }) else begin if not eapply then failwith "make_apply_entry"; if verbose then Feedback.msg_info (str "the hint: eapply " ++ pr_lconstr c ++ str " will only be used by eauto"); (Some hd, { pri; poly; pat = Some pat; name; db = None; secvars; code = with_uid (ERes_pf(c,cty,ctx)); }) end | _ -> failwith "make_apply_entry" (* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose c is a constr cty is the type of constr *) let pr_hint_term env sigma ctx = function | IsGlobRef gr -> pr_global gr | IsConstr (c, ctx) -> let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in pr_constr_env env sigma c (** We need an object to record the side-effect of registering global universes associated with a hint. *) let cache_context_set (_,c) = Global.push_context_set false c let input_context_set : Univ.ContextSet.t -> Libobject.obj = let open Libobject in declare_object { (default_object "Global universe context") with cache_function = cache_context_set; load_function = (fun _ -> cache_context_set); discharge_function = (fun (_,a) -> Some a); classify_function = (fun a -> Keep a) } let warn_polymorphic_hint = CWarnings.create ~name:"polymorphic-hint" ~category:"automation" (fun hint -> strbrk"Using polymorphic hint " ++ hint ++ str" monomorphically" ++ strbrk" use Polymorphic Hint to use it polymorphically.") let fresh_global_or_constr env sigma poly cr = let isgr, (c, ctx) = match cr with | IsGlobRef gr -> true, Universes.fresh_global_instance env gr | IsConstr (c, ctx) -> false, (c, ctx) in if poly then (c, ctx) else if Univ.ContextSet.is_empty ctx then (c, ctx) else begin if isgr then warn_polymorphic_hint (pr_hint_term env sigma ctx cr); Lib.add_anonymous_leaf (input_context_set ctx); (c, Univ.ContextSet.empty) end let make_resolves env sigma flags info poly ?name cr = let c, ctx = fresh_global_or_constr env sigma poly cr in let cty = Retyping.get_type_of env sigma c in let try_apply f = try Some (f (c, cty, ctx)) with Failure _ -> None in let ents = List.map_filter try_apply [make_exact_entry env sigma info poly ?name; make_apply_entry env sigma flags info poly ?name] in if List.is_empty ents then errorlabstrm "Hint" (pr_lconstr c ++ spc() ++ (if pi1 flags then str"cannot be used as a hint." else str "can be used as a hint only for eauto.")); ents (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma decl = let hname = get_id decl in let c = mkVar hname in try [make_apply_entry env sigma (true, true, false) empty_hint_info false ~name:(PathHints [VarRef hname]) (c, get_type decl, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") (* REM : in most cases hintname = id *) let make_unfold eref = let g = global_of_evaluable_reference eref in (Some g, { pri = 4; poly = false; pat = None; name = PathHints [g]; db = None; secvars = secvars_of_global (Global.env ()) g; code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = let tacast = Genarg.in_gen (Genarg.glbwit Constrarg.wit_ltac) tacast in let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri = pri; poly = false; pat = pat; name = PathAny; db = None; secvars = Id.Pred.empty; (* Approximation *) code = with_uid (Extern tacast) }) let make_mode ref m = let ty = Global.type_of_global_unsafe ref in let ctx, t = decompose_prod ty in let n = List.length ctx in let m' = Array.of_list m in if not (n == Array.length m') then errorlabstrm "Hint" (pr_global ref ++ str" has " ++ int n ++ str" arguments while the mode declares " ++ int (Array.length m')) else m' let make_trivial env sigma poly ?(name=PathAny) r = let c,ctx = fresh_global_or_constr env sigma poly r in let sigma = Evd.merge_context_set univ_flexible sigma ctx in let t = hnf_constr env sigma (unsafe_type_of env sigma c) in let hd = head_of_constr_reference (head_constr t) in let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; poly = poly; pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); name = name; db = None; secvars = secvars_of_constr env c; code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) (**************************************************************************) (* declaration of the AUTOHINT library object *) (**************************************************************************) (* If the database does not exist, it is created *) (* TODO: should a warning be printed in this case ?? *) let get_db dbname = try searchtable_map dbname with Not_found -> Hint_db.empty ~name:dbname empty_transparent_state false let add_hint dbname hintlist = let check (_, h) = let () = if KNmap.mem h.code.uid !statustable then error "Conflicting hint keys. This can happen when including \ twice the same module." in statustable := KNmap.add h.code.uid false !statustable in let () = List.iter check hintlist in let db = get_db dbname in let env = Global.env () in let sigma = Evd.from_env env in let db' = Hint_db.add_list env sigma hintlist db in searchtable_add (dbname,db') let add_transparency dbname grs b = let db = get_db dbname in let st = Hint_db.transparent_state db in let st' = List.fold_left (fun (ids, csts) gr -> match gr with | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts) | EvalVarRef v -> (if b then Id.Pred.add else Id.Pred.remove) v ids, csts) st grs in searchtable_add (dbname, Hint_db.set_transparent_state db st') let remove_hint dbname grs = let db = get_db dbname in let db' = Hint_db.remove_list grs db in searchtable_add (dbname, db') type hint_action = | CreateDB of bool * transparent_state | AddTransparency of evaluable_global_reference list * bool | AddHints of hint_entry list | RemoveHints of global_reference list | AddCut of hints_path | AddMode of global_reference * hint_mode array let add_cut dbname path = let db = get_db dbname in let db' = Hint_db.add_cut path db in searchtable_add (dbname, db') let add_mode dbname l m = let db = get_db dbname in let db' = Hint_db.add_mode l m db in searchtable_add (dbname, db') type hint_obj = { hint_local : bool; hint_name : string; hint_action : hint_action; } let load_autohint _ (kn, h) = let name = h.hint_name in match h.hint_action with | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty ~name st b) | AddTransparency (grs, b) -> add_transparency name grs b | AddHints hints -> add_hint name hints | RemoveHints grs -> remove_hint name grs | AddCut path -> add_cut name path | AddMode (l, m) -> add_mode name l m let open_autohint i (kn, h) = if Int.equal i 1 then match h.hint_action with | AddHints hints -> let add (_, hint) = statustable := KNmap.add hint.code.uid true !statustable in List.iter add hints | _ -> () let cache_autohint (kn, obj) = load_autohint 1 (kn, obj); open_autohint 1 (kn, obj) let subst_autohint (subst, obj) = let subst_key gr = let (lab'', elab') = subst_global subst gr in let gr' = (try head_of_constr_reference (head_constr_bound elab') with Bound -> lab'') in if gr' == gr then gr else gr' in let subst_hint (k,data as hint) = let k' = Option.smartmap subst_key k in let pat' = Option.smartmap (subst_pattern subst) data.pat in let code' = match data.code.obj with | Res_pf (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in if c==c' && t'==t then data.code.obj else Res_pf (c', t',ctx) | ERes_pf (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in if c==c' && t'==t then data.code.obj else ERes_pf (c',t',ctx) | Give_exact (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in if c==c' && t'== t then data.code.obj else Give_exact (c',t',ctx) | Res_pf_THEN_trivial_fail (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in if c==c' && t==t' then data.code.obj else Res_pf_THEN_trivial_fail (c',t',ctx) | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in if ref==ref' then data.code.obj else Unfold_nth ref' | Extern tac -> let tac' = Genintern.generic_substitute subst tac in if tac==tac' then data.code.obj else Extern tac' in let name' = subst_path_atom subst data.name in let uid' = subst_kn subst data.code.uid in let data' = if data.code.uid == uid' && data.pat == pat' && data.name == name' && data.code.obj == code' then data else { data with pat = pat'; name = name'; code = { obj = code'; uid = uid' } } in if k' == k && data' == data then hint else (k',data') in let action = match obj.hint_action with | CreateDB _ -> obj.hint_action | AddTransparency (grs, b) -> let grs' = List.smartmap (subst_evaluable_reference subst) grs in if grs == grs' then obj.hint_action else AddTransparency (grs', b) | AddHints hintlist -> let hintlist' = List.smartmap subst_hint hintlist in if hintlist' == hintlist then obj.hint_action else AddHints hintlist' | RemoveHints grs -> let grs' = List.smartmap (subst_global_reference subst) grs in if grs == grs' then obj.hint_action else RemoveHints grs' | AddCut path -> let path' = subst_hints_path subst path in if path' == path then obj.hint_action else AddCut path' | AddMode (l,m) -> let l' = subst_global_reference subst l in if l' == l then obj.hint_action else AddMode (l', m) in if action == obj.hint_action then obj else { obj with hint_action = action } let classify_autohint obj = match obj.hint_action with | AddHints [] -> Dispose | _ -> if obj.hint_local then Dispose else Substitute obj let inAutoHint : hint_obj -> obj = declare_object {(default_object "AUTOHINT") with cache_function = cache_autohint; load_function = load_autohint; open_function = open_autohint; subst_function = subst_autohint; classify_function = classify_autohint; } let make_hint ?(local = false) name action = { hint_local = local; hint_name = name; hint_action = action; } let create_hint_db l n st b = let hint = make_hint ~local:l n (CreateDB (b, st)) in Lib.add_anonymous_leaf (inAutoHint hint) let remove_hints local dbnames grs = let dbnames = if List.is_empty dbnames then ["core"] else dbnames in List.iter (fun dbname -> let hint = make_hint ~local dbname (RemoveHints grs) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames (**************************************************************************) (* The "Hint" vernacular command *) (**************************************************************************) let add_resolves env sigma clist local dbnames = List.iter (fun dbname -> let r = List.flatten (List.map (fun (pri, poly, hnf, path, gr) -> make_resolves env sigma (true,hnf,Flags.is_verbose()) pri poly ~name:path gr) clist) in let hint = make_hint ~local dbname (AddHints r) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_unfolds l local dbnames = List.iter (fun dbname -> let hint = make_hint ~local dbname (AddHints (List.map make_unfold l)) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_cuts l local dbnames = List.iter (fun dbname -> let hint = make_hint ~local dbname (AddCut l) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_mode l m local dbnames = List.iter (fun dbname -> let m' = make_mode l m in let hint = make_hint ~local dbname (AddMode (l, m')) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_transparency l b local dbnames = List.iter (fun dbname -> let hint = make_hint ~local dbname (AddTransparency (l, b)) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_extern info tacast local dbname = let pat = match info.hint_pattern with | None -> None | Some (_, pat) -> Some pat in let hint = make_hint ~local dbname (AddHints [make_extern (Option.get info.hint_priority) pat tacast]) in Lib.add_anonymous_leaf (inAutoHint hint) let add_externs info tacast local dbnames = List.iter (add_extern info tacast local) dbnames let add_trivials env sigma l local dbnames = List.iter (fun dbname -> let l = List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l in let hint = make_hint ~local dbname (AddHints l) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let (forward_intern_tac, extern_intern_tac) = Hook.make () type hnf = bool type hint_info = (patvar list * constr_pattern) hint_info_gen type hints_entry = | HintsResolveEntry of (hint_info * polymorphic * hnf * hints_path_atom * hint_term) list | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsModeEntry of global_reference * hint_mode list | HintsExternEntry of hint_info * glob_tactic_expr let default_prepare_hint_ident = Id.of_string "H" exception Found of constr * types let prepare_hint check (poly,local) env init (sigma,c) = let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in (* We re-abstract over uninstantiated evars and universes. It is actually a bit stupid to generalize over evars since the first thing make_resolves will do is to re-instantiate the products *) let sigma, subst = Evd.nf_univ_variables sigma in let c = Vars.subst_univs_constr subst (Evarutil.nf_evar sigma c) in let c = drop_extra_implicit_args c in let vars = ref (collect_vars c) in let subst = ref [] in let rec find_next_evar c = match kind_of_term c with | Evar (evk,args as ev) -> (* We skip the test whether args is the identity or not *) let t = Evarutil.nf_evar sigma (existential_type sigma ev) in let t = List.fold_right (fun (e,id) c -> replace_term e id c) !subst t in if not (closed0 c) then error "Hints with holes dependent on a bound variable not supported."; if occur_existential t then (* Not clever enough to construct dependency graph of evars *) error "Not clever enough to deal with evars dependent in other evars."; raise (Found (c,t)) | _ -> Constr.iter find_next_evar c in let rec iter c = try find_next_evar c; c with Found (evar,t) -> let id = next_ident_away_from default_prepare_hint_ident (fun id -> Id.Set.mem id !vars) in vars := Id.Set.add id !vars; subst := (evar,mkVar id)::!subst; mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in let c' = iter c in if check then Pretyping.check_evars (Global.env()) Evd.empty sigma c'; let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) else if local then IsConstr (c', diff) else (Lib.add_anonymous_leaf (input_context_set diff); IsConstr (c', Univ.ContextSet.empty)) let interp_hints poly = fun h -> let env = (Global.env()) in let sigma = Evd.from_env env in let f poly c = let evd,c = Constrintern.interp_open_constr env sigma c in prepare_hint true (poly,false) (Global.env()) Evd.empty (evd,c) in let fref r = let gr = global_with_alias r in Dumpglob.add_glob (loc_of_reference r) gr; gr in let fr r = evaluable_of_global_reference (Global.env()) (fref r) in let fi c = match c with | HintsReference c -> let gr = global_with_alias c in (PathHints [gr], poly, IsGlobRef gr) | HintsConstr c -> (PathAny, poly, f poly c) in let fp = Constrintern.intern_constr_pattern (Global.env()) in let fres (info, b, r) = let path, poly, gr = fi r in let info = { info with hint_pattern = Option.map fp info.hint_pattern } in (info, poly, b, path, gr) in match h with | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) | HintsTransparency (lhints, b) -> HintsTransparencyEntry (List.map fr lhints, b) | HintsMode (r, l) -> HintsModeEntry (fref r, l) | HintsConstructors lqid -> let constr_hints_of_ind qid = let ind = global_inductive_with_alias qid in let mib,_ = Global.lookup_inductive ind in Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind"; List.init (nconstructors ind) (fun i -> let c = (ind,i+1) in let gr = ConstructRef c in empty_hint_info, mib.Declarations.mind_polymorphic, true, PathHints [gr], IsGlobRef gr) in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> let pat = Option.map fp patcom in let l = match pat with None -> [] | Some (l, _) -> l in let tacexp = Hook.get forward_intern_tac l tacexp in HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) let add_hints local dbnames0 h = if String.List.mem "nocore" dbnames0 then error "The hint database \"nocore\" is meant to stay empty."; let dbnames = if List.is_empty dbnames0 then ["core"] else dbnames0 in let env = Global.env() in let sigma = Evd.from_env env in match h with | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames | HintsCutEntry lhints -> add_cuts lhints local dbnames | HintsModeEntry (l,m) -> add_mode l m local dbnames | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames | HintsTransparencyEntry (lhints, b) -> add_transparency lhints b local dbnames | HintsExternEntry (info, tacexp) -> add_externs info tacexp local dbnames let expand_constructor_hints env sigma lems = List.map_append (fun (evd,lem) -> match kind_of_term lem with | Ind (ind,u) -> List.init (nconstructors ind) (fun i -> let ctx = Univ.ContextSet.diff (Evd.universe_context_set evd) (Evd.universe_context_set sigma) in not (Univ.ContextSet.is_empty ctx), IsConstr (mkConstructU ((ind,i+1),u),ctx)) | _ -> [match prepare_hint false (false,true) env sigma (evd,lem) with | IsConstr (c, ctx) -> not (Univ.ContextSet.is_empty ctx), IsConstr (c, ctx) | IsGlobRef _ -> assert false (* Impossible return value *) ]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types *) let add_hint_lemmas env sigma eapply lems hint_db = let lems = expand_constructor_hints env sigma lems in let hintlist' = List.map_append (fun (poly, lem) -> make_resolves env sigma (eapply,true,false) empty_hint_info poly lem) lems in Hint_db.add_list env sigma hintlist' hint_db let make_local_hint_db env sigma ts eapply lems = let map c = let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (c, sigma, _) = c.delayed env sigma in (Sigma.to_evar_map sigma, c) in let lems = List.map map lems in let sign = Environ.named_context env in let ts = match ts with | None -> Hint_db.transparent_state (searchtable_map "core") | Some ts -> ts in let hintlist = List.map_append (make_resolve_hyp env sigma) sign in add_hint_lemmas env sigma eapply lems (Hint_db.add_list env sigma hintlist (Hint_db.empty ts false)) let make_local_hint_db env sigma ?ts eapply lems = make_local_hint_db env sigma ts eapply lems let make_db_list dbnames = let use_core = not (List.mem "nocore" dbnames) in let dbnames = List.remove String.equal "nocore" dbnames in let dbnames = if use_core then "core"::dbnames else dbnames in let lookup db = try searchtable_map db with Not_found -> error_no_such_hint_database db in List.map lookup dbnames (**************************************************************************) (* Functions for printing the hints *) (**************************************************************************) let pr_hint_elt (c, _, _) = pr_constr c let pr_hint h = match h.obj with | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt c) | ERes_pf (c, _) -> (str"simple eapply " ++ pr_hint_elt c) | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt c) | Res_pf_THEN_trivial_fail (c, _) -> (str"simple apply " ++ pr_hint_elt c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) | Extern tac -> let env = try let (_, env) = Pfedit.get_current_goal_context () in env with e when CErrors.noncritical e -> Global.env () in (str "(*external*) " ++ Pptactic.pr_glb_generic env tac) let pr_id_hint (id, v) = let pr_pat p = str", pattern " ++ pr_lconstr_pattern p in (pr_hint v.code ++ str"(level " ++ int v.pri ++ pr_opt_no_spc pr_pat v.pat ++ str", id " ++ int id ++ str ")" ++ spc ()) let pr_hint_list hintlist = (str " " ++ hov 0 (prlist pr_id_hint hintlist) ++ fnl ()) let pr_hints_db (name,db,hintlist) = (str "In the database " ++ str name ++ str ":" ++ if List.is_empty hintlist then (str " nothing" ++ fnl ()) else (fnl () ++ pr_hint_list hintlist)) (* Print all hints associated to head c in any database *) let pr_hint_list_for_head c = let dbs = current_db () in let validate (name, db) = let hints = List.map (fun v -> 0, v) (Hint_db.map_all Id.Pred.full c db) in (name, db, hints) in let valid_dbs = List.map validate dbs in if List.is_empty valid_dbs then (str "No hint declared for :" ++ pr_global c) else hov 0 (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++ hov 0 (prlist pr_hints_db valid_dbs)) let pr_hint_ref ref = pr_hint_list_for_head ref (* Print all hints associated to head id in any database *) let pr_hint_term cl = try let dbs = current_db () in let valid_dbs = let fn = try let hdc = decompose_app_bound cl in if occur_existential cl then Hint_db.map_existential ~secvars:Id.Pred.full hdc cl else Hint_db.map_auto ~secvars:Id.Pred.full hdc cl with Bound -> Hint_db.map_none ~secvars:Id.Pred.full in let fn db = List.map (fun x -> 0, x) (fn db) in List.map (fun (name, db) -> (name, db, fn db)) dbs in if List.is_empty valid_dbs then (str "No hint applicable for current goal") else (str "Applicable Hints :" ++ fnl () ++ hov 0 (prlist pr_hints_db valid_dbs)) with Match_failure _ | Failure _ -> (str "No hint applicable for current goal") (* print all hints that apply to the concl of the current goal *) let pr_applicable_hint () = let pts = get_pftreestate () in let glss = Proof.V82.subgoals pts in match glss.Evd.it with | [] -> CErrors.error "No focused goal." | g::_ -> pr_hint_term (Goal.V82.concl glss.Evd.sigma g) let pp_hint_mode = function | ModeInput -> str"+" | ModeNoHeadEvar -> str"!" | ModeOutput -> str"-" (* displays the whole hint database db *) let pr_hint_db db = let pr_mode = prvect_with_sep spc pp_hint_mode in let pr_modes l = if List.is_empty l then mt () else str" (modes " ++ prlist_with_sep pr_comma pr_mode l ++ str")" in let content = let fold head modes hintlist accu = let goal_descr = match head with | None -> str "For any goal" | Some head -> str "For " ++ pr_global head ++ pr_modes modes in let hints = pr_hint_list (List.map (fun x -> (0, x)) hintlist) in let hint_descr = hov 0 (goal_descr ++ str " -> " ++ hints) in accu ++ hint_descr in Hint_db.fold fold db (mt ()) in let (ids, csts) = Hint_db.transparent_state db in hov 0 ((if Hint_db.use_dn db then str"Discriminated database" else str"Non-discriminated database")) ++ fnl () ++ hov 2 (str"Unfoldable variable definitions: " ++ pr_idpred ids) ++ fnl () ++ hov 2 (str"Unfoldable constant definitions: " ++ pr_cpred csts) ++ fnl () ++ hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)) ++ fnl () ++ content let pr_hint_db_by_name dbname = try let db = searchtable_map dbname in pr_hint_db db with Not_found -> error_no_such_hint_database dbname (* displays all the hints of all databases *) let pr_searchtable () = let fold name db accu = accu ++ str "In the database " ++ str name ++ str ":" ++ fnl () ++ pr_hint_db db ++ fnl () in Hintdbmap.fold fold !searchtable (mt ()) let print_mp mp = try let qid = Nametab.shortest_qualid_of_module mp in str " from " ++ pr_qualid qid with Not_found -> mt () let is_imported h = try KNmap.find h.uid !statustable with Not_found -> true let warn_non_imported_hint = CWarnings.create ~name:"non-imported-hint" ~category:"automation" (fun (hint,mp) -> strbrk "Hint used but not imported: " ++ hint ++ print_mp mp) let warn h x = let hint = pr_hint h in let (mp, _, _) = KerName.repr h.uid in warn_non_imported_hint (hint,mp); Proofview.tclUNIT x let run_hint tac k = match !warn_hint with | `LAX -> k tac.obj | `WARN -> if is_imported tac then k tac.obj else Proofview.tclBIND (k tac.obj) (fun x -> warn tac x) | `STRICT -> if is_imported tac then k tac.obj else Proofview.tclZERO (UserError ("", (str "Tactic failure."))) let repr_hint h = h.obj coq-8.6/tactics/hints.mli0000644000175000017500000002334013022274260014417 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* global_reference * constr array val secvars_of_hyps : Context.Named.t -> Id.Pred.t val empty_hint_info : 'a hint_info_gen (** Pre-created hint databases *) type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of Genarg.glob_generic_argument (* Hint Extern *) type hint type raw_hint = constr * types * Univ.universe_context_set type 'a hints_path_atom_gen = | PathHints of 'a list (* For forward hints, their names is the list of projections *) | PathAny type hints_path_atom = global_reference hints_path_atom_gen type hint_db_name = string type 'a with_metadata = private { pri : int; (** A number between 0 and 4, 4 = lower priority *) poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (** A pattern for the concl of the Goal *) name : hints_path_atom; (** A potential name to refer to the hint *) db : hint_db_name option; secvars : Id.Pred.t; (** The section variables this hint depends on, as a predicate *) code : 'a; (** the tactic to apply when the concl matches pat *) } type full_hint = hint with_metadata type search_entry (** The head may not be bound. *) type hint_entry type 'a hints_path_gen = | PathAtom of 'a hints_path_atom_gen | PathStar of 'a hints_path_gen | PathSeq of 'a hints_path_gen * 'a hints_path_gen | PathOr of 'a hints_path_gen * 'a hints_path_gen | PathEmpty | PathEpsilon type pre_hints_path = Libnames.reference hints_path_gen type hints_path = global_reference hints_path_gen val normalize_path : hints_path -> hints_path val path_matches : hints_path -> hints_path_atom list -> bool val path_derivate : hints_path -> hints_path_atom -> hints_path val pp_hints_path_gen : ('a -> Pp.std_ppcmds) -> 'a hints_path_gen -> Pp.std_ppcmds val pp_hints_path_atom : ('a -> Pp.std_ppcmds) -> 'a hints_path_atom_gen -> Pp.std_ppcmds val pp_hints_path : hints_path -> Pp.std_ppcmds val pp_hint_mode : hint_mode -> Pp.std_ppcmds val glob_hints_path_atom : Libnames.reference hints_path_atom_gen -> Globnames.global_reference hints_path_atom_gen val glob_hints_path : Libnames.reference hints_path_gen -> Globnames.global_reference hints_path_gen module Hint_db : sig type t val empty : ?name:hint_db_name -> transparent_state -> bool -> t val find : global_reference -> t -> search_entry (** All hints which have no pattern. * [secvars] represent the set of section variables that * can be used in the hint. *) val map_none : secvars:Id.Pred.t -> t -> full_hint list (** All hints associated to the reference *) val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments, _not_ using the discrimination net. *) val map_existential : secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments and using the discrimination net. *) val map_eauto : secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments. *) val map_auto : secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list val add_one : env -> evar_map -> hint_entry -> t -> t val add_list : env -> evar_map -> hint_entry list -> t -> t val remove_one : global_reference -> t -> t val remove_list : global_reference list -> t -> t val iter : (global_reference option -> hint_mode array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool val transparent_state : t -> transparent_state val set_transparent_state : t -> transparent_state -> t val add_cut : hints_path -> t -> t val cut : t -> hints_path val unfolds : t -> Id.Set.t * Cset.t end type hint_db = Hint_db.t type hnf = bool type hint_info = (patvar list * constr_pattern) hint_info_gen type hint_term = | IsGlobRef of global_reference | IsConstr of constr * Univ.universe_context_set type hints_entry = | HintsResolveEntry of (hint_info * polymorphic * hnf * hints_path_atom * hint_term) list | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsModeEntry of global_reference * hint_mode list | HintsExternEntry of hint_info * Tacexpr.glob_tactic_expr val searchtable_map : hint_db_name -> hint_db val searchtable_add : (hint_db_name * hint_db) -> unit (** [create_hint_db local name st use_dn]. [st] is a transparency state for unification using this db [use_dn] switches the use of the discrimination net for all hints and patterns. *) val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit val remove_hints : bool -> hint_db_name list -> global_reference list -> unit val current_db_names : unit -> String.Set.t val current_pure_db : unit -> hint_db list val interp_hints : polymorphic -> hints_expr -> hints_entry val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit val prepare_hint : bool (* Check no remaining evars *) -> (bool * bool) (* polymorphic or monomorphic, local or global *) -> env -> evar_map -> open_constr -> hint_term (** [make_exact_entry info (c, ctyp, ctx)]. [c] is the term given as an exact proof to solve the goal; [ctyp] is the type of [c]. [ctx] is its (refreshable) universe context. In info: [hint_priority] is the hint's desired priority, it is 0 if unspecified [hint_pattern] is the hint's desired pattern, it is inferred if not specified *) val make_exact_entry : env -> evar_map -> hint_info -> polymorphic -> ?name:hints_path_atom -> (constr * types * Univ.universe_context_set) -> hint_entry (** [make_apply_entry (eapply,hnf,verbose) info (c,cty,ctx))]. [eapply] is true if this hint will be used only with EApply; [hnf] should be true if we should expand the head of cty before searching for products; [c] is the term given as an exact proof to solve the goal; [cty] is the type of [c]. [ctx] is its (refreshable) universe context. In info: [hint_priority] is the hint's desired priority, it is computed as the number of products in [cty] if unspecified [hint_pattern] is the hint's desired pattern, it is inferred from the conclusion of [cty] if not specified *) val make_apply_entry : env -> evar_map -> bool * bool * bool -> hint_info -> polymorphic -> ?name:hints_path_atom -> (constr * types * Univ.universe_context_set) -> hint_entry (** A constr which is Hint'ed will be: - (1) used as an Exact, if it does not start with a product - (2) used as an Apply, if its HNF starts with a product, and has no missing arguments. - (3) used as an EApply, if its HNF starts with a product, and has missing arguments. *) val make_resolves : env -> evar_map -> bool * bool * bool -> hint_info -> polymorphic -> ?name:hints_path_atom -> hint_term -> hint_entry list (** [make_resolve_hyp hname htyp]. used to add an hypothesis to the local hint database; Never raises a user exception; If the hyp cannot be used as a Hint, the empty list is returned. *) val make_resolve_hyp : env -> evar_map -> Context.Named.Declaration.t -> hint_entry list (** [make_extern pri pattern tactic_expr] *) val make_extern : int -> constr_pattern option -> Tacexpr.glob_tactic_expr -> hint_entry val run_hint : hint -> ((raw_hint * clausenv) hint_ast -> 'r Proofview.tactic) -> 'r Proofview.tactic (** This function is for backward compatibility only, not to use in newly written code. *) val repr_hint : hint -> (raw_hint * clausenv) hint_ast val extern_intern_tac : (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr) Hook.t (** Create a Hint database from the pairs (name, constr). Useful to take the current goal hypotheses as hints; Boolean tells if lemmas with evars are allowed *) val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> Tacexpr.delayed_open_constr list -> hint_db val make_db_list : hint_db_name list -> hint_db list (** Initially created hint databases, for typeclasses and rewrite *) val typeclasses_db : hint_db_name val rewrite_db : hint_db_name (** Printing hints *) val pr_searchtable : unit -> std_ppcmds val pr_applicable_hint : unit -> std_ppcmds val pr_hint_ref : global_reference -> std_ppcmds val pr_hint_db_by_name : hint_db_name -> std_ppcmds val pr_hint_db : Hint_db.t -> std_ppcmds val pr_hint : hint -> Pp.std_ppcmds (** Hook for changing the initialization of auto *) val add_hints_init : (unit -> unit) -> unit coq-8.6/tactics/equality.ml0000644000175000017500000021420113022274260014754 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* !discriminate_introduction); optwrite = (:=) discriminate_introduction } let injection_pattern_l2r_order = ref true let use_injection_pattern_l2r_order () = !injection_pattern_l2r_order && Flags.version_strictly_greater Flags.V8_4 let _ = declare_bool_option { optsync = true; optdepr = false; optname = "injection left-to-right pattern order and clear by default when with introduction pattern"; optkey = ["Injection";"L2R";"Pattern";"Order"]; optread = (fun () -> !injection_pattern_l2r_order) ; optwrite = (fun b -> injection_pattern_l2r_order := b) } let injection_in_context = ref false let use_injection_in_context () = !injection_in_context && Flags.version_strictly_greater Flags.V8_5 let _ = declare_bool_option { optsync = true; optdepr = false; optname = "injection in context"; optkey = ["Structural";"Injection"]; optread = (fun () -> !injection_in_context) ; optwrite = (fun b -> injection_in_context := b) } (* Rewriting tactics *) let tclNOTSAMEGOAL tac = Proofview.V82.tactic (Tacticals.tclNOTSAMEGOAL (Proofview.V82.of_tactic tac)) type dep_proof_flag = bool (* true = support rewriting dependent proofs *) type freeze_evars_flag = bool (* true = don't instantiate existing evars *) type orientation = bool type conditions = | Naive (* Only try the first occurrence of the lemma (default) *) | FirstSolved (* Use the first match whose side-conditions are solved *) | AllMatches (* Rewrite all matches whose side-conditions are solved *) (* Warning : rewriting from left to right only works if there exists in the context a theorem named __r with type (A:)(x:A)(P:A->Prop)(P x)->(y:A)(eqname A y x)->(P y). If another equality myeq is introduced, then corresponding theorems myeq_ind_r, myeq_rec_r and myeq_rect_r have to be proven. See below. -- Eduardo (19/8/97) *) let rewrite_core_unif_flags = { modulo_conv_on_closed_terms = None; use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; modulo_delta_types = empty_transparent_state; check_applied_meta_types = true; use_pattern_unification = true; use_meta_bound_pattern_unification = true; frozen_evars = Evar.Set.empty; restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = true; } let rewrite_unif_flags = { core_unify_flags = rewrite_core_unif_flags; merge_unify_flags = rewrite_core_unif_flags; subterm_unify_flags = rewrite_core_unif_flags; allow_K_in_toplevel_higher_order_unification = false; (* allow_K does not matter in practice because calls w_typed_unify *) resolve_evars = true } let freeze_initial_evars sigma flags clause = (* We take evars of the type: this may include old evars! For excluding *) (* all old evars, including the ones occurring in the rewriting lemma, *) (* we would have to take the clenv_value *) let newevars = Evd.evars_of_term (clenv_type clause) in let evars = fold_undefined (fun evk _ evars -> if Evar.Set.mem evk newevars then evars else Evar.Set.add evk evars) sigma Evar.Set.empty in {flags with core_unify_flags = {flags.core_unify_flags with frozen_evars = evars}; merge_unify_flags = {flags.merge_unify_flags with frozen_evars = evars}; subterm_unify_flags = {flags.subterm_unify_flags with frozen_evars = evars}} let make_flags frzevars sigma flags clause = if frzevars then freeze_initial_evars sigma flags clause else flags let side_tac tac sidetac = match sidetac with | None -> tac | Some sidetac -> tclTHENSFIRSTn tac [|Proofview.tclUNIT ()|] sidetac let instantiate_lemma_all frzevars gl c ty l l2r concl = let env = Proofview.Goal.env gl in let eqclause = pf_apply Clenv.make_clenv_binding gl (c,ty) l in let (equiv, args) = decompose_appvect (Clenv.clenv_type eqclause) in let arglen = Array.length args in let () = if arglen < 2 then error "The term provided is not an applied relation." in let c1 = args.(arglen - 2) in let c2 = args.(arglen - 1) in let try_occ (evd', c') = Clenvtac.clenv_pose_dependent_evars true {eqclause with evd = evd'} in let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_unif_flags eqclause in let occs = w_unify_to_subterm_all ~flags env eqclause.evd ((if l2r then c1 else c2),concl) in List.map try_occ occs let instantiate_lemma gl c ty l l2r concl = let sigma, ct = pf_type_of gl c in let t = try snd (reduce_to_quantified_ind (pf_env gl) sigma ct) with UserError _ -> ct in let eqclause = Clenv.make_clenv_binding (pf_env gl) sigma (c,t) l in [eqclause] let rewrite_conv_closed_core_unif_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; (* We have this flag for historical reasons, it has e.g. the consequence *) (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) modulo_delta = empty_transparent_state; modulo_delta_types = full_transparent_state; check_applied_meta_types = true; use_pattern_unification = true; (* To rewrite "?n x y" in "y+x=0" when ?n is *) (* a preexisting evar of the goal*) use_meta_bound_pattern_unification = true; frozen_evars = Evar.Set.empty; (* This is set dynamically *) restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = true; } let rewrite_conv_closed_unif_flags = { core_unify_flags = rewrite_conv_closed_core_unif_flags; merge_unify_flags = rewrite_conv_closed_core_unif_flags; subterm_unify_flags = rewrite_conv_closed_core_unif_flags; allow_K_in_toplevel_higher_order_unification = false; resolve_evars = false } let rewrite_keyed_core_unif_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; (* We have this flag for historical reasons, it has e.g. the consequence *) (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) modulo_delta = full_transparent_state; modulo_delta_types = full_transparent_state; check_applied_meta_types = true; use_pattern_unification = true; (* To rewrite "?n x y" in "y+x=0" when ?n is *) (* a preexisting evar of the goal*) use_meta_bound_pattern_unification = true; frozen_evars = Evar.Set.empty; (* This is set dynamically *) restrict_conv_on_strict_subterms = false; modulo_betaiota = true; modulo_eta = true; } let rewrite_keyed_unif_flags = { core_unify_flags = rewrite_keyed_core_unif_flags; merge_unify_flags = rewrite_keyed_core_unif_flags; subterm_unify_flags = rewrite_keyed_core_unif_flags; allow_K_in_toplevel_higher_order_unification = false; resolve_evars = false } let rewrite_elim with_evars frzevars cls c e = Proofview.Goal.enter { enter = begin fun gl -> let flags = if Unification.is_keyed_unification () then rewrite_keyed_unif_flags else rewrite_conv_closed_unif_flags in let flags = make_flags frzevars (Tacmach.New.project gl) flags c in general_elim_clause with_evars flags cls c e end } (* Ad hoc asymmetric general_elim_clause *) let general_elim_clause with_evars frzevars cls rew elim = let open Pretype_errors in Proofview.tclORELSE begin match cls with | None -> (* was tclWEAK_PROGRESS which only fails for tactics generating one subgoal and did not fail for useless conditional rewritings generating an extra condition *) tclNOTSAMEGOAL (rewrite_elim with_evars frzevars cls rew elim) | Some _ -> rewrite_elim with_evars frzevars cls rew elim end begin function (e, info) -> match e with | PretypeError (env, evd, NoOccurrenceFound (c', _)) -> Proofview.tclZERO (PretypeError (env, evd, NoOccurrenceFound (c', cls))) | e -> Proofview.tclZERO ~info e end let general_elim_clause with_evars frzevars tac cls c t l l2r elim = let all, firstonly, tac = match tac with | None -> false, false, None | Some (tac, Naive) -> false, false, Some tac | Some (tac, FirstSolved) -> true, true, Some (tclCOMPLETE tac) | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac) in let try_clause c = side_tac (tclTHEN (Proofview.Unsafe.tclEVARS c.evd) (general_elim_clause with_evars frzevars cls c elim)) tac in Proofview.Goal.enter { enter = begin fun gl -> let instantiate_lemma concl = if not all then instantiate_lemma gl c t l l2r concl else instantiate_lemma_all frzevars gl c t l l2r concl in let typ = match cls with | None -> pf_nf_concl gl | Some id -> pf_get_hyp_typ id (Proofview.Goal.assume gl) in let cs = instantiate_lemma typ in if firstonly then tclFIRST (List.map try_clause cs) else tclMAP try_clause cs end } (* The next function decides in particular whether to try a regular rewrite or a generalized rewrite. Approach is to break everything, if [eq] appears in head position then regular rewrite else try general rewrite. If occurrences are set, use general rewrite. *) let (forward_general_setoid_rewrite_clause, general_setoid_rewrite_clause) = Hook.make () (* Do we have a JMeq instance on twice the same domains ? *) let jmeq_same_dom gl = function | None -> true (* already checked in Hipattern.find_eq_data_decompose *) | Some t -> let rels, t = decompose_prod_assum t in let env = Environ.push_rel_context rels (Proofview.Goal.env gl) in match decompose_app t with | _, [dom1; _; dom2;_] -> is_conv env (Tacmach.New.project gl) dom1 dom2 | _ -> false (* find_elim determines which elimination principle is necessary to eliminate lbeq on sort_of_gl. *) let find_elim hdcncl lft2rgt dep cls ot gl = let inccl = Option.is_empty cls in if (is_global Coqlib.glob_eq hdcncl || (is_global Coqlib.glob_jmeq hdcncl && jmeq_same_dom gl ot)) && not dep || Flags.version_less_or_equal Flags.V8_2 then let c = match kind_of_term hdcncl with | Ind (ind_sp,u) -> let pr1 = lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) in begin match lft2rgt, cls with | Some true, None | Some false, Some _ -> let c1 = destConstRef pr1 in let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in begin try let _ = Global.lookup_constant c1' in c1' with Not_found -> errorlabstrm "Equality.find_elim" (str "Cannot find rewrite principle " ++ pr_label l' ++ str ".") end | _ -> destConstRef pr1 end | _ -> (* cannot occur since we checked that we are in presence of Logic.eq or Jmeq just before *) assert false in let Sigma (elim, sigma, p) = Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in Sigma ((elim, Safe_typing.empty_private_constants), sigma, p) else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) | false, Some true, true -> rew_l2r_scheme_kind | false, Some true, false -> rew_r2l_scheme_kind | false, _, false -> rew_l2r_scheme_kind | false, _, true -> rew_r2l_scheme_kind (* Dependent case *) | true, Some true, true -> rew_l2r_dep_scheme_kind | true, Some true, false -> rew_l2r_forward_dep_scheme_kind | true, _, true -> rew_r2l_dep_scheme_kind | true, _, false -> rew_r2l_forward_dep_scheme_kind in match kind_of_term hdcncl with | Ind (ind,u) -> let c, eff = find_scheme scheme_name ind in (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *) let Sigma (elim, sigma, p) = Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in Sigma ((elim, eff), sigma, p) | _ -> assert false let type_of_clause cls gl = match cls with | None -> Proofview.Goal.concl gl | Some id -> pf_get_hyp_typ id gl let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let evd = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let isatomic = isProd (whd_zeta evd hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun c type_of_cls in let Sigma ((elim, effs), sigma, p) = find_elim hdcncl lft2rgt dep cls (Some t) gl in let tac = Proofview.tclEFFECTS effs <*> general_elim_clause with_evars frzevars tac cls c t l (match lft2rgt with None -> false | Some b -> b) {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} in Sigma (tac, sigma, p) end } let adjust_rewriting_direction args lft2rgt = match args with | [_] -> (* equality to a constant, like in eq_true *) (* more natural to see -> as the rewriting to the constant *) if not lft2rgt then error "Rewriting non-symmetric equality not allowed from right-to-left."; None | _ -> (* other equality *) Some lft2rgt let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac) (* Main function for dispatching which kind of rewriting it is about *) let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac ((c,l) : constr with_bindings) with_evars = if occs != AllOccurrences then ( rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac) else Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in let rels, t = decompose_prod_assum (whd_betaiotazeta sigma ctype) in match match_with_equality_type t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels) l with_evars frzevars dep_proof_ok hdcncl | None -> Proofview.tclORELSE begin rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac end begin function | (e, info) -> let env' = push_rel_context rels env in let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) match match_with_equality_type t' with | Some (hdcncl,args) -> let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok hdcncl | None -> Proofview.tclZERO ~info e (* error "The provided term does not end with an equality or a declared rewrite relation." *) end end } let general_rewrite_ebindings = general_rewrite_ebindings_clause None let general_rewrite_bindings l2r occs frzevars dep_proof_ok ?tac (c,bl) = general_rewrite_ebindings_clause None l2r occs frzevars dep_proof_ok ?tac (c,bl) let general_rewrite l2r occs frzevars dep_proof_ok ?tac c = general_rewrite_bindings l2r occs frzevars dep_proof_ok ?tac (c,NoBindings) false let general_rewrite_ebindings_in l2r occs frzevars dep_proof_ok ?tac id = general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac let general_rewrite_bindings_in l2r occs frzevars dep_proof_ok ?tac id (c,bl) = general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac (c,bl) let general_rewrite_in l2r occs frzevars dep_proof_ok ?tac id c = general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac (c,NoBindings) let general_rewrite_clause l2r with_evars ?tac c cl = let occs_of = occurrences_map (List.fold_left (fun acc -> function ArgArg x -> x :: acc | ArgVar _ -> acc) []) in match cl.onhyps with | Some l -> (* If a precise list of locations is given, success is mandatory for each of these locations. *) let rec do_hyps = function | [] -> Proofview.tclUNIT () | ((occs,id),_) :: l -> tclTHENFIRST (general_rewrite_ebindings_in l2r (occs_of occs) false true ?tac id c with_evars) (do_hyps l) in if cl.concl_occs == NoOccurrences then do_hyps l else tclTHENFIRST (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) (do_hyps l) | None -> (* Otherwise, if we are told to rewrite in all hypothesis via the syntax "* |-", we fail iff all the different rewrites fail *) let rec do_hyps_atleastonce = function | [] -> tclZEROMSG (Pp.str"Nothing to rewrite.") | id :: l -> tclIFTHENTRYELSEMUST (general_rewrite_ebindings_in l2r AllOccurrences false true ?tac id c with_evars) (do_hyps_atleastonce l) in let do_hyps = (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) let ids gl = let ids_in_c = Environ.global_vars_set (Global.env()) (fst c) in let ids_of_hyps = pf_ids_of_hyps gl in Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps in Proofview.Goal.enter { enter = begin fun gl -> do_hyps_atleastonce (ids gl) end } in if cl.concl_occs == NoOccurrences then do_hyps else tclIFTHENTRYELSEMUST (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) do_hyps let apply_special_clear_request clear_flag f = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try let ((c, bl), sigma) = run_delayed env sigma f in apply_clear_request clear_flag (use_clear_hyp_by_default ()) c with e when catchable_exception e -> tclIDTAC end } let general_multi_rewrite with_evars l cl tac = let do1 l2r f = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (c, sigma) = run_delayed env sigma f in tclWITHHOLES with_evars (general_rewrite_clause l2r with_evars ?tac c cl) sigma end } in let rec doN l2r c = function | Precisely n when n <= 0 -> Proofview.tclUNIT () | Precisely 1 -> do1 l2r c | Precisely n -> tclTHENFIRST (do1 l2r c) (doN l2r c (Precisely (n-1))) | RepeatStar -> tclREPEAT_MAIN (do1 l2r c) | RepeatPlus -> tclTHENFIRST (do1 l2r c) (doN l2r c RepeatStar) | UpTo n when n<=0 -> Proofview.tclUNIT () | UpTo n -> tclTHENFIRST (tclTRY (do1 l2r c)) (doN l2r c (UpTo (n-1))) in let rec loop = function | [] -> Proofview.tclUNIT () | (l2r,m,clear_flag,c)::l -> tclTHENFIRST (tclTHEN (doN l2r c m) (apply_special_clear_request clear_flag c)) (loop l) in loop l let rewriteLR = general_rewrite true AllOccurrences true true let rewriteRL = general_rewrite false AllOccurrences true true (* Replacing tactics *) let classes_dirpath = DirPath.make (List.map Id.of_string ["Classes";"Coq"]) let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] let check_setoid cl = Option.fold_left ( List.fold_left (fun b ((occ,_),_) -> b||(Locusops.occurrences_map (fun x -> x) occ <> AllOccurrences) ) ) ((Locusops.occurrences_map (fun x -> x) cl.concl_occs <> AllOccurrences) && (Locusops.occurrences_map (fun x -> x) cl.concl_occs <> NoOccurrences)) cl.onhyps let replace_core clause l2r eq = if check_setoid clause then init_setoid (); tclTHENFIRST (assert_as false None None eq) (onLastHypId (fun id -> tclTHEN (tclTRY (general_rewrite_clause l2r false (mkVar id,NoBindings) clause)) (clear [id]))) (* eq,sym_eq : equality on Type and its symmetry theorem c1 c2 : c1 is to be replaced by c2 unsafe : If true, do not check that c1 and c2 are convertible tac : Used to prove the equality c1 = c2 gl : goal *) let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = let try_prove_eq = match try_prove_eq_opt with | None -> Proofview.tclUNIT () | Some tac -> tclCOMPLETE tac in Proofview.Goal.enter { enter = begin fun gl -> let get_type_of = pf_apply get_type_of gl in let t1 = get_type_of c1 and t2 = get_type_of c2 in let evd = if unsafe then Some (Tacmach.New.project gl) else try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Tacmach.New.project gl)) with Evarconv.UnableToUnify _ -> None in match evd with | None -> tclFAIL 0 (str"Terms do not have convertible types") | Some evd -> let e = build_coq_eq () in let sym = build_coq_eq_sym () in Tacticals.New.pf_constr_of_global sym (fun sym -> Tacticals.New.pf_constr_of_global e (fun e -> let eq = applist (e, [t1;c1;c2]) in tclTHENLAST (replace_core clause l2r eq) (tclFIRST [assumption; tclTHEN (apply sym) assumption; try_prove_eq ]))) end } let replace c1 c2 = replace_using_leibniz onConcl c2 c1 false false None let replace_by c1 c2 tac = replace_using_leibniz onConcl c2 c1 false false (Some tac) let replace_in_clause_maybe_by c1 c2 cl tac_opt = replace_using_leibniz cl c2 c1 false false tac_opt (* End of Eduardo's code. The rest of this file could be improved using the functions match_with_equation, etc that I defined in Pattern.ml. -- Eduardo (19/8/97) *) (* Tactics for equality reasoning with the "eq" relation. This code will work with any equivalence relation which is substitutive *) (* [find_positions t1 t2] will find the positions in the two terms which are suitable for discrimination, or for injection. Obviously, if there is a position which is suitable for discrimination, then we want to exploit it, and not bother with injection. So when we find a position which is suitable for discrimination, we will just raise an exception with that position. So the algorithm goes like this: if [t1] and [t2] start with the same constructor, then we can continue to try to find positions in the arguments of [t1] and [t2]. if [t1] and [t2] do not start with the same constructor, then we have found a discrimination position if one [t1] or [t2] do not start with a constructor and the two terms are not already convertible, then we have found an injection position. A discriminating position consists of a constructor-path and a pair of operators. The constructor-path tells us how to get down to the place where the two operators, which must differ, can be found. An injecting position has two terms instead of the two operators, since these terms are different, but not manifestly so. A constructor-path is a list of pairs of (operator * int), where the int (based at 0) tells us which argument of the operator we descended into. *) exception DiscrFound of (constructor * int) list * constructor * constructor let keep_proof_equalities_for_injection = ref false let _ = declare_bool_option { optsync = true; optdepr = false; optname = "injection on prop arguments"; optkey = ["Keep";"Proof";"Equalities"]; optread = (fun () -> !keep_proof_equalities_for_injection) ; optwrite = (fun b -> keep_proof_equalities_for_injection := b) } let find_positions env sigma t1 t2 = let project env sorts posn t1 t2 = let ty1 = get_type_of env sigma t1 in let s = get_sort_family_of env sigma ty1 in if Sorts.List.mem s sorts then [(List.rev posn,t1,t2)] else [] in let rec findrec sorts posn t1 t2 = let hd1,args1 = whd_all_stack env sigma t1 in let hd2,args2 = whd_all_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with | Construct (sp1,_), Construct (sp2,_) when Int.equal (List.length args1) (constructor_nallargs_env env sp1) -> let sorts' = Sorts.List.intersect sorts (allowed_sorts env (fst sp1)) in (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) if eq_constructor sp1 sp2 then let nrealargs = constructor_nrealargs_env env sp1 in let rargs1 = List.lastn nrealargs args1 in let rargs2 = List.lastn nrealargs args2 in List.flatten (List.map2_i (fun i -> findrec sorts' ((sp1,i)::posn)) 0 rargs1 rargs2) else if Sorts.List.mem InType sorts' then (* see build_discriminator *) raise (DiscrFound (List.rev posn,sp1,sp2)) else (* if we cannot eliminate to Type, we cannot discriminate but we may still try to project *) project env sorts posn (applist (hd1,args1)) (applist (hd2,args2)) | _ -> let t1_0 = applist (hd1,args1) and t2_0 = applist (hd2,args2) in if is_conv env sigma t1_0 t2_0 then [] else project env sorts posn t1_0 t2_0 in try let sorts = if !keep_proof_equalities_for_injection then [InSet;InType;InProp] else [InSet;InType] in Inr (findrec sorts [] t1 t2) with DiscrFound (path,c1,c2) -> Inl (path,c1,c2) let discriminable env sigma t1 t2 = match find_positions env sigma t1 t2 with | Inl _ -> true | _ -> false let injectable env sigma t1 t2 = match find_positions env sigma t1 t2 with | Inl _ | Inr [] | Inr [([],_,_)] -> false | Inr _ -> true (* Once we have found a position, we need to project down to it. If we are discriminating, then we need to produce False on one of the branches of the discriminator, and True on the other one. So the result type of the case-expressions is always Prop. If we are injecting, then we need to discover the result-type. This can be difficult, since the type of the two terms at the injection-position can be different, and we need to find a dependent sigma-type which generalizes them both. We can get an approximation to the right type to choose by: (0) Before beginning, we reserve a patvar for the default value of the match, to be used in all the bogus branches. (1) perform the case-splits, down to the site of the injection. At each step, we have a term which is the "head" of the next case-split. At the point when we actually reach the end of our path, the "head" is the term to return. We compute its type, and then, backwards, make a sigma-type with every free debruijn reference in that type. We can be finer, and first do a S(TRONG)NF on the type, so that we get the fewest number of references possible. (2) This gives us a closed type for the head, which we use for the types of all the case-splits. (3) Now, we can compute the type of one of T1, T2, and then unify it with the type of the last component of the result-type, and this will give us the bindings for the other arguments of the tuple. *) (* The algorithm, then is to perform successive case-splits. We have the result-type of the case-split, and also the type of that result-type. We have a "direction" we want to follow, i.e. a constructor-number, and in all other "directions", we want to juse use the default-value. After doing the case-split, we call the afterfun, with the updated environment, to produce the term for the desired "direction". The assumption is made here that the result-type is not manifestly functional, so we can just use the length of the branch-type to know how many lambda's to stick in. *) (* [descend_then env sigma head dirn] returns the number of products introduced, and the environment which is active, in the body of the case-branch given by [dirn], along with a continuation, which expects to be fed: (1) the value of the body of the branch given by [dirn] (2) the default-value (3) the type of the default-value, which must also be the type of the body of the [dirn] branch the continuation then constructs the case-split. *) let descend_then env sigma head dirn = let IndType (indf,_) = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in let indp,_ = (dest_ind_family indf) in let ind, _ = check_privacy env indp in let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in let dirn_nlams = cstr.(dirn-1).cs_nargs in let dirn_env = push_rel_context cstr.(dirn-1).cs_args env in (dirn_nlams, dirn_env, (fun dirnval (dfltval,resty) -> let deparsign = make_arity_signature env true indf in let p = it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in let build_branch i = let result = if Int.equal i dirn then dirnval else dfltval in it_mkLambda_or_LetIn_name env result cstr.(i-1).cs_args in let brl = List.map build_branch (List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in Inductiveops.make_case_or_project env indf ci p head (Array.of_list brl))) (* Now we need to construct the discriminator, given a discriminable position. This boils down to: (1) If the position is directly beneath us, then we need to do a case-split, with result-type Prop, and stick True and False into the branches, as is convenient. (2) If the position is not directly beneath us, then we need to call descend_then, to descend one step, and then recursively construct the discriminator. *) (* [construct_discriminator env sigma dirn c ind special default]] constructs a case-split on [c] of type [ind], with the [dirn]-th branch giving [special], and all the rest giving [default]. *) let build_selector env sigma dirn c ind special default = let IndType(indf,_) = try find_rectype env sigma ind with Not_found -> (* one can find Rel(k) in case of dependent constructors like T := c : (A:Set)A->T and a discrimination on (c bool true) = (c bool false) CP : changed assert false in a more informative error *) errorlabstrm "Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in let (indp,_) = dest_ind_family indf in let ind, _ = check_privacy env indp in let typ = Retyping.get_type_of env sigma default in let (mib,mip) = lookup_mind_specif env ind in let deparsign = make_arity_signature env true indf in let p = it_mkLambda_or_LetIn typ deparsign in let cstrs = get_constructors env indf in let build_branch i = let endpt = if Int.equal i dirn then special else default in it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in let brl = List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in mkCase (ci, p, c, Array.of_list brl) let rec build_discriminator env sigma dirn c = function | [] -> let ind = get_type_of env sigma c in let true_0,false_0 = build_coq_True(),build_coq_False() in build_selector env sigma dirn c ind true_0 false_0 | ((sp,cnum),argnum)::l -> let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in let subval = build_discriminator cnum_env sigma dirn newc l in kont subval (build_coq_False (),mkSort (Prop Null)) (* Note: discrimination could be more clever: if some elimination is not allowed because of a large impredicative constructor in the path (see allowed_sorts in find_positions), the positions could still be discrimated by projecting first instead of putting the discrimination combinator inside the projecting combinator. Example of relevant situation: Inductive t:Set := c : forall A:Set, A -> nat -> t. Goal ~ c _ 0 0 = c _ 0 1. intro. discriminate H. *) let gen_absurdity id = Proofview.Goal.enter { enter = begin fun gl -> let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in let hyp_typ = pf_nf_evar gl hyp_typ in if is_empty_type hyp_typ then simplest_elim (mkVar id) else tclZEROMSG (str "Not the negation of an equality.") end } (* Precondition: eq is leibniz equality returns ((eq_elim t t1 P i t2), absurd_term) where P=[e:t]discriminator absurd_term=False *) let ind_scheme_of_eq lbeq = let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in let kind = inductive_sort_family mip in (* use ind rather than case by compatibility *) let kind = if kind == InProp then Elimschemes.ind_scheme_kind_from_prop else Elimschemes.ind_scheme_kind_from_type in let c, eff = find_scheme kind (destIndRef lbeq.eq) in ConstRef c, eff let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = let i = build_coq_I () in let absurd_term = build_coq_False () in let eq_elim, eff = ind_scheme_of_eq lbeq in let sigma, eq_elim = Evd.fresh_global (Global.env ()) sigma eq_elim in sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), eff let eq_baseid = Id.of_string "e" let apply_on_clause (f,t) clause = let sigma = clause.evd in let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in let argmv = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in clenv_fchain ~with_univs:false argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in let discriminator = build_discriminator e_env sigma dirn (mkVar e) cpath in let sigma,(pf, absurd_term), eff = discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in let pf_ty = mkArrow eqn absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = Clenvtac.clenv_value_cast_meta absurd_clause in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS eff <*> tclTHENS (assert_after Anonymous absurd_term) [onLastHypId gen_absurdity; (Proofview.V82.tactic (Tacmach.refine pf))] let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in match find_positions env sigma t1 t2 with | Inr _ -> tclZEROMSG (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u eq_clause cpath dirn end } let onEquality with_evars tac (c,lbindc) = Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in let t = type_of c in let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in let eq_clause' = Clenvtac.clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in tclTHEN (Proofview.Unsafe.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') end } let onNegatedEquality with_evars tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in match kind_of_term (hnf_constr env sigma ccl) with | Prod (_,t,u) when is_empty_type u -> tclTHEN introf (onLastHypId (fun id -> onEquality with_evars tac (mkVar id,NoBindings))) | _ -> tclZEROMSG (str "Not a negated primitive equality.") end } let discrSimpleClause with_evars = function | None -> onNegatedEquality with_evars discrEq | Some id -> onEquality with_evars discrEq (mkVar id,NoBindings) let discr with_evars = onEquality with_evars discrEq let discrClause with_evars = onClause (discrSimpleClause with_evars) let discrEverywhere with_evars = (* tclORELSE *) (if discr_do_intro () then (tclTHEN (tclREPEAT introf) (tryAllHyps (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings))))) else (* <= 8.2 compat *) tryAllHypsAndConcl (discrSimpleClause with_evars)) (* (fun gls -> errorlabstrm "DiscrEverywhere" (str"No discriminable equalities.")) *) let discr_tac with_evars = function | None -> discrEverywhere with_evars | Some c -> onInductionArg (fun clear_flag -> discr with_evars) c let discrConcl = discrClause false onConcl let discrHyp id = discrClause false (onHyp id) (* returns the sigma type (sigS, sigT) with the respective constructor depending on the sort *) (* J.F.: correction du bug #1167 en accord avec Hugo. *) let find_sigma_data env s = build_sigma_type () (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser index bound in [rty] Then we build the term [(existT A P (mkRel lind) rterm)] of type [(sigS A P)] where [A] is the type of [mkRel lind] and [P] is [\na:A.rty{1/lind}] *) let make_tuple env sigma (rterm,rty) lind = assert (dependent (mkRel lind) rty); let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in let na = Context.Rel.Declaration.get_name (lookup_rel lind env) in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) let p = mkLambda (na, a, rty) in let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in sigma, (applist(exist_term,[a;p;(mkRel lind);rterm]), applist(sig_term,[a;p])) (* check that the free-references of the type of [c] are contained in the free-references of the normal-form of that type. Strictly computing the exact set of free rels would require full normalization but this is not reasonable (e.g. in presence of records that contains proofs). We restrict ourself to a "simpl" normalization *) let minimal_free_rels env sigma (c,cty) = let cty_rels = free_rels cty in let cty' = simpl env sigma cty in let rels' = free_rels cty' in if Int.Set.subset cty_rels rels' then (cty,cty_rels) else (cty',rels') (* Like the above, but recurse over all the rels found until there are no more rels to be found *) let minimal_free_rels_rec env sigma = let rec minimalrec_free_rels_rec prev_rels (c,cty) = let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in let combined_rels = Int.Set.union prev_rels direct_rels in let folder rels i = snd (minimalrec_free_rels_rec rels (c, unsafe_type_of env sigma (mkRel i))) in (cty, List.fold_left folder combined_rels (Int.Set.elements (Int.Set.diff direct_rels prev_rels))) in minimalrec_free_rels_rec Int.Set.empty (* [sig_clausal_form siglen ty] Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the type of ty), and return: (1) a pattern, with meta-variables in it for various arguments, which, when the metavariables are replaced with appropriate terms, will have type [ty] (2) an integer, which is the last argument - the one which we just returned. (3) a pattern, for the type of that last meta (4) a typing for each patvar WARNING: No checking is done to make sure that the sigS(or sigT)'s are actually there. - Only homogeneous pairs are built i.e. pairs where all the dependencies are of the same sort [sig_clausal_form] proceed as follows: the default tuple is constructed by taking the tuple-type, exploding the first [tuplen] [sigS]'s, and replacing at each step the binder in the right-hand-type by a fresh metavariable. In addition, on the way back out, we will construct the pattern for the tuple which uses these meta-vars. This gives us a pattern, which we use to match against the type of [dflt]; if that fails, then against the S(TRONG)NF of that type. If both fail, then we just cannot construct our tuple. If one of those succeed, then we can construct our value easily - we just use the tuple-pattern. *) let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let sigdata = find_sigma_data env sort_of_ty in let evdref = ref (Evd.clear_metas sigma) in let rec sigrec_clausal_form siglen p_i = if Int.equal siglen 0 then (* is the default value typable with the expected type *) let dflt_typ = unsafe_type_of env sigma dflt in try let () = evdref := Evarconv.the_conv_x_leq env dflt_typ p_i !evdref in let () = evdref := Evarconv.solve_unif_constraints_with_heuristics env !evdref in dflt with Evarconv.UnableToUnify _ -> error "Cannot solve a unification problem." else let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with | (_sigS,[a;p]) -> (a,p) | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type") in let ev = Evarutil.e_new_evar env evdref a in let rty = beta_applist(p_i_minus_1,[ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in match Evd.existential_opt_value !evdref (destEvar ev) with | Some w -> let w_type = unsafe_type_of env sigma w in if Evarconv.e_cumul env evdref w_type a then let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) else error "Cannot solve a unification problem." | None -> (* This at least happens if what has been detected as a dependency is not one; use an evasive error message; even if the problem is upwards: unification should be tried in the first place in make_iterated_tuple instead of approximatively computing the free rels; then unsolved evars would mean not binding rel *) error "Cannot solve a unification problem." in let scf = sigrec_clausal_form siglen ty in !evdref, Evarutil.nf_evar !evdref scf (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors (say [Ci(e1,Cj(e2,Ck(...,term,...),...),...)]), returns a given subterm of the term (say [term]). Let [typ] be the type of [term]. If [term] has no dependencies in the [e1], [e2], etc, then all is simple. If not, then we need to encapsulated the dependencies into a dependent tuple in such a way that the destructor has not a dependent type and rewriting can then be applied. The destructor has the form [e]Cases e of | ... | Ci (x1,x2,...) => Cases x2 of | ... | Cj (y1,y2,...) => Cases y2 of | ... | Ck (...,z,...) => z | ... end | ... end | ... end and the dependencies is expressed by the fact that [z] has a type dependent in the x1, y1, ... Assume [z] is typed as follows: env |- z:zty If [zty] has no dependencies, this is simple. Otherwise, assume [zty] has free (de Bruijn) variables in,...i1 then the role of [make_iterated_tuple env sigma (term,typ) (z,zty)] is to build the tuple [existT [xn]Pn Rel(in) .. (existT [x2]P2 Rel(i2) (existT [x1]P1 Rel(i1) z))] where P1 is zty[i1/x1], P2 is {x1 | P1[i2/x2]} etc. To do this, we find the free (relative) references of the strong NF of [z]'s type, gather them together in left-to-right order (i.e. highest-numbered is farthest-left), and construct a big iterated pair out of it. This only works when the references are all themselves to members of [Set]s, because we use [sigS] to construct the tuple. Suppose now that our constructed tuple is of length [tuplen]. We need also to construct a default value for the other branches of the destructor. As default value, we take a tuple of the form [existT [xn]Pn ?n (... existT [x2]P2 ?2 (existT [x1]P1 ?1 term))] but for this we have to solve the following unification problem: typ = zty[i1/?1;...;in/?n] This is done by [sig_clausal_form]. *) let make_iterated_tuple env sigma dflt (z,zty) = let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in let sort_of_zty = get_sort_of env sigma zty in let sorted_rels = Int.Set.elements rels in let sigma, (tuple,tuplety) = List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels in assert (closed0 tuplety); let n = List.length sorted_rels in let sigma, dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in sigma, (tuple,tuplety,dfltval) let rec build_injrec env sigma dflt c = function | [] -> make_iterated_tuple env sigma dflt (c,unsafe_type_of env sigma c) | ((sp,cnum),argnum)::l -> try let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in let sigma, (subval,tuplety,dfltval) = build_injrec cnum_env sigma dflt newc l in sigma, (kont subval (dfltval,tuplety), tuplety,dfltval) with UserError _ -> failwith "caught" let build_injector env sigma dflt c cpath = let sigma, (injcode,resty,_) = build_injrec env sigma dflt c cpath in sigma, (injcode,resty) (* let try_delta_expand env sigma t = let whdt = whd_all env sigma t in let rec hd_rec c = match kind_of_term c with | Construct _ -> whdt | App (f,_) -> hd_rec f | Cast (c,_,_) -> hd_rec c | _ -> t in hd_rec whdt *) let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) let inject_if_homogenous_dependent_pair ty = Proofview.Goal.nf_enter { enter = begin fun gl -> try let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in (* fetch the informations of the pair *) let ceq = Universes.constr_of_global Coqlib.glob_eq in let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in let existTconstr () = (Coqlib.build_sigma_type()).Coqlib.intro in (* check whether the equality deals with dep pairs or not *) let eqTypeDest = fst (decompose_app t) in if not (Globnames.is_global (sigTconstr()) eqTypeDest) then raise Exit; let hd1,ar1 = decompose_app_vect t1 and hd2,ar2 = decompose_app_vect t2 in if not (Globnames.is_global (existTconstr()) hd1) then raise Exit; if not (Globnames.is_global (existTconstr()) hd2) then raise Exit; let ind,_ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in (* check if the user has declared the dec principle *) (* and compare the fst arguments of the dep pair *) (* Note: should work even if not an inductive type, but the table only *) (* knows inductive types *) if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) && pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; Coqlib.check_required_library ["Coq";"Logic";"Eqdep_dec"]; let new_eq_args = [|pf_unsafe_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in let c, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in (* cut with the good equality and prove the requested goal *) tclTHENLIST [Proofview.tclEFFECTS eff; intro; onLastHyp (fun hyp -> tclTHENS (cut (mkApp (ceq,new_eq_args))) [clear [destVar hyp]; Proofview.V82.tactic (Tacmach.refine (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|]))) ])] with Exit -> Proofview.tclUNIT () end } (* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it expands then only when the whdnf has a constructor of an inductive type in hd position, otherwise delta expansion is not done *) let simplify_args env sigma t = (* Quick hack to reduce in arguments of eq only *) match decompose_app t with | eq, [t;c1;c2] -> applist (eq,[t;simpl env sigma c1;simpl env sigma c2]) | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2]) | _ -> t let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (LocalAssum (e,t)) env in let evdref = ref sigma in let filter (cpath, t1', t2') = try (* arbitrarily take t1' as the injector default value *) let sigma, (injbody,resty) = build_injector e_env !evdref t1' (mkVar e) cpath in let injfun = mkNamedLambda e t injbody in let sigma,congr = Evd.fresh_global env sigma eq.congr in let pf = applist(congr,[t;resty;injfun;t1;t2]) in let sigma, pf_typ = Typing.type_of env sigma pf in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = Clenvtac.clenv_value_cast_meta inj_clause in let ty = simplify_args env sigma (clenv_type inj_clause) in evdref := sigma; Some (pf, ty) with Failure _ -> None in let injectors = List.map_filter filter posns in if List.is_empty injectors then tclZEROMSG (str "Failed to decompose the equality.") else Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Tacticals.New.tclTHENFIRST (Proofview.tclIGNORE (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [inject_if_homogenous_dependent_pair ty; Proofview.V82.tactic (Tacmach.refine pf)]) (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in let env = eq_clause.env in match find_positions env sigma t1 t2 with | Inl _ -> tclZEROMSG (strbrk"This equality is discriminable. You should use the discriminate tactic to solve the goal.") | Inr [] -> let suggestion = if !keep_proof_equalities_for_injection then "" else " You can try to use option Set Keep Proof Equalities." in tclZEROMSG (strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)) | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 -> tclZEROMSG (str"Nothing to inject.") | Inr posns -> inject_at_positions env sigma l2r u eq_clause posns (tac (clenv_value eq_clause)) let get_previous_hyp_position id gl = let rec aux dest = function | [] -> raise (RefinerError (NoSuchHyp id)) | d :: right -> let hyp = Context.Named.Declaration.get_id d in if Id.equal hyp id then dest else aux (MoveAfter hyp) right in aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let injEq ?(old=false) with_evars clear_flag ipats = (* Decide which compatibility mode to use *) let ipats_style, l2r, dft_clear_flag, bounded_intro = match ipats with | None when not old && use_injection_in_context () -> Some [], true, true, true | None -> None, false, false, false | _ -> let b = use_injection_pattern_l2r_order () in ipats, b, b, b in (* Built the post tactic depending on compatibility mode *) let post_tac c n = match ipats_style with | Some ipats -> Proofview.Goal.enter { enter = begin fun gl -> let destopt = match kind_of_term c with | Var id -> get_previous_hyp_position id gl | _ -> MoveLast in let clear_tac = tclTRY (apply_clear_request clear_flag dft_clear_flag c) in (* Try should be removal if dependency were treated *) let intro_tac = if bounded_intro then intro_patterns_bound_to with_evars n destopt ipats else intro_patterns_to with_evars destopt ipats in tclTHEN clear_tac intro_tac end } | None -> tclIDTAC in injEqThen post_tac l2r let inj ipats with_evars clear_flag = onEquality with_evars (injEq with_evars clear_flag ipats) let injClause ipats with_evars = function | None -> onNegatedEquality with_evars (injEq with_evars None ipats) | Some c -> onInductionArg (inj ipats with_evars) c let simpleInjClause with_evars = function | None -> onNegatedEquality with_evars (injEq ~old:true with_evars None None) | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (injEq ~old:true with_evars clear_flag None)) c let injConcl = injClause None false None let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.ghost,id))) let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = clause.evd in let env = Proofview.Goal.env gl in match find_positions env sigma t1 t2 with | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u clause cpath dirn | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) ntac (clenv_value clause) 0 | Inr posns -> inject_at_positions env sigma true u clause posns (ntac (clenv_value clause)) end } let dEqThen with_evars ntac = function | None -> onNegatedEquality with_evars (decompEqThen (ntac None)) | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (decompEqThen (ntac clear_flag))) c let dEq with_evars = dEqThen with_evars (fun clear_flag c x -> (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) let intro_decomp_eq tac data cl = Proofview.Goal.enter { enter = begin fun gl -> let cl = pf_apply make_clenv_binding gl cl NoBindings in decompEqThen (fun _ -> tac) data cl end } let _ = declare_intro_decomp_eq intro_decomp_eq (* [subst_tuple_term dep_pair B] Given that dep_pair looks like: (existT e1 (existT e2 ... (existT en en+1) ... )) of type {x1:T1 & {x2:T2(x1) & ... {xn:Tn(x1..xn-1) & en+1 } } } and B might contain instances of the ei, we will return the term: ([x1:ty1]...[xn+1:tyn+1]B (projT1 (mkRel 1)) (projT1 (projT2 (mkRel 1))) ... (projT1 (projT2^n (mkRel 1))) (projT2 (projT2^n (mkRel 1))) That is, we will abstract out the terms e1...en+1 of types t1 (=_beta T1), ..., tn+1 (=_beta Tn+1(e1..en)) as usual, but will then produce a term in which the abstraction is on a single term - the debruijn index [mkRel 1], which will be of the same type as dep_pair (note that the abstracted body may not be typable!). ALGORITHM for abstraction: We have a list of terms, [e1]...[en+1], which we want to abstract out of [B]. For each term [ei], going backwards from [n+1], we just do a [subst_term], and then do a lambda-abstraction to the type of the [ei]. *) let decomp_tuple_term env c t = let rec decomprec inner_code ex exty = let iterated_decomp = try let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose ex in let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in let cdrtyp = beta_applist (p,[car]) in List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) with Constr_matching.PatternMatchingFailure -> [] in [((ex,exty),inner_code)]::iterated_decomp in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let sigma = Sigma.to_evar_map sigma in let typ = get_type_of env sigma dep_pair1 in (* We find all possible decompositions *) let decomps1 = decomp_tuple_term env dep_pair1 typ in let decomps2 = decomp_tuple_term env dep_pair2 typ in (* We adjust to the shortest decomposition *) let n = min (List.length decomps1) (List.length decomps2) in let decomp1 = List.nth decomps1 (n-1) in let decomp2 = List.nth decomps2 (n-1) in (* We rewrite dep_pair1 ... *) let e1_list,proj_list = List.split decomp1 in (* ... and use dep_pair2 to compute the expected goal *) let e2_list,_ = List.split decomp2 in (* We build the expected goal *) let abst_B = List.fold_right (fun (e,t) body -> lambda_create env (t,subst_term e body)) e1_list b in let pred_body = beta_applist(abst_B,proj_list) in let body = mkApp (lambda_create env (typ,pred_body),[|dep_pair1|]) in let expected_goal = beta_applist (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota sigma expected_goal in (* Retype to get universes right *) let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in let sigma, _ = Typing.type_of env sigma body in Sigma.Unsafe.of_pair ((body, expected_goal), sigma) (* Like "replace" but decompose dependent equalities *) (* i.e. if equality is "exists t v = exists u w", and goal is "phi(t,u)", *) (* then it uses the predicate "\x.phi(proj1_sig x,proj2_sig x)", and so *) (* on for further iterated sigma-tuples *) let cutSubstInConcl l2r eqn = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in let tac = tclTHENFIRST (tclTHENLIST [ (change_concl typ); (* Put in pattern form *) (replace_core onConcl l2r eqn) ]) (change_concl expected) (* Put in normalized form *) in Sigma (tac, sigma, p) end } let cutSubstInHyp l2r eqn id = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_get_hyp_typ id gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in let tac = tclTHENFIRST (tclTHENLIST [ (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly)); (replace_core (onHyp id) l2r eqn) ]) (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly)) in Sigma (tac, sigma, p) end } let try_rewrite tac = Proofview.tclORELSE tac begin function (e, info) -> match e with | Constr_matching.PatternMatchingFailure -> tclZEROMSG (str "Not a primitive equality here.") | e when catchable_exception e -> tclZEROMSG (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") | e -> Proofview.tclZERO ~info e end let cutSubstClause l2r eqn cls = match cls with | None -> cutSubstInConcl l2r eqn | Some id -> cutSubstInHyp l2r eqn id let cutRewriteClause l2r eqn cls = try_rewrite (cutSubstClause l2r eqn cls) let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None let substClause l2r c cls = Proofview.Goal.enter { enter = begin fun gl -> let eq = pf_apply get_type_of gl c in tclTHENS (cutSubstClause l2r eq cls) [Proofview.tclUNIT (); exact_no_check c] end } let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls) let rewriteInHyp l2r c id = rewriteClause l2r c (Some id) let rewriteInConcl l2r c = rewriteClause l2r c None (* Naming scheme for rewrite and cutrewrite tactics give equality give proof of equality / cutSubstClause substClause raw | cutSubstInHyp substInHyp \ cutSubstInConcl substInConcl / cutRewriteClause rewriteClause user| cutRewriteInHyp rewriteInHyp \ cutRewriteInConcl rewriteInConcl raw = raise typing error or PatternMatchingFailure user = raise user error specific to rewrite *) (**********************************************************************) (* Substitutions tactics (JCF) *) let regular_subst_tactic = ref true let _ = declare_bool_option { optsync = true; optdepr = false; optname = "more regular behavior of tactic subst"; optkey = ["Regular";"Subst";"Tactic"]; optread = (fun () -> !regular_subst_tactic); optwrite = (:=) regular_subst_tactic } let restrict_to_eq_and_identity eq = (* compatibility *) if not (is_global glob_eq eq) && not (is_global glob_identity eq) then raise Constr_matching.PatternMatchingFailure exception FoundHyp of (Id.t * constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occurring in [t] *) let is_eq_x gl x d = let id = get_id d in try let is_var id c = match kind_of_term c with | Var id' -> Id.equal id id' | _ -> false in let c = pf_nf_evar gl (get_type d) in let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in if (is_var x lhs) && not (local_occur_var x rhs) then raise (FoundHyp (id,rhs,true)); if (is_var x rhs) && not (local_occur_var x lhs) then raise (FoundHyp (id,lhs,false)) with Constr_matching.PatternMatchingFailure -> () (* Rewrite "hyp:x=rhs" or "hyp:rhs=x" (if dir=false) everywhere and erase hyp and x; proceed by generalizing all dep hyps *) let subst_one dep_proof_ok x (hyp,rhs,dir) = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in (* The set of hypotheses using x *) let dephyps = List.rev (pi3 (List.fold_right (fun dcl (dest,deps,allhyps) -> let id = get_id dcl in if not (Id.equal id hyp) && List.exists (fun y -> occur_var_in_decl env y dcl) deps then let id_dest = if !regular_subst_tactic then dest else MoveLast in (dest,id::deps,(id_dest,id)::allhyps) else (MoveBefore id,deps,allhyps)) hyps (MoveBefore x,[x],[]))) in (* In practice, no dep hyps before x, so MoveBefore x is good enough *) (* Decides if x appears in conclusion *) let depconcl = occur_var env x concl in let need_rewrite = not (List.is_empty dephyps) || depconcl in tclTHENLIST ((if need_rewrite then [revert (List.map snd dephyps); general_rewrite dir AllOccurrences true dep_proof_ok (mkVar hyp); (tclMAP (fun (dest,id) -> intro_move (Some id) dest) dephyps)] else [Proofview.tclUNIT ()]) @ [tclTRY (clear [x; hyp])]) end } (* Look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *) let subst_one_var dep_proof_ok x = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let xval = pf_get_hyp x gl |> get_value in (* If x has a body, simply replace x with body and clear x *) if not (Option.is_empty xval) then tclTHEN (unfold_body x) (clear [x]) else (* Find a non-recursive definition for x *) let res = try (** [is_eq_x] ensures nf_evar on its side *) let hyps = Proofview.Goal.hyps gl in let test hyp _ = is_eq_x gl x hyp in Context.Named.fold_outside test ~init:() hyps; errorlabstrm "Subst" (str "Cannot find any non-recursive equality over " ++ pr_id x ++ str".") with FoundHyp res -> res in subst_one dep_proof_ok x res end } let subst_gen dep_proof_ok ids = tclMAP (subst_one_var dep_proof_ok) ids (* For every x, look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *) let subst = subst_gen true type subst_tactic_flags = { only_leibniz : bool; rewrite_dependent_proof : bool } let default_subst_tactic_flags () = if Flags.version_strictly_greater Flags.V8_2 then { only_leibniz = false; rewrite_dependent_proof = true } else { only_leibniz = true; rewrite_dependent_proof = false } let subst_all ?(flags=default_subst_tactic_flags ()) () = if !regular_subst_tactic then (* First step: find hypotheses to treat in linear time *) let find_equations gl = let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in let select_equation_name decl = try let lbeq,u,(_,x,y) = find_eq_data_decompose (get_type decl) in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match kind_of_term x, kind_of_term y with | Var z, _ when not (is_evaluable env (EvalVarRef z)) -> Some (get_id decl) | _, Var z when not (is_evaluable env (EvalVarRef z)) -> Some (get_id decl) | _ -> None with Constr_matching.PatternMatchingFailure -> None in let hyps = Proofview.Goal.hyps gl in List.rev (List.map_filter select_equation_name hyps) in (* Second step: treat equations *) let process hyp = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in let c = pf_get_hyp hyp gl |> get_type in let _,_,(_,x,y) = find_eq_data_decompose c in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then Proofview.tclUNIT () else match kind_of_term x, kind_of_term y with | Var x', _ when not (occur_term x y) && not (is_evaluable env (EvalVarRef x')) -> subst_one flags.rewrite_dependent_proof x' (hyp,y,true) | _, Var y' when not (occur_term y x) && not (is_evaluable env (EvalVarRef y')) -> subst_one flags.rewrite_dependent_proof y' (hyp,x,false) | _ -> Proofview.tclUNIT () end } in Proofview.Goal.nf_enter { enter = begin fun gl -> let ids = find_equations gl in tclMAP process ids end } else (* Old implementation, not able to manage configurations like a=b, a=t, or situations like "a = S b, b = S a", or also accidentally unfolding let-ins *) Proofview.Goal.nf_enter { enter = begin fun gl -> let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = try let lbeq,u,(_,x,y) = find_eq_data_decompose c in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then failwith "caught"; match kind_of_term x with Var x -> x | _ -> match kind_of_term y with Var y -> y | _ -> failwith "caught" with Constr_matching.PatternMatchingFailure -> failwith "caught" in let test p = try Some (test p) with Failure _ -> None in let hyps = pf_hyps_types gl in let ids = List.map_filter test hyps in let ids = List.uniquize ids in subst_gen flags.rewrite_dependent_proof ids end } (* Rewrite the first assumption for which a condition holds and gives the direction of the rewrite *) let cond_eq_term_left c t gl = try let (_,x,_) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term_right c t gl = try let (_,_,x) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then false else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term c t gl = try let (_,x,y) = pi3 (find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else if pf_conv_x gl c y then false else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let rewrite_assumption_cond cond_eq_term cl = let rec arec hyps gl = match hyps with | [] -> error "No such assumption." | hyp ::rest -> let id = get_id hyp in begin try let dir = cond_eq_term (get_type hyp) gl in general_rewrite_clause dir false (mkVar id,NoBindings) cl with | Failure _ | UserError _ -> arec rest gl end in Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Proofview.Goal.lift gl Sigma.Unsafe.le in let hyps = Proofview.Goal.hyps gl in arec hyps gl end } (* Generalize "subst x" to substitution of subterm appearing as an equation in the context, but not clearing the hypothesis *) let replace_term dir_opt c = let cond_eq_fun = match dir_opt with | None -> cond_eq_term c | Some true -> cond_eq_term_left c | Some false -> cond_eq_term_right c in rewrite_assumption_cond cond_eq_fun (* Declare rewriting tactic for intro patterns "<-" and "->" *) let _ = let gmr l2r with_evars tac c = general_rewrite_clause l2r with_evars tac c in Hook.set Tactics.general_rewrite_clause gmr let _ = Hook.set Tactics.subst_one subst_one coq-8.6/tactics/elimschemes.ml0000644000175000017500000001422613022274260015422 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) let rect_scheme_kind_from_prop = declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop" (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) let rect_dep_scheme_kind_from_type = declare_individual_scheme_object "_rect" ~aux:"_rect_from_type" (fun _ x -> build_induction_scheme_in_type true InType x, Safe_typing.empty_private_constants) let ind_scheme_kind_from_type = declare_individual_scheme_object "_ind_nodep" (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InProp) let ind_scheme_kind_from_prop = declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop" (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InProp) let ind_dep_scheme_kind_from_type = declare_individual_scheme_object "_ind" ~aux:"_ind_from_type" (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InProp) let rec_scheme_kind_from_prop = declare_individual_scheme_object "_rec" ~aux:"_rec_from_prop" (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InSet) let rec_scheme_kind_from_type = declare_individual_scheme_object "_rec_nodep" ~aux:"_rec_nodep_from_type" (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InSet) let rec_dep_scheme_kind_from_type = declare_individual_scheme_object "_rec" ~aux:"_rec_from_type" (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InSet) (* Case analysis *) let build_case_analysis_scheme_in_type dep sort ind = let env = Global.env () in let sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep sort in c, Evd.evar_universe_context (Sigma.to_evar_map sigma) let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) let case_scheme_kind_from_prop = declare_individual_scheme_object "_case" ~aux:"_case_from_prop" (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_type = declare_individual_scheme_object "_case" ~aux:"_case_from_type" (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_type_in_prop = declare_individual_scheme_object "_casep_dep" (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_prop = declare_individual_scheme_object "_case_dep" (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_prop_in_prop = declare_individual_scheme_object "_casep" (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) coq-8.6/tactics/elimschemes.mli0000644000175000017500000000272113022274260015570 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* std_ppcmds = function | DRel -> str "*" | DSort -> str "Sort" | DRef _ -> str "Ref" | DCtx (ctx,t) -> f ctx ++ spc() ++ str "|-" ++ spc () ++ f t | DLambda (t1,t2) -> str "fun"++ spc() ++ f t1 ++ spc() ++ str"->" ++ spc() ++ f t2 | DApp (t1,t2) -> f t1 ++ spc() ++ f t2 | DCase (_,t1,t2,ta) -> str "case" | DFix _ -> str "fix" | DCoFix _ -> str "cofix" | DCons ((t,dopt),tl) -> f t ++ (match dopt with Some t' -> str ":=" ++ f t' | None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl | DNil -> str "[]" (* * Functional iterators for the t datatype * a.k.a boring and error-prone boilerplate code *) let map f = function | (DRel | DSort | DNil | DRef _) as c -> c | DCtx (ctx,c) -> DCtx (f ctx, f c) | DLambda (t,c) -> DLambda (f t, f c) | DApp (t,u) -> DApp (f t,f u) | DCase (ci,p,c,bl) -> DCase (ci, f p, f c, Array.map f bl) | DFix (ia,i,ta,ca) -> DFix (ia,i,Array.map f ta,Array.map f ca) | DCoFix(i,ta,ca) -> DCoFix (i,Array.map f ta,Array.map f ca) | DCons ((t,topt),u) -> DCons ((f t,Option.map f topt), f u) let compare_ci ci1 ci2 = let c = ind_ord ci1.ci_ind ci2.ci_ind in if c = 0 then let c = Int.compare ci1.ci_npar ci2.ci_npar in if c = 0 then let c = Array.compare Int.compare ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls in if c = 0 then Array.compare Int.compare ci1.ci_cstr_nargs ci2.ci_cstr_nargs else c else c else c let compare cmp t1 t2 = match t1, t2 with | DRel, DRel -> 0 | DSort, DSort -> 0 | DRef gr1, DRef gr2 -> RefOrdered.compare gr1 gr2 | DCtx (tl1, tr1), DCtx (tl2, tr2) | DLambda (tl1, tr1), DLambda (tl2, tr2) | DApp (tl1, tr1), DApp (tl2, tr2) -> let c = cmp tl1 tl2 in if c = 0 then cmp tr1 tr2 else c | DCase (ci1, c1, t1, p1), DCase (ci2, c2, t2, p2) -> let c = cmp c1 c2 in if c = 0 then let c = cmp t1 t2 in if c = 0 then let c = Array.compare cmp p1 p2 in if c = 0 then compare_ci ci1 ci2 else c else c else c | DFix (i1, j1, tl1, pl1), DFix (i2, j2, tl2, pl2) -> let c = Int.compare j1 j2 in if c = 0 then let c = Array.compare Int.compare i1 i2 in if c = 0 then let c = Array.compare cmp tl1 tl2 in if c = 0 then Array.compare cmp pl1 pl2 else c else c else c | DCoFix (i1, tl1, pl1), DCoFix (i2, tl2, pl2) -> let c = Int.compare i1 i2 in if c = 0 then let c = Array.compare cmp tl1 tl2 in if c = 0 then Array.compare cmp pl1 pl2 else c else c | _ -> Pervasives.compare t1 t2 (** OK **) let fold f acc = function | (DRel | DNil | DSort | DRef _) -> acc | DCtx (ctx,c) -> f (f acc ctx) c | DLambda (t,c) -> f (f acc t) c | DApp (t,u) -> f (f acc t) u | DCase (ci,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | DFix (ia,i,ta,ca) -> Array.fold_left f (Array.fold_left f acc ta) ca | DCoFix(i,ta,ca) -> Array.fold_left f (Array.fold_left f acc ta) ca | DCons ((t,topt),u) -> f (Option.fold_left f (f acc t) topt) u let choose f = function | (DRel | DSort | DNil | DRef _) -> invalid_arg "choose" | DCtx (ctx,c) -> f ctx | DLambda (t,c) -> f t | DApp (t,u) -> f u | DCase (ci,p,c,bl) -> f c | DFix (ia,i,ta,ca) -> f ta.(0) | DCoFix (i,ta,ca) -> f ta.(0) | DCons ((t,topt),u) -> f u let dummy_cmp () () = 0 let fold2 (f:'a -> 'b -> 'c -> 'a) (acc:'a) (c1:'b t) (c2:'c t) : 'a = let head w = map (fun _ -> ()) w in if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0) then invalid_arg "fold2:compare" else match c1,c2 with | (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _) -> acc | (DCtx (c1,t1), DCtx (c2,t2) | DApp (c1,t1), DApp (c2,t2) | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2 | DCase (ci,p1,c1,bl1),DCase (_,p2,c2,bl2) -> Array.fold_left2 f (f (f acc p1 p2) c1 c2) bl1 bl2 | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 | DCoFix(i,ta1,ca1), DCoFix(_,ta2,ca2) -> Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2 | _ -> assert false let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t = let head w = map (fun _ -> ()) w in if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0) then invalid_arg "map2_t:compare" else match c1,c2 with | (DRel, DRel | DSort, DSort | DNil, DNil | DRef _, DRef _) as cc -> let (c,_) = cc in c | DCtx (c1,t1), DCtx (c2,t2) -> DCtx (f c1 c2, f t1 t2) | DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2) | DApp (t1,u1), DApp (t2,u2) -> DApp (f t1 t2,f u1 u2) | DCase (ci,p1,c1,bl1), DCase (_,p2,c2,bl2) -> DCase (ci, f p1 p2, f c1 c2, Array.map2 f bl1 bl2) | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> DFix (ia,i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) | DCoFix (i,ta1,ca1), DCoFix (_,ta2,ca2) -> DCoFix (i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2) | _ -> assert false let terminal = function | (DRel | DSort | DNil | DRef _) -> true | _ -> false let compare t1 t2 = compare dummy_cmp t1 t2 end (* * Terms discrimination nets * Uses the general dnet datatype on DTerm.t * (here you can restart reading) *) (* * Construction of the module *) module type IDENT = sig type t val compare : t -> t -> int val subst : substitution -> t -> t val constr_of : t -> constr end module type OPT = sig val reduce : constr -> constr val direction : bool end module Make = functor (Ident : IDENT) -> functor (Opt : OPT) -> struct module TDnet : Dnet.S with type ident=Ident.t and type 'a structure = 'a DTerm.t and type meta = int = Dnet.Make(DTerm)(Ident)(Int) type t = TDnet.t type ident = TDnet.ident (** We will freshen metas on the fly, to cope with the implementation defect of Term_dnet which requires metas to be all distinct. *) let fresh_meta = let index = ref 0 in fun () -> let ans = !index in let () = index := succ ans in ans open DTerm open TDnet let pat_of_constr c : term_pattern = (** To each evar we associate a unique identifier. *) let metas = ref Evar.Map.empty in let rec pat_of_constr c = match kind_of_term c with | Rel _ -> Term DRel | Sort _ -> Term DSort | Var i -> Term (DRef (VarRef i)) | Const (c,u) -> Term (DRef (ConstRef c)) | Ind (i,u) -> Term (DRef (IndRef i)) | Construct (c,u)-> Term (DRef (ConstructRef c)) | Term.Meta _ -> assert false | Evar (i,_) -> let meta = try Evar.Map.find i !metas with Not_found -> let meta = fresh_meta () in let () = metas := Evar.Map.add i meta !metas in meta in Meta meta | Case (ci,c1,c2,ca) -> Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca)) | Fix ((ia,i),(_,ta,ca)) -> Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca)) | CoFix (i,(_,ta,ca)) -> Term(DCoFix(i,Array.map pat_of_constr ta,Array.map pat_of_constr ca)) | Cast (c,_,_) -> pat_of_constr c | Lambda (_,t,c) -> Term(DLambda (pat_of_constr t, pat_of_constr c)) | (Prod (_,_,_) | LetIn(_,_,_,_)) -> let (ctx,c) = ctx_of_constr (Term DNil) c in Term (DCtx (ctx,c)) | App (f,ca) -> Array.fold_left (fun c a -> Term (DApp (c,a))) (pat_of_constr f) (Array.map pat_of_constr ca) | Proj (p,c) -> Term (DApp (Term (DRef (ConstRef (Projection.constant p))), pat_of_constr c)) and ctx_of_constr ctx c = match kind_of_term c with | Prod (_,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c | LetIn(_,d,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t, Some (pat_of_constr d)),ctx))) c | _ -> ctx,pat_of_constr c in pat_of_constr c let empty_ctx : term_pattern -> term_pattern = function | Meta _ as c -> c | Term (DCtx(_,_)) as c -> c | c -> Term (DCtx (Term DNil, c)) (* * Basic primitives *) let empty = TDnet.empty let subst s t = let sleaf id = Ident.subst s id in let snode = function | DTerm.DRef gr -> DTerm.DRef (fst (subst_global s gr)) | n -> n in TDnet.map sleaf snode t let union = TDnet.union let add (c:constr) (id:Ident.t) (dn:t) = let c = Opt.reduce c in let c = empty_ctx (pat_of_constr c) in TDnet.add dn c id let new_meta () = Meta (fresh_meta ()) let rec remove_cap : term_pattern -> term_pattern = function | Term (DCons (t,u)) -> Term (DCons (t,remove_cap u)) | Term DNil -> new_meta() | Meta _ as m -> m | _ -> assert false let under_prod : term_pattern -> term_pattern = function | Term (DCtx (t,u)) -> Term (DCtx (remove_cap t,u)) | Meta m -> Term (DCtx(new_meta(), Meta m)) | _ -> assert false (* debug *) (* let rec pr_term_pattern p = (fun pr_t -> function | Term t -> pr_t t | Meta m -> str"["++Pp.int (Obj.magic m)++str"]" ) (pr_dconstr pr_term_pattern) p*) let search_pat cpat dpat dn = let whole_c = cpat in (* if we are at the root, add an empty context *) let dpat = under_prod (empty_ctx dpat) in TDnet.Idset.fold (fun id acc -> let c_id = Opt.reduce (Ident.constr_of id) in let (ctx,wc) = try Termops.align_prod_letin whole_c c_id with Invalid_argument _ -> [],c_id in let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in try let _ = Termops.filtering ctx Reduction.CUMUL wc whole_c in id :: acc with Termops.CannotFilter -> (* msgnl(str"recon "++Termops.print_constr_env (Global.env()) wc); *) acc ) (TDnet.find_match dpat dn) [] (* * High-level primitives describing specific search problems *) let search_pattern dn pat = let pat = Opt.reduce pat in search_pat pat (empty_ctx (pat_of_constr pat)) dn let find_all dn = Idset.elements (TDnet.find_all dn) let map f dn = TDnet.map f (fun x -> x) dn let refresh_metas dn = let new_metas = ref Int.Map.empty in let refresh_one_meta i = try Int.Map.find i !new_metas with Not_found -> let new_meta = fresh_meta () in let () = new_metas := Int.Map.add i new_meta !new_metas in new_meta in TDnet.map_metas refresh_one_meta dn end module type S = sig type t type ident val empty : t val add : constr -> ident -> t -> t val union : t -> t -> t val subst : substitution -> t -> t val search_pattern : t -> constr -> ident list val find_all : t -> ident list val map : (ident -> ident) -> t -> t val refresh_metas : t -> t end coq-8.6/tactics/elim.mli0000644000175000017500000000204113022274260014213 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (Tacexpr.intro_patterns -> branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic val h_decompose : inductive list -> constr -> unit Proofview.tactic val h_decompose_or : constr -> unit Proofview.tactic val h_decompose_and : constr -> unit Proofview.tactic val h_double_induction : quantified_hypothesis -> quantified_hypothesis-> unit Proofview.tactic coq-8.6/tactics/autorewrite.ml0000644000175000017500000002673713022274260015510 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* errorlabstrm "AutoRewrite" (str "Rewriting base " ++ str bas ++ str " does not exist.") let find_rewrites bas = List.rev_map snd (HintDN.find_all (find_base bas)) let find_matches bas pat = let base = find_base bas in let res = HintDN.search_pattern base pat in List.map snd res let print_rewrite_hintdb bas = (str "Database " ++ str bas ++ fnl () ++ prlist_with_sep fnl (fun h -> str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ Option.cata (fun tac -> str " then use tactic " ++ Pptactic.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in let try_rewrite dir ctx c tc = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c in let sigma = Sigma.to_evar_map sigma in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in let tac = general_rewrite_maybe_in dir c' tc in Sigma.Unsafe.of_pair (tac, sigma) end } in let lrul = List.map (fun h -> let tac = match h.rew_tac with | None -> Proofview.tclUNIT () | Some (Genarg.GenArg (Genarg.Glbwit wit, tac)) -> let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) in (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> Tacticals.New.tclTHEN tac (Tacticals.New.tclREPEAT_MAIN (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) (Proofview.tclUNIT()) lrul)) (* The AutoRewrite tactic *) let autorewrite ?(conds=Naive) tac_main lbas = Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac bas -> Tacticals.New.tclTHEN tac (one_base (fun dir c tac -> let tac = (tac, conds) in general_rewrite dir AllOccurrences true false ~tac c) tac_main bas)) (Proofview.tclUNIT()) lbas)) let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = Proofview.Goal.nf_enter { enter = begin fun gl -> (* let's check at once if id exists (to raise the appropriate error) *) let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in let general_rewrite_in id = let id = ref id in let to_be_cleared = ref false in fun dir cstr tac gl -> let last_hyp_id = match Tacmach.pf_hyps gl with d :: _ -> Context.Named.Declaration.get_id d | _ -> (* even the hypothesis id is missing *) raise (Logic.RefinerError (Logic.NoSuchHyp !id)) in let gl' = Proofview.V82.of_tactic (general_rewrite_in dir AllOccurrences true ~tac:(tac, conds) false !id cstr false) gl in let gls = gl'.Evd.it in match gls with g::_ -> (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with d ::_ -> let lastid = Context.Named.Declaration.get_id d in if not (Id.equal last_hyp_id lastid) then begin let gl'' = if !to_be_cleared then tclTHEN (fun _ -> gl') (tclTRY (Proofview.V82.of_tactic (clear [!id]))) gl else gl' in id := lastid ; to_be_cleared := true ; gl'' end else begin to_be_cleared := false ; gl' end | _ -> assert false) (* there must be at least an hypothesis *) | _ -> assert false (* rewriting cannot complete a proof *) in let general_rewrite_in x y z w = Proofview.V82.tactic (general_rewrite_in x y z w) in Tacticals.New.tclMAP (fun id -> Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac bas -> Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas))) idl end } let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] let gen_auto_multi_rewrite conds tac_main lbas cl = let try_do_hyps treat_id l = autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas in if cl.concl_occs != AllOccurrences && cl.concl_occs != NoOccurrences then Tacticals.New.tclZEROMSG (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") else let compose_tac t1 t2 = match cl.onhyps with | Some [] -> t1 | _ -> Tacticals.New.tclTHENFIRST t1 t2 in compose_tac (if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ()) (match cl.onhyps with | Some l -> try_do_hyps (fun ((_,id),_) -> id) l | None -> (* try to rewrite in all hypothesis (except maybe the rewritten one) *) Proofview.Goal.nf_enter { enter = begin fun gl -> let ids = Tacmach.New.pf_ids_of_hyps gl in try_do_hyps (fun id -> id) ids end }) let auto_multi_rewrite ?(conds=Naive) lems cl = Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in match onconcl,cl.Locus.onhyps with | false,Some [_] | true,Some [] | false,Some [] -> (* autorewrite with .... in clause using tac n'est sur que si clause represente soit le but soit UNE hypothese *) Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) | _ -> Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") (* Functions necessary to the library object declaration *) let cache_hintrewrite (_,(rbase,lrl)) = let base = try raw_find_base rbase with Not_found -> HintDN.empty in let max = try fst (Util.List.last (HintDN.find_all base)) with Failure _ -> 0 in let lrl = HintDN.refresh_metas lrl in let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in rewtab:=String.Map.add rbase (HintDN.union lrl base) !rewtab let subst_hintrewrite (subst,(rbase,list as node)) = let list' = HintDN.subst subst list in if list' == list then node else (rbase,list') let classify_hintrewrite x = Libobject.Substitute x (* Declaration of the Hint Rewrite library object *) let inHintRewrite : string * HintDN.t -> Libobject.obj = Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with Libobject.cache_function = cache_hintrewrite; Libobject.load_function = (fun _ -> cache_hintrewrite); Libobject.subst_function = subst_hintrewrite; Libobject.classify_function = classify_hintrewrite } open Clenv type hypinfo = { hyp_cl : clausenv; hyp_prf : constr; hyp_ty : types; hyp_car : constr; hyp_rel : constr; hyp_l2r : bool; hyp_left : constr; hyp_right : constr; } let decompose_applied_relation metas env sigma c ctype left2right = let find_rel ty = let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in let eqclause = if metas then eqclause else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd) in let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in let rec split_last_two = function | [c1;c2] -> [],(c1, c2) | x::y::z -> let l,res = split_last_two (y::z) in x::l, res | _ -> raise Not_found in try let others,(c1,c2) = split_last_two args in let ty1, ty2 = Typing.unsafe_type_of env eqclause.evd c1, Typing.unsafe_type_of env eqclause.evd c2 in (* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) (* else *) Some { hyp_cl=eqclause; hyp_prf=(Clenv.clenv_value eqclause); hyp_ty = ty; hyp_car=ty1; hyp_rel=mkApp (equiv, Array.of_list others); hyp_l2r=left2right; hyp_left=c1; hyp_right=c2; } with Not_found -> None in match find_rel ctype with | Some c -> Some c | None -> let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) match find_rel (it_mkProd_or_LetIn t' ctx) with | Some c -> Some c | None -> None let find_applied_relation metas loc env sigma c left2right = let ctype = Typing.unsafe_type_of env sigma c in match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c | None -> user_err_loc (loc, "decompose_applied_relation", str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) let add_rew_rules base lrul = let counter = ref 0 in let env = Global.env () in let sigma = Evd.from_env env in let ist = { Genintern.ltacvars = Id.Set.empty; genv = Global.env () } in let intern tac = snd (Genintern.generic_intern ist tac) in let lrul = List.fold_left (fun dn (loc,(c,ctx),b,t) -> let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in let info = find_applied_relation false loc env sigma c b in let pat = if b then info.hyp_left else info.hyp_right in let rul = { rew_lemma = c; rew_type = info.hyp_ty; rew_pat = pat; rew_ctx = ctx; rew_l2r = b; rew_tac = Option.map intern t} in incr counter; HintDN.add pat (!counter, rul) dn) HintDN.empty lrul in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) coq-8.6/tactics/class_tactics.mli0000644000175000017500000000375013022274260016114 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool val set_typeclasses_debug : bool -> unit val get_typeclasses_debug : unit -> bool val set_typeclasses_depth : int option -> unit val get_typeclasses_depth : unit -> int option type search_strategy = Dfs | Bfs val set_typeclasses_strategy : search_strategy -> unit val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> ?strategy:search_strategy -> depth:(Int.t option) -> Hints.hint_db_name list -> unit Proofview.tactic val head_of_constr : Id.t -> Term.constr -> unit Proofview.tactic val not_evar : constr -> unit Proofview.tactic val is_ground : constr -> tactic val autoapply : constr -> Hints.hint_db_name -> tactic module Search : sig val eauto_tac : ?st:Names.transparent_state -> (** The transparent_state used when working with local hypotheses *) ?unique:bool -> (** Should we force a unique solution *) only_classes:bool -> (** Should non-class goals be shelved and resolved at the end *) ?strategy:search_strategy -> (** Is a traversing-strategy specified? *) depth:Int.t option -> (** Bounded or unbounded search *) dep:bool -> (** Should the tactic be made backtracking on the initial goals, whatever their internal dependencies are. *) Hints.hint_db list -> (** The list of hint databases to use *) unit Proofview.tactic end coq-8.6/tactics/btermdn.ml0000644000175000017500000001216613022274260014560 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* RefOrdered.compare gr1 gr2 | _ -> Pervasives.compare t1 t2 (** OK *) type 'res lookup_res = 'res Dn.lookup_res = Label of 'res | Nothing | Everything let decomp_pat = let rec decrec acc = function | PApp (f,args) -> decrec (Array.to_list args @ acc) f | PProj (p, c) -> (PRef (ConstRef (Projection.constant p)), c :: acc) | c -> (c,acc) in decrec [] let decomp = let rec decrec acc c = match kind_of_term c with | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f | Proj (p, c) -> (mkConst (Projection.constant p), c :: acc) | Cast (c1,_,_) -> decrec acc c1 | _ -> (c,acc) in decrec [] let constr_val_discr t = let c, l = decomp t in match kind_of_term c with | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id -> Label(GRLabel (VarRef id),l) | Const _ -> Everything | _ -> Nothing let constr_pat_discr t = if not (Patternops.occur_meta_pattern t) then None else match decomp_pat t with | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) | _ -> None let constr_val_discr_st (idpred,cpred) t = let c, l = decomp t in match kind_of_term c with | Const (c,u) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> if List.is_empty l then Label(LambdaLabel, [d; c] @ l) else Everything | Sort _ -> Label(SortLabel, []) | Evar _ -> Everything | _ -> Nothing let constr_pat_discr_st (idpred,cpred) t = match decomp_pat t with | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) | PRef ((VarRef v) as ref), args when not (Id.Pred.mem v idpred) -> Some(GRLabel ref,args) | PVar v, args when not (Id.Pred.mem v idpred) -> Some(GRLabel (VarRef v),args) | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) -> Some (GRLabel ref, args) | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) | PLambda (_, d, c), [] -> Some (LambdaLabel, [d ; c]) | PSort s, [] -> Some (SortLabel, []) | _ -> None let bounded_constr_pat_discr_st st (t,depth) = if Int.equal depth 0 then None else match constr_pat_discr_st st t with | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) let bounded_constr_val_discr_st st (t,depth) = if Int.equal depth 0 then Nothing else match constr_val_discr_st st t with | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) | Nothing -> Nothing | Everything -> Everything let bounded_constr_pat_discr (t,depth) = if Int.equal depth 0 then None else match constr_pat_discr t with | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) let bounded_constr_val_discr (t,depth) = if Int.equal depth 0 then Nothing else match constr_val_discr t with | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) | Nothing -> Nothing | Everything -> Everything module Make = functor (Z : Map.OrderedType) -> struct module Y = struct type t = term_label let compare = compare_term_label end module Dn = Dn.Make(Y)(Z) type t = Dn.t let empty = Dn.empty let add = function | None -> (fun dn (c,v) -> Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) | Some st -> (fun dn (c,v) -> Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) let rmv = function | None -> (fun dn (c,v) -> Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) | Some st -> (fun dn (c,v) -> Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) let lookup = function | None -> (fun dn t -> Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth)) | Some st -> (fun dn t -> Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth)) let app f dn = Dn.app f dn end coq-8.6/tactics/tactic_matching.mli0000644000175000017500000000422713022274260016416 0ustar garesgares (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Evd.evar_map -> Term.constr -> (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic (** [match_goal env sigma hyps concl rules] matches the goal [hyps|-concl] with the set of matching rules [rules]. The environment [env] and the evar_map [sigma] are used to check convertibility for pattern variables shared between hypothesis patterns or the conclusion pattern. *) val match_goal: Environ.env -> Evd.evar_map -> Context.Named.t -> Term.constr -> (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic coq-8.6/tactics/equality.mli0000644000175000017500000001315213022274260015127 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic val general_rewrite : orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic (* Equivalent to [general_rewrite l2r] *) val rewriteLR : ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic val rewriteRL : ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic (* Warning: old [general_rewrite_in] is now [general_rewrite_bindings_in] *) val general_setoid_rewrite_clause : (Id.t option -> orientation -> occurrences -> constr with_bindings -> new_goals:constr list -> unit Proofview.tactic) Hook.t val general_rewrite_ebindings_clause : Id.t option -> orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic val general_rewrite_bindings_in : orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> Id.t -> constr with_bindings -> evars_flag -> unit Proofview.tactic val general_rewrite_in : orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> Id.t -> constr -> evars_flag -> unit Proofview.tactic val general_rewrite_clause : orientation -> evars_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> clause -> unit Proofview.tactic val general_multi_rewrite : evars_flag -> (bool * multi * clear_flag * delayed_open_constr_with_bindings) list -> clause -> (unit Proofview.tactic * conditions) option -> unit Proofview.tactic val replace_in_clause_maybe_by : constr -> constr -> clause -> unit Proofview.tactic option -> unit Proofview.tactic val replace : constr -> constr -> unit Proofview.tactic val replace_by : constr -> constr -> unit Proofview.tactic -> unit Proofview.tactic val discr : evars_flag -> constr with_bindings -> unit Proofview.tactic val discrConcl : unit Proofview.tactic val discrHyp : Id.t -> unit Proofview.tactic val discrEverywhere : evars_flag -> unit Proofview.tactic val discr_tac : evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic val inj : intro_patterns option -> evars_flag -> clear_flag -> constr with_bindings -> unit Proofview.tactic val injClause : intro_patterns option -> evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic val injHyp : clear_flag -> Id.t -> unit Proofview.tactic val injConcl : unit Proofview.tactic val simpleInjClause : evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic val dEq : evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings destruction_arg option -> unit Proofview.tactic val make_iterated_tuple : env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) (* The family cutRewriteIn expect an equality statement *) val cutRewriteInHyp : bool -> types -> Id.t -> unit Proofview.tactic val cutRewriteInConcl : bool -> constr -> unit Proofview.tactic (* The family rewriteIn expect the proof of an equality *) val rewriteInHyp : bool -> constr -> Id.t -> unit Proofview.tactic val rewriteInConcl : bool -> constr -> unit Proofview.tactic val discriminable : env -> evar_map -> constr -> constr -> bool val injectable : env -> evar_map -> constr -> constr -> bool (* Subst *) (* val unfold_body : Id.t -> tactic *) type subst_tactic_flags = { only_leibniz : bool; rewrite_dependent_proof : bool } val subst_gen : bool -> Id.t list -> unit Proofview.tactic val subst : Id.t list -> unit Proofview.tactic val subst_all : ?flags:subst_tactic_flags -> unit -> unit Proofview.tactic (* Replace term *) (* [replace_term dir_opt c cl] perfoms replacement of [c] by the first value found in context (according to [dir] if given to get the rewrite direction) in the clause [cl] *) val replace_term : bool option -> constr -> clause -> unit Proofview.tactic val set_eq_dec_scheme_kind : mutual scheme_kind -> unit (* [build_selector env sigma i c t u v] matches on [c] of type [t] and returns [u] in branch [i] and [v] on other branches *) val build_selector : env -> evar_map -> int -> constr -> types -> constr -> constr -> constr coq-8.6/tactics/inv.ml0000644000175000017500000004711313022274260013721 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* a1=a1->a2=a2 ... -> C Algorithm: suppose length(largs)=n (1) Push the entire arity, [xbar:Abar], carrying along largs and the conclusion (2) Pair up each ai with its respective Rel version: a1==(Rel n), a2==(Rel n-1), etc. (3) For each pair, ai,Rel j, if the Ai is dependent - that is, the type of [Rel j] is an open term, then we construct the iterated tuple, [make_iterated_tuple] does it, and use that for our equation Otherwise, we just use ai=Rel j *) type inversion_status = Dep of constr option | NoDep let compute_eqn env sigma n i ai = (mkRel (n-i),get_type_of env sigma (mkRel (n-i))) let make_inv_predicate env evd indf realargs id status concl = let nrealargs = List.length realargs in let (hyps,concl) = match status with | NoDep -> (* We push the arity and leave concl unchanged *) let hyps_arity,_ = get_arity env indf in (hyps_arity,concl) | Dep dflt_concl -> if not (occur_var env id concl) then errorlabstrm "make_inv_predicate" (str "Current goal does not depend on " ++ pr_id id ++ str"."); (* We abstract the conclusion of goal with respect to realargs and c to * be concl in order to rewrite and have c also rewritten when the case * will be done *) let pred = match dflt_concl with | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> let sort = get_sort_family_of env !evd concl in let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in let p = make_arity env true indf sort in let evd',(p,ptyp) = Unification.abstract_list_all env !evd p concl (realargs@[mkVar id]) in evd := evd'; p in let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in (* We lift to make room for the equations *) (hyps,lift nrealargs bodypred) in let nhyps = Context.Rel.length hyps in let env' = push_rel_context hyps env in (* Now the arity is pushed, and we need to construct the pairs * ai,mkRel(n-i+1) *) (* Now, we can recurse down this list, for each ai,(mkRel k) whether to push (mkRel k)=ai (when Ai is closed). In any case, we carry along the rest of pairs *) let eqdata = Coqlib.build_coq_eq_data () in let rec build_concl eqns args n = function | [] -> it_mkProd concl eqns, Array.rev_of_list args | ai :: restlist -> let ai = lift nhyps ai in let (xi, ti) = compute_eqn env' !evd nhyps n ai in let (lhs,eqnty,rhs) = if closed0 ti then (xi,ti,ai) else let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in evd := sigma; res in let eq_term = eqdata.Coqlib.eq in let eq = Evarutil.evd_comb1 (Evd.fresh_global env) evd eq_term in let eqn = applist (eq,[eqnty;lhs;rhs]) in let eqns = (Anonymous, lift n eqn) :: eqns in let refl_term = eqdata.Coqlib.refl in let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in let refl = mkApp (refl_term, [|eqnty; rhs|]) in let _ = Evarutil.evd_comb1 (Typing.type_of env) evd refl in let args = refl :: args in build_concl eqns args (succ n) restlist in let (newconcl, args) = build_concl [] [] 0 realargs in let predicate = it_mkLambda_or_LetIn_name env newconcl hyps in let _ = Evarutil.evd_comb1 (Typing.type_of env) evd predicate in (* OK - this predicate should now be usable by res_elimination_then to do elimination on the conclusion. *) predicate, args (* The result of the elimination is a bunch of goals like: |- (cibar:Cibar)Equands->C where the cibar are either dependent or not. We are fed a signature, with "true" for every recursive argument, and false for every non-recursive one. So we need to do the sign_branch_len(sign) intros, thinning out all recursive assumptions. This leaves us with exactly length(sign) assumptions. We save their names, and then do introductions for all the equands (there are some number of them, which is the other argument of the tactic) This gives us the #neqns equations, whose names we get also, and the #length(sign) arguments. Suppose that #nodep of these arguments are non-dependent. Generalize and thin them. This gives us #dep = #length(sign)-#nodep arguments which are dependent. Now, we want to take each of the equations, and do all possible injections to get the left-hand-side to be a variable. At the same time, if we find a lhs/rhs pair which are different, we can discriminate them to prove false and finish the branch. Then, we thin away the equations, and do the introductions for the #nodep arguments which we generalized before. *) (* Called after the case-assumptions have been killed off, and all the intros have been done. Given that the clause in question is an equality (if it isn't we fail), we are responsible for projecting the equality, using Injection and Discriminate, and applying it to the concusion *) (* Computes the subset of hypothesis in the local context whose type depends on t (should be of the form (mkVar id)), then it generalizes them, applies tac to rewrite all occurrencies of t, and introduces generalized hypotheis. Precondition: t=(mkVar id) *) let dependent_hyps env id idlist gl = let rec dep_rec =function | [] -> [] | d::l -> (* Update the type of id1: it may have been subject to rewriting *) let d = pf_get_hyp (get_id d) gl in if occur_var_in_decl env id d then d :: dep_rec l else dep_rec l in dep_rec idlist let split_dep_and_nodep hyps gl = List.fold_right (fun d (l1,l2) -> if var_occurs_in_pf gl (get_id d) then (d::l1,l2) else (l1,d::l2)) hyps ([],[]) (* Computation of dids is late; must have been done in rewrite_equations*) (* Will keep generalizing and introducing back and forth... *) (* Moreover, others hyps depending of dids should have been *) (* generalized; in such a way that [dids] can endly be cleared *) (* Consider for instance this case extracted from Well_Ordering.v A : Set B : A ->Set a0 : A f : (B a0) ->WO y : WO H0 : (le_WO y (sup a0 f)) ============================ (Acc WO le_WO y) Inversion H0 gives A : Set B : A ->Set a0 : A f : (B a0) ->WO y : WO H0 : (le_WO y (sup a0 f)) a1 : A f0 : (B a1) ->WO v : (B a1) H1 : (f0 v)=y H3 : a1=a0 f1 : (B a0) ->WO v0 : (B a0) H4 : (existS A [a:A](B a) ->WO a0 f1)=(existS A [a:A](B a) ->WO a0 f) ============================ (Acc WO le_WO (f1 v0)) while, ideally, we would have expected A : Set B : A ->Set a0 : A f0 : (B a0)->WO v : (B a0) ============================ (Acc WO le_WO (f0 v)) obtained from destruction with equalities A : Set B : A ->Set a0 : A f : (B a0) ->WO y : WO H0 : (le_WO y (sup a0 f)) a1 : A f0 : (B a1)->WO v : (B a1) H1 : (f0 v)=y H2 : (sup a1 f0)=(sup a0 f) ============================ (Acc WO le_WO (f0 v)) by clearing initial hypothesis H0 and its dependency y, clearing H1 (in fact H1 can be avoided using the same trick as for newdestruct), decomposing H2 to get a1=a0 and (a1,f0)=(a0,f), replacing a1 by a0 everywhere and removing a1 and a1=a0 (in fact it would have been more regular to replace a0 by a1, avoiding f1 and v0 cannot replace f0 and v), finally removing H4 (here because f is not used, more generally after using eq_dep and replacing f by f0) [and finally rename a0, f0 into a,f]. Summary: nine useless hypotheses! Nota: with Inversion_clear, only four useless hypotheses *) let generalizeRewriteIntros as_mode tac depids id = Proofview.tclENV >>= fun env -> Proofview.Goal.nf_enter { enter = begin fun gl -> let dids = dependent_hyps env id depids gl in let reintros = if as_mode then intros_replacing else intros_possibly_replacing in (tclTHENLIST [bring_hyps dids; tac; (* may actually fail to replace if dependent in a previous eq *) reintros (ids_of_named_context dids)]) end } let error_too_many_names pats = let loc = Loc.join_loc (fst (List.hd pats)) (fst (List.last pats)) in Proofview.tclENV >>= fun env -> tclZEROMSG ~loc ( str "Unexpected " ++ str (String.plural (List.length pats) "introduction pattern") ++ str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (fst (run_delayed env Evd.empty c)))) pats ++ str ".") let get_names (allow_conj,issimple) (loc, pat as x) = match pat with | IntroNaming IntroAnonymous | IntroForthcoming _ -> error "Anonymous pattern not allowed for inversion equations." | IntroNaming (IntroFresh _) -> error "Fresh pattern not allowed for inversion equations." | IntroAction IntroWildcard -> error "Discarding pattern not allowed for inversion equations." | IntroAction (IntroRewrite _) -> error "Rewriting pattern not allowed for inversion equations." | IntroAction (IntroOrAndPattern (IntroAndPattern [])) when allow_conj -> (None, []) | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l) | IntroOrPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l ])) when allow_conj -> (Some id,l) | IntroAction (IntroOrAndPattern (IntroAndPattern _)) -> if issimple then error"Conjunctive patterns not allowed for simple inversion equations." else error"Nested conjunctive patterns not allowed for inversion equations." | IntroAction (IntroInjection l) -> error "Injection patterns not allowed for inversion equations." | IntroAction (IntroOrAndPattern (IntroOrPattern _)) -> error "Disjunctive patterns not allowed for inversion equations." | IntroAction (IntroApplyOn (c,pat)) -> error "Apply patterns not allowed for inversion equations." | IntroNaming (IntroIdentifier id) -> (Some id,[x]) let rec tclMAP_i allow_conj n tacfun = function | [] -> tclDO n (tacfun (None,[])) | a::l as l' -> if Int.equal n 0 then error_too_many_names l' else tclTHEN (tacfun (get_names allow_conj a)) (tclMAP_i allow_conj (n-1) tacfun l) let remember_first_eq id x = if !x == MoveLast then x := MoveAfter id (* invariant: ProjectAndApply is responsible for erasing the clause which it is given as input It simplifies the clause (an equality) to use it as a rewrite rule and then erases the result of the simplification. *) (* invariant: ProjectAndApplyNoThining simplifies the clause (an equality) . If it can discriminate then the goal is proved, if not tries to use it as a rewrite rule. It erases the clause which is given as input *) let projectAndApply as_mode thin avoid id eqname names depids = let subst_hyp l2r id = tclTHEN (tclTRY(rewriteInConcl l2r (mkVar id))) (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC)) in let substHypIfVariable tac id = Proofview.Goal.nf_enter { enter = begin fun gl -> (** We only look at the type of hypothesis "id" *) let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in let (t,t1,t2) = Hipattern.dest_nf_eq gl hyp in match (kind_of_term t1, kind_of_term t2) with | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1 | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2 | _ -> tac id end } in let deq_trailer id clear_flag _ neqns = assert (clear_flag == None); tclTHENLIST [if as_mode then clear [id] else tclIDTAC; (tclMAP_i (false,false) neqns (function (idopt,_) -> tclTRY (tclTHEN (intro_move_avoid idopt avoid MoveLast) (* try again to substitute and if still not a variable after *) (* decomposition, arbitrarily try to rewrite RL !? *) (tclTRY (onLastHypId (substHypIfVariable (fun id -> subst_hyp false id)))))) names); (if as_mode then tclIDTAC else clear [id])] (* Doing the above late breaks the computation of dids in generalizeRewriteIntros, and hence breaks proper intros_replacing but it is needed for compatibility *) in substHypIfVariable (* If no immediate variable in the equation, try to decompose it *) (* and apply a trailer which again try to substitute *) (fun id -> dEqThen false (deq_trailer id) (Some (None,ElimOnConstr (mkVar id,NoBindings)))) id let nLastDecls i tac = Proofview.Goal.nf_enter { enter = begin fun gl -> tac (nLastDecls gl i) end } (* Introduction of the equations on arguments othin: discriminates Simple Inversion, Inversion and Inversion_clear None: the equations are introduced, but not rewritten Some thin: the equations are rewritten, and cleared if thin is true *) let rewrite_equations as_mode othin neqns names ba = Proofview.Goal.nf_enter { enter = begin fun gl -> let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in let first_eq = ref MoveLast in let avoid = if as_mode then List.map get_id nodepids else [] in match othin with | Some thin -> tclTHENLIST [tclDO neqns intro; bring_hyps nodepids; clear (ids_of_named_context nodepids); (nLastDecls neqns (fun ctx -> bring_hyps (List.rev ctx))); (nLastDecls neqns (fun ctx -> clear (ids_of_named_context ctx))); tclMAP_i (true,false) neqns (fun (idopt,names) -> (tclTHEN (intro_move_avoid idopt avoid MoveLast) (onLastHypId (fun id -> tclTRY (projectAndApply as_mode thin avoid id first_eq names depids))))) names; tclMAP (fun d -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) let idopt = if as_mode then Some (get_id d) else None in intro_move idopt (if thin then MoveLast else !first_eq)) nodepids; (tclMAP (fun d -> tclTRY (clear [get_id d])) depids)] | None -> (* simple inversion *) if as_mode then tclMAP_i (false,true) neqns (fun (idopt,_) -> intro_move idopt MoveLast) names else (tclTHENLIST [tclDO neqns intro; bring_hyps nodepids; clear (ids_of_named_context nodepids)]) end } let interp_inversion_kind = function | SimpleInversion -> None | FullInversion -> Some false | FullInversionClear -> Some true let rewrite_equations_tac as_mode othin id neqns names ba = let othin = interp_inversion_kind othin in let tac = rewrite_equations as_mode othin neqns names ba in match othin with | Some true (* if Inversion_clear, clear the hypothesis *) -> tclTHEN tac (tclTRY (clear [id])) | _ -> tac let raw_inversion inv_kind id status names = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let c = mkVar id in let (ind, t) = try pf_apply Tacred.reduce_to_atomic_ind gl (pf_unsafe_type_of gl c) with UserError _ -> let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in CErrors.errorlabstrm "" msg in let IndType (indf,realargs) = find_rectype env sigma t in let evdref = ref sigma in let (elim_predicate, args) = make_inv_predicate env evdref indf realargs id status concl in let sigma = !evdref in let (cut_concl,case_tac) = if status != NoDep && (dependent c concl) then Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])), case_then_using else Reduction.beta_appvect elim_predicate (Array.of_list realargs), case_nodep_then_using in let refined id = let prf = mkApp (mkVar id, args) in Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) } in let neqns = List.length realargs in let as_mode = names != None in let tac = (tclTHENS (assert_before Anonymous cut_concl) [case_tac names (introCaseAssumsThen false (* ApplyOn not supported by inversion *) (rewrite_equations_tac as_mode inv_kind id neqns)) (Some elim_predicate) ind (c, t); onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) in Sigma.Unsafe.of_pair (tac, sigma) end } (* Error messages of the inversion tactics *) let wrap_inv_error id = function (e, info) -> match e with | Indrec.RecursionSchemeError (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) -> Proofview.tclENV >>= fun env -> tclZEROMSG ( (strbrk "Inversion would require case analysis on sort " ++ pr_sort Evd.empty k ++ strbrk " which is not allowed for inductive definition " ++ pr_inductive env (fst i) ++ str ".")) | e -> Proofview.tclZERO ~info e (* The most general inversion tactic *) let inversion inv_kind status names id = Proofview.tclORELSE (raw_inversion inv_kind id status names) (wrap_inv_error id) (* Specializing it... *) let inv_gen thin status names = try_intros_until (inversion thin status names) open Tacexpr let inv k = inv_gen k NoDep let inv_tac id = inv FullInversion None (NamedHyp id) let inv_clear_tac id = inv FullInversionClear None (NamedHyp id) let dinv k c = inv_gen k (Dep c) let dinv_tac id = dinv FullInversion None None (NamedHyp id) let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) (* InvIn will bring the specified clauses into the conclusion, and then * perform inversion on the named hypothesis. After, it will intro them * back to their places in the hyp-list. *) let invIn k names ids id = Proofview.Goal.nf_enter { enter = begin fun gl -> let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let concl = Proofview.Goal.concl gl in let nb_prod_init = nb_prod concl in let intros_replace_ids = Proofview.Goal.enter { enter = begin fun gl -> let concl = pf_nf_concl gl in let nb_of_new_hyp = nb_prod concl - (List.length hyps + nb_prod_init) in if nb_of_new_hyp < 1 then intros_replacing ids else tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) end } in Proofview.tclORELSE (tclTHENLIST [bring_hyps hyps; inversion k NoDep names id; intros_replace_ids]) (wrap_inv_error id) end } let invIn_gen k names idl = try_intros_until (invIn k names idl) let inv_clause k names = function | [] -> inv k names | idl -> invIn_gen k names idl coq-8.6/tactics/leminv.ml0000644000175000017500000002341513022274260014416 0ustar garesgares(************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (*