aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--.merlin2
-rw-r--r--CHANGES7
-rw-r--r--COMPATIBILITY31
-rw-r--r--INSTALL5
-rw-r--r--Makefile6
-rw-r--r--Makefile.build70
-rw-r--r--Makefile.common12
-rw-r--r--_tags1
-rw-r--r--checker/check.mllib1
-rw-r--r--config/coq_config.mli7
-rw-r--r--configure.ml169
-rw-r--r--dev/base_include1
-rw-r--r--dev/db1
-rw-r--r--dev/ocamldebug-coq.run3
-rw-r--r--dev/printers.mllib4
-rw-r--r--dev/top_printers.ml10
-rw-r--r--doc/refman/Program.tex2
-rw-r--r--doc/refman/RefMan-ltac.tex12
-rw-r--r--doc/refman/RefMan-oth.tex8
-rw-r--r--doc/refman/RefMan-tac.tex2
-rw-r--r--engine/engine.mllib7
-rw-r--r--engine/evd.ml (renamed from pretyping/evd.ml)631
-rw-r--r--engine/evd.mli (renamed from pretyping/evd.mli)32
-rw-r--r--engine/logic_monad.ml (renamed from proofs/logic_monad.ml)221
-rw-r--r--engine/logic_monad.mli (renamed from proofs/logic_monad.mli)65
-rw-r--r--engine/namegen.ml (renamed from pretyping/namegen.ml)0
-rw-r--r--engine/namegen.mli (renamed from pretyping/namegen.mli)0
-rw-r--r--engine/proofview_monad.ml (renamed from proofs/proofview_monad.ml)0
-rw-r--r--engine/proofview_monad.mli (renamed from proofs/proofview_monad.mli)0
-rw-r--r--engine/sigma.ml93
-rw-r--r--engine/sigma.mli116
-rw-r--r--engine/termops.ml (renamed from pretyping/termops.ml)0
-rw-r--r--engine/termops.mli (renamed from pretyping/termops.mli)4
-rw-r--r--engine/uState.ml467
-rw-r--r--engine/uState.mli115
-rw-r--r--grammar/argextend.ml475
-rw-r--r--grammar/grammar.mllib1
-rw-r--r--grammar/q_util.ml429
-rw-r--r--grammar/q_util.mli2
-rw-r--r--grammar/tacextend.ml483
-rw-r--r--grammar/vernacextend.ml47
-rw-r--r--ide/coq.ml16
-rw-r--r--ide/coqOps.ml37
-rw-r--r--ide/coqide.ml257
-rw-r--r--ide/fileOps.ml8
-rw-r--r--ide/ide.mllib2
-rw-r--r--ide/ide_slave.ml23
-rw-r--r--ide/ideutils.ml51
-rw-r--r--ide/ideutils.mli9
-rw-r--r--ide/interface.mli9
-rw-r--r--ide/nanoPG.ml2
-rw-r--r--ide/preferences.ml1209
-rw-r--r--ide/preferences.mli169
-rw-r--r--ide/session.ml22
-rw-r--r--ide/session.mli1
-rw-r--r--ide/tags.ml54
-rw-r--r--ide/tags.mli19
-rw-r--r--ide/wg_Command.ml25
-rw-r--r--ide/wg_Command.mli2
-rw-r--r--ide/wg_Completion.ml2
-rw-r--r--ide/wg_MessageView.ml39
-rw-r--r--ide/wg_MessageView.mli11
-rw-r--r--ide/wg_ProofView.ml34
-rw-r--r--ide/wg_ScriptView.ml29
-rw-r--r--ide/wg_Segment.ml3
-rw-r--r--ide/xmlprotocol.ml414
-rw-r--r--ide/xmlprotocol.mli4
-rw-r--r--intf/extend.mli34
-rw-r--r--intf/tacexpr.mli20
-rw-r--r--kernel/cemitcodes.ml12
-rw-r--r--kernel/cemitcodes.mli4
-rw-r--r--kernel/closure.ml21
-rw-r--r--kernel/closure.mli2
-rw-r--r--kernel/constr.ml20
-rw-r--r--kernel/constr.mli8
-rw-r--r--kernel/csymtable.ml16
-rw-r--r--kernel/environ.ml17
-rw-r--r--kernel/environ.mli2
-rw-r--r--kernel/indtypes.ml78
-rw-r--r--kernel/kernel.mllib1
-rw-r--r--kernel/mod_typing.ml2
-rw-r--r--kernel/names.ml19
-rw-r--r--kernel/names.mli7
-rw-r--r--kernel/nativelib.ml11
-rw-r--r--kernel/pre_env.ml4
-rw-r--r--kernel/pre_env.mli2
-rw-r--r--kernel/reduction.ml38
-rw-r--r--kernel/reduction.mli8
-rw-r--r--kernel/subtyping.ml2
-rw-r--r--kernel/term.mli4
-rw-r--r--kernel/uGraph.ml868
-rw-r--r--kernel/uGraph.mli63
-rw-r--r--kernel/univ.ml834
-rw-r--r--kernel/univ.mli54
-rw-r--r--lib/cMap.ml42
-rw-r--r--lib/cMap.mli15
-rw-r--r--lib/envars.ml27
-rw-r--r--lib/envars.mli13
-rw-r--r--lib/feedback.ml6
-rw-r--r--lib/feedback.mli2
-rw-r--r--lib/flags.ml6
-rw-r--r--lib/flags.mli4
-rw-r--r--lib/hMap.ml14
-rw-r--r--lib/pp.ml6
-rw-r--r--lib/pp.mli4
-rw-r--r--lib/richpp.ml34
-rw-r--r--lib/richpp.mli26
-rw-r--r--lib/serialize.ml4
-rw-r--r--lib/serialize.mli2
-rw-r--r--lib/system.ml95
-rw-r--r--lib/system.mli38
-rw-r--r--library/global.mli2
-rw-r--r--library/universes.ml34
-rw-r--r--library/universes.mli10
-rw-r--r--myocamlbuild.ml2
-rw-r--r--parsing/compat.ml471
-rw-r--r--parsing/egramcoq.ml38
-rw-r--r--parsing/egramcoq.mli4
-rw-r--r--parsing/egramml.ml73
-rw-r--r--parsing/egramml.mli18
-rw-r--r--parsing/entry.ml63
-rw-r--r--parsing/entry.mli50
-rw-r--r--parsing/lexer.ml411
-rw-r--r--parsing/parsing.mllib1
-rw-r--r--parsing/pcoq.ml (renamed from parsing/pcoq.ml4)389
-rw-r--r--parsing/pcoq.mli81
-rw-r--r--plugins/btauto/refl_btauto.ml9
-rw-r--r--plugins/cc/cctac.ml40
-rw-r--r--plugins/decl_mode/decl_proof_instr.ml9
-rw-r--r--plugins/derive/derive.ml1
-rw-r--r--plugins/fourier/fourierR.ml5
-rw-r--r--plugins/funind/functional_principles_proofs.ml4
-rw-r--r--plugins/funind/indfun.ml3
-rw-r--r--plugins/funind/invfun.ml4
-rw-r--r--plugins/funind/recdef.ml6
-rw-r--r--plugins/micromega/Psatz.v8
-rw-r--r--plugins/micromega/certificate.ml1566
-rw-r--r--plugins/micromega/coq_micromega.ml399
-rw-r--r--plugins/micromega/g_micromega.ml436
-rw-r--r--plugins/micromega/mfourier.ml20
-rw-r--r--plugins/micromega/mutils.ml9
-rw-r--r--plugins/omega/coq_omega.ml29
-rw-r--r--plugins/quote/quote.ml11
-rw-r--r--plugins/setoid_ring/g_newring.ml490
-rw-r--r--plugins/setoid_ring/newring.ml (renamed from plugins/setoid_ring/newring.ml4)151
-rw-r--r--plugins/setoid_ring/newring.mli78
-rw-r--r--plugins/setoid_ring/newring_ast.mli63
-rw-r--r--plugins/setoid_ring/newring_plugin.mllib1
-rw-r--r--pretyping/evarconv.ml5
-rw-r--r--pretyping/evarutil.ml46
-rw-r--r--pretyping/evarutil.mli5
-rw-r--r--pretyping/pretyping.ml2
-rw-r--r--pretyping/pretyping.mllib3
-rw-r--r--pretyping/unification.ml54
-rw-r--r--pretyping/unification.mli10
-rw-r--r--printing/pptactic.ml30
-rw-r--r--printing/pptactic.mli2
-rw-r--r--printing/pptacticsig.mli6
-rw-r--r--proofs/clenv.ml49
-rw-r--r--proofs/clenvtac.ml12
-rw-r--r--proofs/logic.ml4
-rw-r--r--proofs/pfedit.ml3
-rw-r--r--proofs/proof_global.ml14
-rw-r--r--proofs/proof_global.mli5
-rw-r--r--proofs/proofs.mllib2
-rw-r--r--proofs/proofview.ml102
-rw-r--r--proofs/proofview.mli102
-rw-r--r--proofs/tacmach.ml14
-rw-r--r--proofs/tacmach.mli46
-rw-r--r--proofs/tactic_debug.ml5
-rw-r--r--stm/asyncTaskQueue.ml2
-rw-r--r--stm/lemmas.ml24
-rw-r--r--stm/lemmas.mli13
-rw-r--r--stm/stm.ml2
-rw-r--r--tactics/auto.ml66
-rw-r--r--tactics/auto.mli2
-rw-r--r--tactics/autorewrite.ml21
-rw-r--r--tactics/class_tactics.ml132
-rw-r--r--tactics/contradiction.ml33
-rw-r--r--tactics/eauto.ml474
-rw-r--r--tactics/eauto.mli6
-rw-r--r--tactics/elim.ml18
-rw-r--r--tactics/eqdecide.ml21
-rw-r--r--tactics/equality.ml141
-rw-r--r--tactics/evar_tactics.ml16
-rw-r--r--tactics/extratactics.ml468
-rw-r--r--tactics/ftactic.mli6
-rw-r--r--tactics/hipattern.mli6
-rw-r--r--tactics/inv.ml39
-rw-r--r--tactics/leminv.ml5
-rw-r--r--tactics/rewrite.ml46
-rw-r--r--tactics/tacenv.ml8
-rw-r--r--tactics/tacenv.mli4
-rw-r--r--tactics/tacinterp.ml233
-rw-r--r--tactics/tacticals.ml55
-rw-r--r--tactics/tacticals.mli10
-rw-r--r--tactics/tactics.ml815
-rw-r--r--tactics/tactics.mli4
-rw-r--r--tactics/tauto.ml47
-rw-r--r--test-suite/bugs/closed/3911.v26
-rw-r--r--test-suite/bugs/closed/3929.v12
-rw-r--r--test-suite/bugs/closed/3957.v6
-rw-r--r--test-suite/bugs/closed/4214.v (renamed from test-suite/bugs/opened/4214.v)3
-rw-r--r--test-suite/bugs/opened/3889.v11
-rw-r--r--test-suite/bugs/opened/3890.v18
-rw-r--r--test-suite/bugs/opened/3916.v3
-rw-r--r--test-suite/bugs/opened/3919.v-disabled13
-rw-r--r--test-suite/bugs/opened/3922.v-disabled83
-rw-r--r--test-suite/bugs/opened/3923.v33
-rw-r--r--test-suite/bugs/opened/3926.v30
-rw-r--r--test-suite/bugs/opened/3928.v-disabled12
-rw-r--r--test-suite/bugs/opened/3938.v6
-rw-r--r--test-suite/bugs/opened/3946.v11
-rw-r--r--test-suite/bugs/opened/3948.v25
-rw-r--r--test-suite/failure/positivity.v46
-rw-r--r--test-suite/success/Typeclasses.v23
-rw-r--r--test-suite/success/decl_mode2.v249
-rw-r--r--test-suite/success/shrink_abstract.v13
-rw-r--r--test-suite/success/shrink_obligations.v28
-rw-r--r--test-suite/success/subst.v25
-rw-r--r--theories/Init/Datatypes.v2
-rw-r--r--theories/Lists/List.v76
-rw-r--r--theories/Lists/ListSet.v109
-rw-r--r--tools/coq_makefile.ml27
-rw-r--r--tools/coqdep.ml4
-rw-r--r--tools/coqdep_boot.ml49
-rw-r--r--tools/coqdep_common.ml73
-rw-r--r--tools/coqdep_common.mli7
-rw-r--r--tools/coqmktop.ml13
-rw-r--r--tools/fake_ide.ml23
-rw-r--r--tools/ocamllibdep.mll210
-rw-r--r--toplevel/auto_ind_decl.ml40
-rw-r--r--toplevel/classes.ml3
-rw-r--r--toplevel/coqinit.ml2
-rw-r--r--toplevel/coqtop.ml2
-rw-r--r--toplevel/metasyntax.ml14
-rw-r--r--toplevel/metasyntax.mli2
-rw-r--r--toplevel/mltop.ml2
-rw-r--r--toplevel/obligations.ml43
-rw-r--r--toplevel/search.ml27
-rw-r--r--toplevel/usage.ml7
-rw-r--r--toplevel/vernacentries.ml10
243 files changed, 8655 insertions, 5796 deletions
diff --git a/.gitignore b/.gitignore
index 3adb9c67c..0466eac85 100644
--- a/.gitignore
+++ b/.gitignore
@@ -110,6 +110,7 @@ plugins/dp/dp_zenon.ml
tools/gallina_lexer.ml
tools/coqwc.ml
tools/coqdep_lexer.ml
+tools/ocamllibdep.ml
tools/coqdoc/cpretty.ml
lib/xml_lexer.ml
diff --git a/.merlin b/.merlin
index 02420c4d8..91dbc336b 100644
--- a/.merlin
+++ b/.merlin
@@ -12,6 +12,8 @@ S kernel/byterun
B kernel/byterun
S library
B library
+S engine
+B engine
S pretyping
B pretyping
S interp
diff --git a/CHANGES b/CHANGES
index cf0f4446f..fa621f5e5 100644
--- a/CHANGES
+++ b/CHANGES
@@ -31,6 +31,13 @@ Tactics
"intros" automatically complete the introduction of its subcomponents, as the
the disjunctive-conjunctive introduction patterns in non-terminal position
already do.
+- New flag "Shrink Abstract" that minimalizes proofs generated by the abstract
+ tactical w.r.t. variables appearing in the body of the proof.
+
+Program
+
+- The "Shrink Obligations" flag now applies to all obligations, not only those
+solved by the automatic tactic.
- Importing Program no longer overrides the "exists" tactic (potential source
of incompatibilities).
- Hints costs are now correctly taken into account (potential source of
diff --git a/COMPATIBILITY b/COMPATIBILITY
index eaeb2cba2..ab29903b9 100644
--- a/COMPATIBILITY
+++ b/COMPATIBILITY
@@ -3,7 +3,36 @@ Potential sources of incompatibilities between Coq V8.4 and V8.5
(see also file CHANGES)
-Universe Polymorphism.
+- 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
diff --git a/INSTALL b/INSTALL
index 83c1b9f3f..955150c2c 100644
--- a/INSTALL
+++ b/INSTALL
@@ -32,6 +32,11 @@ WHAT DO YOU NEED ?
- Objective Caml version 3.12.1 or later
(available at http://caml.inria.fr/)
+ - Findlib (included in OCaml binary distribution under windows,
+ probably available in your distribution and for sure at
+ http://projects.camlcity.org/projects/findlib.html)
+
+
- Camlp5 (version >= 6.02) (Coq compiles with Camlp4 but might be less
well supported)
diff --git a/Makefile b/Makefile
index bb51e3dd5..c5415d9f6 100644
--- a/Makefile
+++ b/Makefile
@@ -69,7 +69,6 @@ USEGRAMMAR := '(\*.*camlp4deps.*grammar'
## Files in the source tree
-YACCFILES:=$(call find, '*.mly')
LEXFILES := $(call find, '*.mll')
export MLLIBFILES := $(call find, '*.mllib')
export ML4BASEFILES := $(call findx, '*.ml4', grep -L -e $(USEGRAMMAR))
@@ -86,10 +85,9 @@ EXISTINGMLI := $(call find, '*.mli')
## Files that will be generated
GENML4FILES:= $(ML4FILES:.ml4=.ml)
-GENMLIFILES:=$(YACCFILES:.mly=.mli)
GENPLUGINSMOD:=$(filter plugins/%,$(MLLIBFILES:%.mllib=%_mod.ml))
-export GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) \
- tools/tolink.ml kernel/copcodes.ml $(GENPLUGINSMOD)
+export GENMLFILES:=$(LEXFILES:.mll=.ml) $(GENPLUGINSMOD) \
+ tools/tolink.ml kernel/copcodes.ml
export GENHFILES:=kernel/byterun/coq_jumptbl.h
export GENVFILES:=theories/Numbers/Natural/BigN/NMake_gen.v
export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) $(GENVFILES)
diff --git a/Makefile.build b/Makefile.build
index 0455a247b..957592640 100644
--- a/Makefile.build
+++ b/Makefile.build
@@ -94,8 +94,8 @@ HIDE := $(if $(VERBOSE),,@)
LOCALINCLUDES=$(addprefix -I , $(SRCDIRS) )
MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB)
-OCAMLC := $(OCAMLC) $(CAMLFLAGS)
-OCAMLOPT := $(OCAMLOPT) $(CAMLFLAGS)
+OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS)
+OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS)
BYTEFLAGS=-thread $(CAMLDEBUG) $(USERFLAGS)
OPTFLAGS=-thread $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS)
@@ -179,7 +179,7 @@ endif
TOTARGET = > "$@" || (RV=$$?; rm -f "$@"; exit $${RV})
###########################################################################
-# Compilation option for .c files
+# Compilation option for .c files
###########################################################################
CINCLUDES= -I $(CAMLHLIB)
@@ -189,9 +189,9 @@ 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)
+$(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN)
cd $(dir $(LIBCOQRUN)) && \
- $(OCAMLMKLIB) -oc $(COQRUN) $(foreach u,$(BYTERUN),$(notdir $(u)))
+ $(OCAMLFIND) ocamlmklib -oc $(COQRUN) $(foreach u,$(BYTERUN),$(notdir $(u)))
#coq_jumptbl.h is required only if you have GCC 2.0 or later
kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h
@@ -501,12 +501,13 @@ test-suite: world $(ALLSTDLIB).v
##################################################################
.PHONY: lib kernel byterun library proofs tactics interp parsing pretyping
-.PHONY: highparsing stm toplevel hightactics
+.PHONY: engine highparsing stm toplevel hightactics
lib: lib/clib.cma lib/lib.cma
kernel: kernel/kernel.cma
byterun: $(BYTERUN)
library: library/library.cma
+engine: engine/engine.cma
proofs: proofs/proofs.cma
tactics: tactics/tactics.cma
interp: interp/interp.cma
@@ -601,7 +602,7 @@ theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_g
printers: $(DEBUGPRINTERS)
-tools: $(TOOLS) $(DEBUGPRINTERS) $(COQDEPBOOT)
+tools: $(TOOLS) $(DEBUGPRINTERS) $(OCAMLLIBDEP)
# coqdep_boot : a basic version of coqdep, with almost no dependencies.
@@ -609,12 +610,9 @@ tools: $(TOOLS) $(DEBUGPRINTERS) $(COQDEPBOOT)
# to avoid using implicit rules and hence .ml.d files that would need
# coqdep_boot.
-COQDEPBOOTSRC:= \
- tools/coqdep_lexer.mli tools/coqdep_lexer.ml \
- tools/coqdep_common.mli tools/coqdep_common.ml \
- tools/coqdep_boot.ml
+OCAMLLIBDEPSRC:= tools/ocamllibdep.ml
-$(COQDEPBOOT): $(COQDEPBOOTSRC)
+$(OCAMLLIBDEP): $(OCAMLLIBDEPSRC)
$(SHOW)'OCAMLBEST -o $@'
$(HIDE)$(call bestocaml, -I tools, unix)
@@ -829,34 +827,34 @@ install-latex:
source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf
$(OCAMLDOCDIR)/coq.tex: $(DOCMLIS:.mli=.cmi)
- $(OCAMLDOC) -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\
+ $(OCAMLFIND) ocamldoc -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\
$(DOCMLIS) -t "Coq mlis documentation" \
-intro $(OCAMLDOCDIR)/docintro -o $@
mli-doc: $(DOCMLIS:.mli=.cmi)
- $(OCAMLDOC) -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \
+ $(OCAMLFIND) ocamldoc -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \
$(DOCMLIS) -d $(OCAMLDOCDIR)/html -colorize-code \
-t "Coq mlis documentation" -intro $(OCAMLDOCDIR)/docintro \
-css-style style.css
ml-dot: $(MLFILES)
- $(OCAMLDOC) -dot -dot-reduce -rectypes -I +threads -I $(CAMLLIB) -I $(MYCAMLP4LIB) $(MLINCLUDES) \
+ $(OCAMLFIND) ocamldoc -dot -dot-reduce -rectypes -I +threads -I $(CAMLLIB) -I $(MYCAMLP4LIB) $(MLINCLUDES) \
$(filter $(addsuffix /%.ml,$(CORESRCDIRS)),$(MLFILES)) -o $(OCAMLDOCDIR)/coq.dot
%_dep.png: %.dot
$(DOT) -Tpng $< -o $@
%_types.dot: %.mli
- $(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -dot-types -o $@ $<
+ $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -dot-types -o $@ $<
-OCAMLDOC_MLLIBD = $(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ \
+OCAMLDOC_MLLIBD = $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ \
$(foreach lib,$(|:.mllib.d=_MLLIB_DEPENDENCIES),$(addsuffix .ml,$($(lib))))
%.dot: | %.mllib.d
$(OCAMLDOC_MLLIBD)
ml-doc:
- $(OCAMLDOC) -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES)
+ $(OCAMLFIND) ocamldoc -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES)
parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d
$(OCAMLDOC_MLLIBD)
@@ -868,7 +866,7 @@ tactics/tactics.dot: | tactics/tactics.mllib.d tactics/hightactics.mllib.d
$(OCAMLDOC_MLLIBD)
%.dot: %.mli
- $(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $<
+ $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $<
$(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex
(cd $(OCAMLDOCDIR) ; pdflatex $*.tex && pdflatex $*.tex)
@@ -1017,10 +1015,6 @@ endif
$(SHOW)'OCAMLLEX $<'
$(HIDE)$(OCAMLLEX) -o $@ "$*.mll"
-%.ml %.mli: %.mly
- $(SHOW)'OCAMLYACC $<'
- $(HIDE)$(OCAMLYACC) $<
-
plugins/%_mod.ml: plugins/%.mllib
$(SHOW)'ECHO... > $@'
$(HIDE)sed -e "s/\([^ ]\{1,\}\)/let _=Mltop.add_known_module\"\1\" /g" $< > $@
@@ -1060,35 +1054,39 @@ endif
# Since OCaml 3.12.1, we could use again ocamldep directly, thanks to
# the option -ml-synonym
-OCAMLDEP_NG = $(OCAMLDEP) -slash -ml-synonym .ml4
+OCAMLDEP_NG = $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4
-checker/%.ml.d: $(D_DEPEND_BEFORE_SRC) checker/%.ml $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
+checker/%.ml.d: $(D_DEPEND_BEFORE_SRC) checker/%.ml $(D_DEPEND_AFTER_SRC) $(GENFILES)
$(SHOW)'OCAMLDEP $<'
$(HIDE)$(OCAMLDEP_NG) $(LOCALCHKLIBS) "$<" $(TOTARGET)
-checker/%.mli.d: $(D_DEPEND_BEFORE_SRC) checker/%.mli $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
+checker/%.mli.d: $(D_DEPEND_BEFORE_SRC) checker/%.mli $(D_DEPEND_AFTER_SRC) $(GENFILES)
$(SHOW)'OCAMLDEP $<'
$(HIDE)$(OCAMLDEP_NG) $(LOCALCHKLIBS) "$<" $(TOTARGET)
-%.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
+%.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(GENFILES)
$(SHOW)'OCAMLDEP $<'
$(HIDE)$(OCAMLDEP_NG) $(DEPFLAGS) "$<" $(TOTARGET)
-%.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
+%.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(GENFILES)
$(SHOW)'OCAMLDEP $<'
$(HIDE)$(OCAMLDEP_NG) $(DEPFLAGS) "$<" $(TOTARGET)
-checker/%.mllib.d: $(D_DEPEND_BEFORE_SRC) checker/%.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
- $(SHOW)'COQDEP $<'
- $(HIDE)$(COQDEPBOOT) -I checker -c "$<" $(TOTARGET)
+checker/%.mllib.d: $(D_DEPEND_BEFORE_SRC) checker/%.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES)
+ $(SHOW)'OCAMLLIBDEP $<'
+ $(HIDE)$(OCAMLLIBDEP) $(LOCALCHKLIBS) "$<" $(TOTARGET)
+
+dev/%.mllib.d: $(D_DEPEND_BEFORE_SRC) dev/%.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES)
+ $(SHOW)'OCAMLLIBDEP $<'
+ $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) -I dev "$<" $(TOTARGET)
-%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
- $(SHOW)'COQDEP $<'
- $(HIDE)$(COQDEPBOOT) -I kernel -I tools/coqdoc -c "$<" $(TOTARGET)
+%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES)
+ $(SHOW)'OCAMLLIBDEP $<'
+ $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET)
-%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENVFILES)
+%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEP) $(GENVFILES)
$(SHOW)'COQDEP $<'
- $(HIDE)$(COQDEPBOOT) $(DEPNATDYN) "$<" $(TOTARGET)
+ $(HIDE)$(COQDEP) -boot $(DEPNATDYN) "$<" $(TOTARGET)
%_stubs.c.d: $(D_DEPEND_BEFORE_SRC) %_stubs.c $(D_DEPEND_AFTER_SRC)
$(SHOW)'CCDEP $<'
diff --git a/Makefile.common b/Makefile.common
index 92a48cd6c..1bc09b9ba 100644
--- a/Makefile.common
+++ b/Makefile.common
@@ -63,7 +63,7 @@ CSDPCERT:=plugins/micromega/csdpcert$(EXE)
CORESRCDIRS:=\
config lib kernel kernel/byterun library \
proofs tactics pretyping interp stm \
- toplevel parsing printing grammar intf
+ toplevel parsing printing grammar intf engine
PLUGINS:=\
omega romega micromega quote \
@@ -87,7 +87,7 @@ CHKSRCDIRS:= checker lib config kernel parsing
###########################################################################
COQDEP:=bin/coqdep$(EXE)
-COQDEPBOOT:=bin/coqdep_boot$(EXE)
+OCAMLLIBDEP:=bin/ocamllibdep$(EXE)
COQMAKEFILE:=bin/coq_makefile$(EXE)
GALLINA:=bin/gallina$(EXE)
COQTEX:=bin/coq-tex$(EXE)
@@ -99,7 +99,7 @@ COQWORKMGR:=bin/coqworkmgr$(EXE)
TOOLS:=$(COQDEP) $(COQMAKEFILE) $(GALLINA) $(COQTEX) $(COQWC) $(COQDOC) $(COQC)\
$(COQWORKMGR)
-PRIVATEBINARIES:=$(FAKEIDE) $(COQDEPBOOT)
+PRIVATEBINARIES:=$(FAKEIDE) $(OCAMLLIBDEP)
###########################################################################
# Documentation
@@ -166,7 +166,7 @@ BYTERUN:=$(addprefix kernel/byterun/, \
# the libraries directly
CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma library/library.cma \
- pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \
+ engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \
parsing/parsing.cma printing/printing.cma tactics/tactics.cma \
stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma tactics/hightactics.cma
@@ -260,7 +260,7 @@ CSDPCERTCMO:=$(addprefix plugins/micromega/, \
DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/printers.cma
-COQDEPCMO:=$(COQENVCMO) tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep.cmo
+COQDEPCMO:=$(COQENVCMO) lib/system.cmo tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep.cmo
COQDOCCMO:=lib/clib.cma $(addprefix tools/coqdoc/, \
cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo )
@@ -378,7 +378,7 @@ MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \
OCAMLDOCDIR=dev/ocamldoc
DOCMLIS=$(wildcard ./lib/*.mli ./intf/*.mli ./kernel/*.mli ./library/*.mli \
- ./pretyping/*.mli ./interp/*.mli printing/*.mli \
+ ./engine/*.mli ./pretyping/*.mli ./interp/*.mli printing/*.mli \
./parsing/*.mli ./proofs/*.mli \
./tactics/*.mli ./stm/*.mli ./toplevel/*.mli)
diff --git a/_tags b/_tags
index 5c978cabd..f805eeaa3 100644
--- a/_tags
+++ b/_tags
@@ -63,6 +63,7 @@
"library": include
"parsing": include
"plugins": include
+"engine": include
"pretyping": include
"printing": include
"proofs": include
diff --git a/checker/check.mllib b/checker/check.mllib
index 49ca6bf05..246fe64de 100644
--- a/checker/check.mllib
+++ b/checker/check.mllib
@@ -35,6 +35,7 @@ Errors
Ephemeron
Future
CUnix
+
System
Profile
RemoteCounter
diff --git a/config/coq_config.mli b/config/coq_config.mli
index c63ba65d4..26f4a148c 100644
--- a/config/coq_config.mli
+++ b/config/coq_config.mli
@@ -14,12 +14,7 @@ val datadir : string option (* where extra data files are installed *)
val docdir : string (* where the doc is installed *)
val ocaml : string (* names of ocaml binaries *)
-val ocamlc : string
-val ocamlopt : string
-val ocamlmklib : string
-val ocamldoc : string
-val ocamldep : string
-val ocamlyacc : string
+val ocamlfind : string
val ocamllex : string
val camlbin : string (* base directory of OCaml binaries *)
diff --git a/configure.ml b/configure.ml
index 173429ba8..47721f778 100644
--- a/configure.ml
+++ b/configure.ml
@@ -11,11 +11,11 @@
#load "str.cma"
open Printf
-let coq_version = "8.5beta2"
-let coq_macos_version = "8.4.92" (** "[...] should be a string comprised of
+let coq_version = "trunk"
+let coq_macos_version = "8.4.90" (** "[...] should be a string comprised of
three non-negative, period-separed integers [...]" *)
-let vo_magic = 8492
-let state_magic = 58502
+let vo_magic = 8511
+let state_magic = 58511
let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr";
"coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"]
@@ -236,7 +236,7 @@ module Prefs = struct
let docdir = ref (None : string option)
let emacslib = ref (None : string option)
let coqdocdir = ref (None : string option)
- let camldir = ref (None : string option)
+ let ocamlfindcmd = ref (None : string option)
let lablgtkdir = ref (None : string option)
let usecamlp5 = ref true
let camlp5dir = ref (None : string option)
@@ -290,8 +290,8 @@ let args_options = Arg.align [
"<dir> Obsolete: same as -emacslib";
"-coqdocdir", arg_string_option Prefs.coqdocdir,
"<dir> Where to install Coqdoc style files";
- "-camldir", arg_string_option Prefs.camldir,
- "<dir> Specifies the path to the OCaml binaries";
+ "-ocamlfind", arg_string_option Prefs.ocamlfindcmd,
+ "<dir> Specifies the ocamlfind command to use";
"-lablgtkdir", arg_string_option Prefs.lablgtkdir,
"<dir> Specifies the path to the Lablgtk library";
"-usecamlp5", Arg.Set Prefs.usecamlp5,
@@ -352,42 +352,18 @@ let _ = parse_args ()
(** Default OCaml binaries *)
type camlexec =
- { mutable byte : string;
- mutable opt : string;
+ { mutable find : string;
mutable top : string;
- mutable mklib : string;
- mutable dep : string;
- mutable doc : string;
- mutable lex : string;
- mutable yacc : string }
-
-(* TODO: autodetect .opt binaries ? *)
+ mutable lex : string; }
let camlexec =
- { byte = "ocamlc";
- opt = "ocamlopt";
+ { find = "ocamlfind";
top = "ocaml";
- mklib = "ocamlmklib";
- dep = "ocamldep";
- doc = "ocamldoc";
- lex = "ocamllex";
- yacc = "ocamlyacc" }
-
-let reset_caml_byte c o = c.byte <- o
-let reset_caml_opt c o = c.opt <- o
-let reset_caml_doc c o = c.doc <- o
+ lex = "ocamllex"; }
+
let reset_caml_lex c o = c.lex <- o
-let reset_caml_dep c o = c.dep <- o
-
-let rebase_camlexec dir c =
- c.byte <- Filename.concat dir c.byte;
- c.opt <- Filename.concat dir c.opt;
- c.top <- Filename.concat dir c.top;
- c.mklib <- Filename.concat dir c.mklib;
- c.dep <- Filename.concat dir c.dep;
- c.doc <- Filename.concat dir c.doc;
- c.lex <- Filename.concat dir c.lex;
- c.yacc <- Filename.concat dir c.yacc
+let reset_caml_top c o = c.top <- o
+let reset_caml_find c o = c.find <- o
let coq_debug_flag = if !Prefs.debug then "-g" else ""
let coq_profile_flag = if !Prefs.profile then "-p" else ""
@@ -471,32 +447,28 @@ let browser =
(** * OCaml programs *)
let camlbin, caml_version, camllib =
- let camlbin, camlc = match !Prefs.camldir with
- | Some dir ->
- rebase_camlexec dir camlexec;
- Filename.dirname camlexec.byte, camlexec.byte
- | None ->
- try let camlc = which camlexec.byte in
- let dir = Filename.dirname camlc in
- if not arch_win32 then rebase_camlexec dir camlexec; (* win32: TOCHECK *)
- dir, camlc
- with Not_found ->
- die (sprintf "Error: cannot find '%s' in your path!\n" camlexec.byte ^
- "Please adjust your path or use the -camldir option of ./configure")
+ let () = match !Prefs.ocamlfindcmd with
+ | Some cmd -> reset_caml_find camlexec cmd
+ | None ->
+ try reset_caml_find camlexec (which camlexec.find)
+ with Not_found ->
+ die (sprintf "Error: cannot find '%s' in your path!\n" camlexec.find ^
+ "Please adjust your path or use the -ocamlfind option of ./configure")
in
- let camlcopt = camlc ^ ".opt" in
- let camlc =
- if is_executable camlcopt then begin
- reset_caml_byte camlexec (camlexec.byte ^ ".opt");
- camlcopt
- end
- else if is_executable camlc then
- camlc
- else
- die ("Error: cannot find the executable '"^camlc^"'.") in
- let caml_version, _ = run camlc ["-version"] in
- let camllib, _ = run camlc ["-where"] in
- camlbin, caml_version, camllib
+ if not (is_executable camlexec.find)
+ then die ("Error: cannot find the executable '"^camlexec.find^"'.")
+ else
+ let caml_version, _ = run camlexec.find ["ocamlc";"-version"] in
+ let camllib, _ = run camlexec.find ["printconf";"stdlib"] in
+ let camlbin = (* TODO beurk beurk beurk *)
+ Filename.dirname (Filename.dirname camllib) / "bin/" in
+ let () =
+ if is_executable (camlbin / "ocamllex")
+ then reset_caml_lex camlexec (camlbin / "ocamllex") in
+ let () =
+ if is_executable (camlbin / "ocaml")
+ then reset_caml_top camlexec (camlbin / "ocaml") in
+ camlbin, caml_version, camllib
let camlp4compat = "-loc loc"
@@ -544,12 +516,8 @@ let camltag = match caml_version_list with
(* Convention: we use camldir as a prioritary location for camlpX, if given *)
let which_camlpX base =
- match !Prefs.camldir with
- | Some dir ->
- let file = Filename.concat dir base in
- if is_executable file then file else which base
- | None ->
- which base
+ let file = Filename.concat camlbin base in
+ if is_executable file then file else which base
(* TODO: camlp5dir should rather be the *binary* location, just as camldir *)
(* TODO: remove the late attempts at finding gramlib.cma *)
@@ -646,40 +614,23 @@ let msg_no_dynlink_cmxa () =
printf "and then run ./configure -natdynlink no\n"
let check_native () =
- if !Prefs.byteonly then raise Not_found;
- let camloptopt = camlexec.opt ^ ".opt" in
- if (is_executable camloptopt || program_in_path camloptopt) then
- reset_caml_opt camlexec camloptopt
- else if not (is_executable camlexec.opt || program_in_path camlexec.opt) then
- (msg_no_ocamlopt (); raise Not_found);
- if not (Sys.file_exists (fullcamlpXlibdir/camlpXmod^".cmxa")) then
- (msg_no_camlpX_cmxa (); raise Not_found);
- if not (Sys.file_exists (camllib/"dynlink.cmxa")) then
- (msg_no_dynlink_cmxa (); raise Not_found);
- let version, _ = run camlexec.opt ["-version"] in
- if version <> caml_version then
- printf
- "Warning: Native and bytecode compilers do not have the same version!\n";
- printf "You have native-code compilation. Good!\n"
+ let () = if !Prefs.byteonly then raise Not_found in
+ let version, _ = tryrun camlexec.find ["opt";"-version"] in
+ if version = "" then let () = msg_no_ocamlopt () in raise Not_found
+ else if not (Sys.file_exists (fullcamlpXlibdir/camlpXmod^".cmxa"))
+ then let () = msg_no_camlpX_cmxa () in raise Not_found
+ else if fst (tryrun camlexec.find ["query";"dynlink"]) = ""
+ then let () = msg_no_dynlink_cmxa () in raise Not_found
+ else
+ let () =
+ if version <> caml_version then
+ printf
+ "Warning: Native and bytecode compilers do not have the same version!\n"
+ in printf "You have native-code compilation. Good!\n"
let best_compiler =
try check_native (); "opt" with Not_found -> "byte"
-let _ =
- let camllexopt = camlexec.lex ^ ".opt" in
- if is_executable camllexopt || program_in_path camllexopt then
- reset_caml_lex camlexec camllexopt
-
-let _ =
- let camldepopt = camlexec.dep ^ ".opt" in
- if is_executable camldepopt || program_in_path camldepopt then
- reset_caml_dep camlexec camldepopt
-
-let _ =
- let camldocopt = camlexec.doc ^ ".opt" in
- if is_executable camldocopt || program_in_path camldocopt then
- reset_caml_doc camlexec camldocopt
-
(** * Native dynlink *)
let hasnatdynlink = !Prefs.natdynlink && best_compiler = "opt"
@@ -830,14 +781,14 @@ let strip =
if hasnatdynlink then "true" else "strip"
else
if !Prefs.profile || !Prefs.debug then "true" else begin
- let _, all = run camlexec.byte ["-config"] in
+ let _, all = run camlexec.find ["ocamlc";"-config"] in
let strip = String.concat "" (List.map (fun l ->
match string_split ' ' l with
| "ranlib:" :: cc :: _ -> (* on windows, we greb the right strip *)
Str.replace_first (Str.regexp "ranlib") "strip" cc
| _ -> ""
) all) in
- if strip = "" then "stip" else strip
+ if strip = "" then "strip" else strip
end
(** * md5sum command *)
@@ -1047,12 +998,7 @@ let write_configml f =
pr_o "datadir" datadir;
pr_s "docdir" docdir;
pr_s "ocaml" camlexec.top;
- pr_s "ocamlc" camlexec.byte;
- pr_s "ocamlopt" camlexec.opt;
- pr_s "ocamlmklib" camlexec.mklib;
- pr_s "ocamldep" camlexec.dep;
- pr_s "ocamldoc" camlexec.doc;
- pr_s "ocamlyacc" camlexec.yacc;
+ pr_s "ocamlfind" camlexec.find;
pr_s "ocamllex" camlexec.lex;
pr_s "camlbin" camlbin;
pr_s "camllib" camllib;
@@ -1136,13 +1082,8 @@ let write_makefile f =
pr "VERSION4MACOS=%s\n\n" coq_macos_version;
pr "# Objective-Caml compile command\n";
pr "OCAML=%S\n" camlexec.top;
- pr "OCAMLC=%S\n" camlexec.byte;
- pr "OCAMLMKLIB=%S\n" camlexec.mklib;
- pr "OCAMLOPT=%S\n" camlexec.opt;
- pr "OCAMLDEP=%S\n" camlexec.dep;
- pr "OCAMLDOC=%S\n" camlexec.doc;
+ pr "OCAMLFIND=%S\n" camlexec.find;
pr "OCAMLLEX=%S\n" camlexec.lex;
- pr "OCAMLYACC=%S\n\n" camlexec.yacc;
pr "# The best compiler: native (=opt) or bytecode (=byte)\n";
pr "BEST=%s\n\n" best_compiler;
pr "# Ocaml version number\n";
@@ -1152,8 +1093,6 @@ let write_makefile f =
pr "# Ocaml .h directory\n";
pr "CAMLHLIB=%S\n\n" camllib;
pr "# Caml link command and Caml make top command\n";
- pr "CAMLLINK=%S\n" camlexec.byte;
- pr "CAMLOPTLINK=%S\n\n" camlexec.opt;
pr "# Caml flags\n";
pr "CAMLFLAGS=-rectypes %s\n" coq_annotate_flag;
pr "# User compilation flag\n";
diff --git a/dev/base_include b/dev/base_include
index d58b6ad13..197528acd 100644
--- a/dev/base_include
+++ b/dev/base_include
@@ -8,6 +8,7 @@
#directory "toplevel";;
#directory "library";;
#directory "kernel";;
+#directory "engine";;
#directory "pretyping";;
#directory "lib";;
#directory "proofs";;
diff --git a/dev/db b/dev/db
index f259b50eb..ece22b3f4 100644
--- a/dev/db
+++ b/dev/db
@@ -13,6 +13,7 @@ install_printer Top_printers.ppexistentialset
install_printer Top_printers.ppintset
install_printer Top_printers.pplab
install_printer Top_printers.ppdir
+install_printer Top_printers.ppmbid
install_printer Top_printers.ppmp
install_printer Top_printers.ppkn
install_printer Top_printers.ppcon
diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run
index d4ab22ced..b00d084ed 100644
--- a/dev/ocamldebug-coq.run
+++ b/dev/ocamldebug-coq.run
@@ -17,7 +17,8 @@ exec $OCAMLDEBUG \
-I $COQTOP \
-I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar \
-I $COQTOP/lib -I $COQTOP/intf -I $COQTOP/kernel \
- -I $COQTOP/library -I $COQTOP/pretyping -I $COQTOP/parsing \
+ -I $COQTOP/library -I $COQTOP/engine \
+ -I $COQTOP/pretyping -I $COQTOP/parsing \
-I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \
-I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config \
-I $COQTOP/plugins/cc -I $COQTOP/plugins/dp \
diff --git a/dev/printers.mllib b/dev/printers.mllib
index 07b48ed57..1a2819feb 100644
--- a/dev/printers.mllib
+++ b/dev/printers.mllib
@@ -55,6 +55,7 @@ Monad
Names
Univ
+UGraph
Esubst
Uint31
Sorts
@@ -116,7 +117,9 @@ Miscops
Universes
Termops
Namegen
+UState
Evd
+Sigma
Glob_ops
Redops
Reductionops
@@ -188,6 +191,7 @@ Pfedit
Tactic_debug
Decl_mode
Ppconstr
+Entry
Pcoq
Printer
Pptactic
diff --git a/dev/top_printers.ml b/dev/top_printers.ml
index f9f2e1b09..b3b1ae0e9 100644
--- a/dev/top_printers.ml
+++ b/dev/top_printers.ml
@@ -40,10 +40,10 @@ let ppid id = pp (pr_id id)
let pplab l = pp (pr_lab l)
let ppmbid mbid = pp (str (MBId.debug_to_string mbid))
let ppdir dir = pp (pr_dirpath dir)
-let ppmp mp = pp(str (string_of_mp mp))
+let ppmp mp = pp(str (ModPath.debug_to_string mp))
let ppcon con = pp(debug_pr_con con)
let ppproj con = pp(debug_pr_con (Projection.constant con))
-let ppkn kn = pp(pr_kn kn)
+let ppkn kn = pp(str (KerName.to_string kn))
let ppmind kn = pp(debug_pr_mind kn)
let ppind (kn,i) = pp(debug_pr_mind kn ++ str"," ++int i)
let ppsp sp = pp(pr_path sp)
@@ -221,7 +221,7 @@ let ppuniverseconstraints c = pp (Universes.Constraints.pr c)
let ppuniverse_context_future c =
let ctx = Future.force c in
ppuniverse_context ctx
-let ppuniverses u = pp (Univ.pr_universes Level.pr u)
+let ppuniverses u = pp (UGraph.pr_universes Level.pr u)
let ppnamedcontextval e =
pp (pr_named_context (Global.env ()) Evd.empty (named_context_of_val e))
@@ -519,7 +519,7 @@ let _ =
extend_vernac_command_grammar ("PrintConstr", 0) None
[GramTerminal "PrintConstr";
GramNonTerminal
- (Loc.ghost,ConstrArgType,Aentry ("constr","constr"),
+ (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")),
Some (Names.Id.of_string "c"))]
let _ =
@@ -536,7 +536,7 @@ let _ =
extend_vernac_command_grammar ("PrintPureConstr", 0) None
[GramTerminal "PrintPureConstr";
GramNonTerminal
- (Loc.ghost,ConstrArgType,Aentry ("constr","constr"),
+ (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")),
Some (Names.Id.of_string "c"))]
(* Setting printer of unbound global reference *)
diff --git a/doc/refman/Program.tex b/doc/refman/Program.tex
index 8e078e981..efcc84ee9 100644
--- a/doc/refman/Program.tex
+++ b/doc/refman/Program.tex
@@ -261,7 +261,7 @@ tactic is replaced by the default one if not specified.
as implicit arguments of the special constant
\texttt{Program.Tactics.obligation}.
\item {\tt Set Shrink Obligations}\optindex{Shrink Obligations}
- Control whether obligations defined by tactics should have their
+ Control whether obligations should have their
context minimized to the set of variables used in the proof of the
obligation, to avoid unnecessary dependencies.
\end{itemize}
diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex
index 5880487f7..2f07beb72 100644
--- a/doc/refman/RefMan-ltac.tex
+++ b/doc/refman/RefMan-ltac.tex
@@ -1041,6 +1041,18 @@ This tactical is useful with tactics such as \texttt{omega} or
the user can avoid the explosion at time of the \texttt{Save} command
without having to cut manually the proof in smaller lemmas.
+It may be useful to generate lemmas minimal w.r.t. the assumptions they depend
+on. This can be obtained thanks to the option below.
+
+\begin{quote}
+\optindex{Shrink Abstract}
+{\tt Set Shrink Abstract}
+\end{quote}
+
+When set, all lemmas generated through \texttt{abstract {\tacexpr}} are
+quantified only over the variables that appear in the term constructed by
+\texttt{\tacexpr}.
+
\begin{Variants}
\item \texttt{abstract {\tacexpr} using {\ident}}.\\
Give explicitly the name of the auxiliary lemma.
diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex
index 4b2b8660c..7c95e4d4a 100644
--- a/doc/refman/RefMan-oth.tex
+++ b/doc/refman/RefMan-oth.tex
@@ -914,6 +914,14 @@ This command turns off the normal displaying.
\subsection[\tt Unset Silent.]{\tt Unset Silent.\optindex{Silent}}
This command turns the normal display on.
+\subsection[\tt Set Search Output Name Only.]{\tt Set Search Output Name Only.\optindex{Search Output Name Only}
+\label{Search-Output-Name-Only}
+\index{Search Output Name Only mode}}
+This command restricts the output of search commands to identifier names; turning it on causes invocations of {\tt Search}, {\tt SearchHead}, {\tt SearchPattern}, {\tt SearchRewrite} etc. to omit types from their output, printing only identifiers.
+
+\subsection[\tt Unset Search Output Name Only.]{\tt Unset Search Output Name Only.\optindex{Search Output Name Only}}
+This command turns type display in search results back on.
+
\subsection[\tt Set Printing Width {\integer}.]{\tt Set Printing Width {\integer}.\optindex{Printing Width}}
\label{SetPrintingWidth}
This command sets which left-aligned part of the width of the screen
diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex
index a21e5631f..67ce7e8cd 100644
--- a/doc/refman/RefMan-tac.tex
+++ b/doc/refman/RefMan-tac.tex
@@ -2858,7 +2858,7 @@ Additionally, it prevents a local definition such as {\tt \ident :=
configurations containing hypotheses of the form {\tt {\ident} = $u$},
or {\tt $u'$ = \ident} with $u'$ not a variable.
-The option is off by default.
+The option is on by default.
\end{Variants}
diff --git a/engine/engine.mllib b/engine/engine.mllib
new file mode 100644
index 000000000..7197a2583
--- /dev/null
+++ b/engine/engine.mllib
@@ -0,0 +1,7 @@
+Logic_monad
+Termops
+Namegen
+UState
+Evd
+Sigma
+Proofview_monad
diff --git a/pretyping/evd.ml b/engine/evd.ml
index 36d9c25fd..ce3e91db7 100644
--- a/pretyping/evd.ml
+++ b/engine/evd.ml
@@ -259,231 +259,21 @@ let instantiate_evar_array info c args =
| [] -> c
| _ -> replace_vars inst c
-module StringOrd = struct type t = string let compare = String.compare end
-module UNameMap = struct
-
- include Map.Make(StringOrd)
-
- let union s t =
- if s == t then s
- else
- merge (fun k l r ->
- match l, r with
- | Some _, _ -> l
- | _, _ -> r) s t
-end
-
-(* 2nd part used to check consistency on the fly. *)
-type evar_universe_context =
- { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t;
- uctx_local : Univ.universe_context_set; (** The local context of variables *)
- uctx_univ_variables : Universes.universe_opt_subst;
- (** The local universes that are unification variables *)
- uctx_univ_algebraic : Univ.universe_set;
- (** The subset of unification variables that
- can be instantiated with algebraic universes as they appear in types
- and universe instances only. *)
- uctx_universes : Univ.universes; (** The current graph extended with the local constraints *)
- uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *)
- }
-
-let empty_evar_universe_context =
- { uctx_names = UNameMap.empty, Univ.LMap.empty;
- uctx_local = Univ.ContextSet.empty;
- uctx_univ_variables = Univ.LMap.empty;
- uctx_univ_algebraic = Univ.LSet.empty;
- uctx_universes = Univ.initial_universes;
- uctx_initial_universes = Univ.initial_universes }
-
-let evar_universe_context_from e =
- let u = universes e in
- {empty_evar_universe_context with
- uctx_universes = u; uctx_initial_universes = u}
-
-let is_empty_evar_universe_context ctx =
- Univ.ContextSet.is_empty ctx.uctx_local &&
- Univ.LMap.is_empty ctx.uctx_univ_variables
-
-let union_evar_universe_context ctx ctx' =
- if ctx == ctx' then ctx
- else if is_empty_evar_universe_context ctx' then ctx
- else
- let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in
- let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in
- let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local)
- (Univ.ContextSet.levels ctx.uctx_local) in
- let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in
- let declarenew g =
- Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g
- in
- let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in
- { uctx_names = (names, names_rev);
- uctx_local = local;
- uctx_univ_variables =
- Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables;
- uctx_univ_algebraic =
- Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic;
- uctx_initial_universes = declarenew ctx.uctx_initial_universes;
- uctx_universes =
- if local == ctx.uctx_local then ctx.uctx_universes
- else
- let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in
- Univ.merge_constraints cstrsr (declarenew ctx.uctx_universes) }
-
-(* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *)
-(* let union_evar_universe_context = *)
-(* Profile.profile2 union_evar_universe_context_key union_evar_universe_context;; *)
-
+type evar_universe_context = UState.t
type 'a in_evar_universe_context = 'a * evar_universe_context
-let evar_universe_context_set diff ctx =
- let initctx = ctx.uctx_local in
- let cstrs =
- Univ.LSet.fold
- (fun l cstrs ->
- try
- match Univ.LMap.find l ctx.uctx_univ_variables with
- | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs
- | None -> cstrs
- with Not_found | Option.IsNone -> cstrs)
- (Univ.Instance.levels (Univ.UContext.instance diff)) Univ.Constraint.empty
- in
- Univ.ContextSet.add_constraints cstrs initctx
-
-let evar_universe_context_constraints ctx = snd ctx.uctx_local
-let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_local
-
-let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx }
-let evar_universe_context_subst ctx = ctx.uctx_univ_variables
-
-let add_uctx_names s l (names, names_rev) =
- (UNameMap.add s l names, Univ.LMap.add l s names_rev)
-
-let evar_universe_context_of_binders b =
- let ctx = empty_evar_universe_context in
- let names =
- List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc)
- ctx.uctx_names b
- in { ctx with uctx_names = names }
-
-let instantiate_variable l b v =
- v := Univ.LMap.add l (Some b) !v
-
-exception UniversesDiffer
-
-let process_universe_constraints univs vars alg cstrs =
- let vars = ref vars in
- let normalize = Universes.normalize_universe_opt_subst vars in
- let rec unify_universes fo l d r local =
- let l = normalize l and r = normalize r in
- if Univ.Universe.equal l r then local
- else
- let varinfo x =
- match Univ.Universe.level x with
- | None -> Inl x
- | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg)
- in
- if d == Universes.ULe then
- if Univ.check_leq univs l r then
- (** Keep Prop/Set <= var around if var might be instantiated by prop or set
- later. *)
- if Univ.Universe.is_level l then
- match Univ.Universe.level r with
- | Some r ->
- Univ.Constraint.add (Option.get (Univ.Universe.level l),Univ.Le,r) local
- | _ -> local
- else local
- else
- match Univ.Universe.level r with
- | None -> error ("Algebraic universe on the right")
- | Some rl ->
- if Univ.Level.is_small rl then
- let levels = Univ.Universe.levels l in
- Univ.LSet.fold (fun l local ->
- if Univ.Level.is_small l || Univ.LMap.mem l !vars then
- unify_universes fo (Univ.Universe.make l) Universes.UEq r local
- else raise (Univ.UniverseInconsistency (Univ.Le, Univ.Universe.make l, r, None)))
- levels local
- else
- Univ.enforce_leq l r local
- else if d == Universes.ULub then
- match varinfo l, varinfo r with
- | (Inr (l, true, _), Inr (r, _, _))
- | (Inr (r, _, _), Inr (l, true, _)) ->
- instantiate_variable l (Univ.Universe.make r) vars;
- Univ.enforce_eq_level l r local
- | Inr (_, _, _), Inr (_, _, _) ->
- unify_universes true l Universes.UEq r local
- | _, _ -> assert false
- else (* d = Universes.UEq *)
- match varinfo l, varinfo r with
- | Inr (l', lloc, _), Inr (r', rloc, _) ->
- let () =
- if lloc then
- instantiate_variable l' r vars
- else if rloc then
- instantiate_variable r' l vars
- else if not (Univ.check_eq univs l r) then
- (* Two rigid/global levels, none of them being local,
- one of them being Prop/Set, disallow *)
- if Univ.Level.is_small l' || Univ.Level.is_small r' then
- raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None))
- else
- if fo then
- raise UniversesDiffer
- in
- Univ.enforce_eq_level l' r' local
- | Inr (l, loc, alg), Inl r
- | Inl r, Inr (l, loc, alg) ->
- let inst = Univ.univ_level_rem l r r in
- if alg then (instantiate_variable l inst vars; local)
- else
- let lu = Univ.Universe.make l in
- if Univ.univ_level_mem l r then
- Univ.enforce_leq inst lu local
- else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None))
- | _, _ (* One of the two is algebraic or global *) ->
- if Univ.check_eq univs l r then local
- else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None))
- in
- let local =
- Universes.Constraints.fold (fun (l,d,r) local -> unify_universes false l d r local)
- cstrs Univ.Constraint.empty
- in
- !vars, local
-
-let add_constraints_context ctx cstrs =
- let univs, local = ctx.uctx_local in
- let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc ->
- let l = Univ.Universe.make l and r = Univ.Universe.make r in
- let cstr' =
- if d == Univ.Lt then (Univ.Universe.super l, Universes.ULe, r)
- else (l, (if d == Univ.Le then Universes.ULe else Universes.UEq), r)
- in Universes.Constraints.add cstr' acc)
- cstrs Universes.Constraints.empty
- in
- let vars, local' =
- process_universe_constraints ctx.uctx_universes
- ctx.uctx_univ_variables ctx.uctx_univ_algebraic
- cstrs'
- in
- { ctx with uctx_local = (univs, Univ.Constraint.union local local');
- uctx_univ_variables = vars;
- uctx_universes = Univ.merge_constraints local' ctx.uctx_universes }
-
-(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *)
-(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *)
-
-let add_universe_constraints_context ctx cstrs =
- let univs, local = ctx.uctx_local in
- let vars, local' =
- process_universe_constraints ctx.uctx_universes
- ctx.uctx_univ_variables ctx.uctx_univ_algebraic
- cstrs
- in
- { ctx with uctx_local = (univs, Univ.Constraint.union local local');
- uctx_univ_variables = vars;
- uctx_universes = Univ.merge_constraints local' ctx.uctx_universes }
+let empty_evar_universe_context = UState.empty
+let is_empty_evar_universe_context = UState.is_empty
+let union_evar_universe_context = UState.union
+let evar_universe_context_set = UState.context_set
+let evar_universe_context_constraints = UState.constraints
+let evar_context_universe_context = UState.context
+let evar_universe_context_of = UState.of_context_set
+let evar_universe_context_subst = UState.subst
+let add_constraints_context = UState.add_constraints
+let add_universe_constraints_context = UState.add_universe_constraints
+let constrain_variables = UState.constrain_variables
+let evar_universe_context_of_binders = UState.of_binders
(* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *)
(* let add_universe_constraints_context = *)
@@ -648,14 +438,30 @@ let reassign_name_defined evk evk' (evtoid,idtoev) =
(EvMap.add evk' id (EvMap.remove evk evtoid),
Idmap.add id evk' (Idmap.remove id idtoev))
-let add d e i = match i.evar_body with
+let add_with_name ?(naming = Misctypes.IntroAnonymous) d e i = match i.evar_body with
| Evar_empty ->
- let evar_names = add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in
+ let evar_names = add_name_undefined naming e i d.evar_names in
{ d with undf_evars = EvMap.add e i d.undf_evars; evar_names }
| Evar_defined _ ->
let evar_names = remove_name_possibly_already_defined e d.evar_names in
{ d with defn_evars = EvMap.add e i d.defn_evars; evar_names }
+let add d e i = add_with_name d e i
+
+(** New evars *)
+
+let evar_counter_summary_name = "evar counter"
+
+(* Generator of existential names *)
+let new_untyped_evar =
+ let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in
+ fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr
+
+let new_evar evd ?naming evi =
+ let evk = new_untyped_evar () in
+ let evd = add_with_name evd ?naming evk evi in
+ (evd, evk)
+
let remove d e =
let undf_evars = EvMap.remove e d.undf_evars in
let defn_evars = EvMap.remove e d.defn_evars in
@@ -766,10 +572,6 @@ let cmap f evd =
(* spiwack: deprecated *)
let create_evar_defs sigma = { sigma with
conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty }
-(* spiwack: tentatively deprecated *)
-let create_goal_evar_defs sigma = { sigma with
- (* conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty } *)
- metas=Metamap.empty }
let empty = {
defn_evars = EvMap.empty;
@@ -786,7 +588,7 @@ let empty = {
}
let from_env e =
- { empty with universes = evar_universe_context_from e }
+ { empty with universes = UState.make (Environ.universes e) }
let from_ctx ctx = { empty with universes = ctx }
@@ -847,27 +649,8 @@ let define evk body evd =
let evar_names = remove_name_defined evk evd.evar_names in
{ evd with defn_evars; undf_evars; last_mods; evar_names }
-let evar_declare hyps evk ty ?(src=(Loc.ghost,Evar_kinds.InternalHole))
- ?(filter=Filter.identity) ?candidates ?(store=Store.empty)
- ?(naming=Misctypes.IntroAnonymous) evd =
- let () = match Filter.repr filter with
- | None -> ()
- | Some filter ->
- assert (Int.equal (List.length filter) (List.length (named_context_of_val hyps)))
- in
- let evar_info = {
- evar_hyps = hyps;
- evar_concl = ty;
- evar_body = Evar_empty;
- evar_filter = filter;
- evar_source = src;
- evar_candidates = candidates;
- evar_extra = store; }
- in
- let evar_names = add_name_newly_undefined naming evk evar_info evd.evar_names in
- { evd with undf_evars = EvMap.add evk evar_info evd.undf_evars; evar_names }
-
-let restrict evk evk' filter ?candidates evd =
+let restrict evk filter ?candidates evd =
+ let evk' = new_untyped_evar () in
let evar_info = EvMap.find evk evd.undf_evars in
let evar_info' =
{ evar_info with evar_filter = filter;
@@ -879,7 +662,7 @@ let restrict evk evk' filter ?candidates evd =
let body = mkEvar(evk',id_inst) in
let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in
{ evd with undf_evars = EvMap.add evk' evar_info' undf_evars;
- defn_evars; evar_names }
+ defn_evars; evar_names }, evk'
let downcast evk ccl evd =
let evar_info = EvMap.find evk evd.undf_evars in
@@ -954,7 +737,7 @@ let evars_of_filtered_evar_info evi =
(**********************************************************)
(* Sort variables *)
-type rigid =
+type rigid = UState.rigid =
| UnivRigid
| UnivFlexible of bool (** Is substitution by an algebraic ok? *)
@@ -964,132 +747,32 @@ let univ_flexible_alg = UnivFlexible true
let evar_universe_context d = d.universes
-let universe_context_set d = d.universes.uctx_local
-
-let pr_uctx_level uctx =
- let map, map_rev = uctx.uctx_names in
- fun l ->
- try str(Univ.LMap.find l map_rev)
- with Not_found ->
- Universes.pr_with_global_universes l
-
-let universe_context ?names evd =
- match names with
- | None -> [], Univ.ContextSet.to_context evd.universes.uctx_local
- | Some pl ->
- let levels = Univ.ContextSet.levels evd.universes.uctx_local in
- let newinst, map, left =
- List.fold_right
- (fun (loc,id) (newinst, map, acc) ->
- let l =
- try UNameMap.find (Id.to_string id) (fst evd.universes.uctx_names)
- with Not_found ->
- user_err_loc (loc, "universe_context",
- str"Universe " ++ pr_id id ++ str" is not bound anymore.")
- in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc))
- pl ([], [], levels)
- in
- if not (Univ.LSet.is_empty left) then
- let n = Univ.LSet.cardinal left in
- errorlabstrm "universe_context"
- (str(CString.plural n "Universe") ++ spc () ++
- Univ.LSet.pr (pr_uctx_level evd.universes) left ++
- spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")
- else
- let inst = Univ.Instance.of_array (Array.of_list newinst) in
- let ctx = Univ.UContext.make (inst,
- Univ.ContextSet.constraints evd.universes.uctx_local)
- in map, ctx
+let universe_context_set d = UState.context_set d.universes
+
+let pr_uctx_level = UState.pr_uctx_level
+let universe_context ?names evd = UState.universe_context ?names evd.universes
let restrict_universe_context evd vars =
- let uctx = evd.universes in
- let uctx' = Universes.restrict_universe_context uctx.uctx_local vars in
- { evd with universes = { uctx with uctx_local = uctx' } }
-
+ { evd with universes = UState.restrict evd.universes vars }
+
let universe_subst evd =
- evd.universes.uctx_univ_variables
-
-let merge_uctx sideff rigid uctx ctx' =
- let open Univ in
- let levels = ContextSet.levels ctx' in
- let uctx = if sideff then uctx else
- match rigid with
- | UnivRigid -> uctx
- | UnivFlexible b ->
- let fold u accu =
- if LMap.mem u accu then accu
- else LMap.add u None accu
- in
- let uvars' = LSet.fold fold levels uctx.uctx_univ_variables in
- if b then
- { uctx with uctx_univ_variables = uvars';
- uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels }
- else { uctx with uctx_univ_variables = uvars' }
- in
- let uctx_local =
- if sideff then uctx.uctx_local
- else ContextSet.append ctx' uctx.uctx_local
- in
- let declare g =
- LSet.fold (fun u g ->
- try Univ.add_universe u false g
- with Univ.AlreadyDeclared when sideff -> g)
- levels g
- in
- let initial = declare uctx.uctx_initial_universes in
- let univs = declare uctx.uctx_universes in
- let uctx_universes = merge_constraints (ContextSet.constraints ctx') univs in
- { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial }
+ UState.subst evd.universes
let merge_context_set ?(sideff=false) rigid evd ctx' =
- {evd with universes = merge_uctx sideff rigid evd.universes ctx'}
+ {evd with universes = UState.merge sideff rigid evd.universes ctx'}
-let merge_uctx_subst uctx s =
- { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s }
-
let merge_universe_subst evd subst =
- {evd with universes = merge_uctx_subst evd.universes subst }
+ {evd with universes = UState.merge_subst evd.universes subst }
let with_context_set rigid d (a, ctx) =
(merge_context_set rigid d ctx, a)
-let emit_universe_side_effects eff u =
- let uctxs = Safe_typing.universes_of_private eff in
- List.fold_left (merge_uctx true univ_rigid) u uctxs
-
-let uctx_new_univ_variable rigid name predicative
- ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) =
- let u = Universes.new_univ_level (Global.current_dirpath ()) in
- let ctx' = Univ.ContextSet.add_universe u ctx in
- let uctx', pred =
- match rigid with
- | UnivRigid -> uctx, true
- | UnivFlexible b ->
- let uvars' = Univ.LMap.add u None uvars in
- if b then {uctx with uctx_univ_variables = uvars';
- uctx_univ_algebraic = Univ.LSet.add u avars}, false
- else {uctx with uctx_univ_variables = uvars'}, false
- in
- let names =
- match name with
- | Some n -> add_uctx_names n u uctx.uctx_names
- | None -> uctx.uctx_names
- in
- let initial =
- Univ.add_universe u false uctx.uctx_initial_universes
- in
- let uctx' =
- {uctx' with uctx_names = names; uctx_local = ctx';
- uctx_universes = Univ.add_universe u false uctx.uctx_universes;
- uctx_initial_universes = initial}
- in uctx', u
-
let new_univ_level_variable ?name ?(predicative=true) rigid evd =
- let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in
+ let uctx', u = UState.new_univ_variable rigid name evd.universes in
({evd with universes = uctx'}, u)
let new_univ_variable ?name ?(predicative=true) rigid evd =
- let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in
+ let uctx', u = UState.new_univ_variable rigid name evd.universes in
({evd with universes = uctx'}, Univ.Universe.make u)
let new_sort_variable ?name ?(predicative=true) rigid d =
@@ -1097,43 +780,21 @@ let new_sort_variable ?name ?(predicative=true) rigid d =
(d', Type u)
let add_global_univ d u =
- let uctx = d.universes in
- let initial =
- Univ.add_universe u true uctx.uctx_initial_universes
- in
- let univs =
- Univ.add_universe u true uctx.uctx_universes
- in
- { d with universes = { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local;
- uctx_initial_universes = initial;
- uctx_universes = univs } }
-
+ { d with universes = UState.add_global_univ d.universes u }
+
let make_flexible_variable evd b u =
- let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in
- let uvars' = Univ.LMap.add u None uvars in
- let avars' =
- if b then
- let uu = Univ.Universe.make u in
- let substu_not_alg u' v =
- Option.cata (fun vu -> Univ.Universe.equal uu vu && not (Univ.LSet.mem u' avars)) false v
- in
- if not (Univ.LMap.exists substu_not_alg uvars)
- then Univ.LSet.add u avars else avars
- else avars
- in
- {evd with universes = {ctx with uctx_univ_variables = uvars';
- uctx_univ_algebraic = avars'}}
-
-let make_evar_universe_context e l =
- let uctx = evar_universe_context_from e in
- match l with
- | None -> uctx
- | Some us ->
- List.fold_left
- (fun uctx (loc,id) ->
- fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) true uctx))
- uctx us
-
+ { evd with universes = UState.make_flexible_variable evd.universes b u }
+
+let make_evar_universe_context e l =
+ let uctx = UState.make (Environ.universes e) in
+ match l with
+ | None -> uctx
+ | Some us ->
+ List.fold_left
+ (fun uctx (loc,id) ->
+ fst (UState.new_univ_variable univ_rigid (Some (Id.to_string id)) uctx))
+ uctx us
+
(****************************************)
(* Operations on constants *)
(****************************************)
@@ -1155,20 +816,11 @@ let fresh_global ?(rigid=univ_flexible) ?names env evd gr =
let whd_sort_variable evd t = t
-let is_sort_variable evd s =
- match s with
- | Type u ->
- (match Univ.universe_level u with
- | Some l as x ->
- let uctx = evd.universes in
- if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x
- else None
- | None -> None)
- | _ -> None
+let is_sort_variable evd s = UState.is_sort_variable evd.universes s
let is_flexible_level evd l =
let uctx = evd.universes in
- Univ.LMap.mem l uctx.uctx_univ_variables
+ Univ.LMap.mem l (UState.subst uctx)
let is_eq_sort s1 s2 =
if Sorts.equal s1 s2 then None
@@ -1179,12 +831,12 @@ let is_eq_sort s1 s2 =
else Some (u1, u2)
let normalize_universe evd =
- let vars = ref evd.universes.uctx_univ_variables in
+ let vars = ref (UState.subst evd.universes) in
let normalize = Universes.normalize_universe_opt_subst vars in
normalize
let normalize_universe_instance evd l =
- let vars = ref evd.universes.uctx_univ_variables in
+ let vars = ref (UState.subst evd.universes) in
let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in
Univ.Instance.subst_fn normalize l
@@ -1242,96 +894,28 @@ let set_leq_sort env evd s1 s2 =
else evd
let check_eq evd s s' =
- Univ.check_eq evd.universes.uctx_universes s s'
+ UGraph.check_eq (UState.ugraph evd.universes) s s'
let check_leq evd s s' =
- Univ.check_leq evd.universes.uctx_universes s s'
-
-let subst_univs_context_with_def def usubst (ctx, cst) =
- (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst)
+ UGraph.check_leq (UState.ugraph evd.universes) s s'
-let normalize_evar_universe_context_variables uctx =
- let normalized_variables, undef, def, subst =
- Universes.normalize_univ_variables uctx.uctx_univ_variables
- in
- let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in
- let ctx_local', univs = Universes.refresh_constraints uctx.uctx_initial_universes ctx_local in
- subst, { uctx with uctx_local = ctx_local';
- uctx_univ_variables = normalized_variables;
- uctx_universes = univs }
+let normalize_evar_universe_context_variables = UState.normalize_variables
(* let normvarsconstrkey = Profile.declare_profile "normalize_evar_universe_context_variables";; *)
(* let normalize_evar_universe_context_variables = *)
(* Profile.profile1 normvarsconstrkey normalize_evar_universe_context_variables;; *)
-let abstract_undefined_variables uctx =
- let vars' =
- Univ.LMap.fold (fun u v acc ->
- if v == None then Univ.LSet.remove u acc
- else acc)
- uctx.uctx_univ_variables uctx.uctx_univ_algebraic
- in { uctx with uctx_local = Univ.ContextSet.empty;
- uctx_univ_algebraic = vars' }
-
-let fix_undefined_variables ({ universes = uctx } as evm) =
- let algs', vars' =
- Univ.LMap.fold (fun u v (algs, vars as acc) ->
- if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars)
- else acc)
- uctx.uctx_univ_variables
- (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables)
- in
- {evm with universes =
- { uctx with uctx_univ_variables = vars';
- uctx_univ_algebraic = algs' } }
+let abstract_undefined_variables = UState.abstract_undefined_variables
-
-let refresh_undefined_univ_variables uctx =
- let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in
- let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc)
- uctx.uctx_univ_algebraic Univ.LSet.empty
- in
- let vars =
- Univ.LMap.fold
- (fun u v acc ->
- Univ.LMap.add (Univ.subst_univs_level_level subst u)
- (Option.map (Univ.subst_univs_level_universe subst) v) acc)
- uctx.uctx_univ_variables Univ.LMap.empty
- in
- let declare g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g)
- (Univ.ContextSet.levels ctx') g in
- let initial = declare uctx.uctx_initial_universes in
- let univs = declare Univ.initial_universes in
- let uctx' = {uctx_names = uctx.uctx_names;
- uctx_local = ctx';
- uctx_univ_variables = vars; uctx_univ_algebraic = alg;
- uctx_universes = univs;
- uctx_initial_universes = initial } in
- uctx', subst
+let fix_undefined_variables evd =
+ { evd with universes = UState.fix_undefined_variables evd.universes }
let refresh_undefined_universes evd =
- let uctx', subst = refresh_undefined_univ_variables evd.universes in
+ let uctx', subst = UState.refresh_undefined_univ_variables evd.universes in
let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in
evd', subst
-let normalize_evar_universe_context uctx =
- let rec fixpoint uctx =
- let ((vars',algs'), us') =
- Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables
- uctx.uctx_univ_algebraic
- in
- if Univ.ContextSet.equal us' uctx.uctx_local then uctx
- else
- let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in
- let uctx' =
- { uctx_names = uctx.uctx_names;
- uctx_local = us';
- uctx_univ_variables = vars';
- uctx_univ_algebraic = algs';
- uctx_universes = universes;
- uctx_initial_universes = uctx.uctx_initial_universes }
- in fixpoint uctx'
- in fixpoint uctx
+let normalize_evar_universe_context = UState.normalize
let nf_univ_variables evd =
let subst, uctx' = normalize_evar_universe_context_variables evd.universes in
@@ -1349,14 +933,12 @@ let nf_constraints =
Profile.profile1 nfconstrkey nf_constraints
else nf_constraints
-let universe_of_name evd s =
- UNameMap.find s (fst evd.universes.uctx_names)
+let universe_of_name evd s = UState.universe_of_name evd.universes s
let add_universe_name evd s l =
- let names' = add_uctx_names s l evd.universes.uctx_names in
- {evd with universes = {evd.universes with uctx_names = names'}}
+ { evd with universes = UState.add_universe_name evd.universes s l }
-let universes evd = evd.universes.uctx_universes
+let universes evd = UState.ugraph evd.universes
(* Conversion w.r.t. an evar map and its local universes. *)
@@ -1365,10 +947,10 @@ let conversion_gen env evd pb t u =
| Reduction.CONV ->
Reduction.trans_conv_universes
full_transparent_state ~evars:(existential_opt_value evd) env
- evd.universes.uctx_universes t u
+ (UState.ugraph evd.universes) t u
| Reduction.CUMUL -> Reduction.trans_conv_leq_universes
full_transparent_state ~evars:(existential_opt_value evd) env
- evd.universes.uctx_universes t u
+ (UState.ugraph evd.universes) t u
(* let conversion_gen_key = Profile.declare_profile "conversion_gen" *)
(* let conversion_gen = Profile.profile5 conversion_gen_key conversion_gen *)
@@ -1380,8 +962,10 @@ let test_conversion env d pb t u =
try conversion_gen env d pb t u; true
with _ -> false
+exception UniversesDiffer = UState.UniversesDiffer
+
let eq_constr_univs evd t u =
- let b, c = Universes.eq_constr_univs_infer evd.universes.uctx_universes t u in
+ let b, c = Universes.eq_constr_univs_infer (UState.ugraph evd.universes) t u in
if b then
try let evd' = add_universe_constraints evd c in evd', b
with Univ.UniverseInconsistency _ | UniversesDiffer -> evd, false
@@ -1396,7 +980,7 @@ let e_eq_constr_univs evdref t u =
let emit_side_effects eff evd =
{ evd with effects = Safe_typing.concat_private eff evd.effects;
- universes = emit_universe_side_effects eff evd.universes }
+ universes = UState.emit_side_effects eff evd.universes }
let drop_side_effects evd =
{ evd with effects = Safe_typing.empty_private_constants; }
@@ -1513,39 +1097,6 @@ let meta_reassign mv (v, pb) evd =
let meta_name evd mv =
try fst (clb_name (Metamap.find mv evd.metas)) with Not_found -> Anonymous
-let explain_no_such_bound_variable evd id =
- let mvl =
- List.rev (Metamap.fold (fun n clb l ->
- let na = fst (clb_name clb) in
- if na != Anonymous then out_name na :: l else l)
- evd.metas []) in
- errorlabstrm "Evd.meta_with_name"
- (str"No such bound variable " ++ pr_id id ++
- (if mvl == [] then str " (no bound variables at all in the expression)."
- else
- (str" (possible name" ++
- str (if List.length mvl == 1 then " is: " else "s are: ") ++
- pr_enum pr_id mvl ++ str").")))
-
-let meta_with_name evd id =
- let na = Name id in
- let (mvl,mvnodef) =
- Metamap.fold
- (fun n clb (l1,l2 as l) ->
- let (na',def) = clb_name clb in
- if Name.equal na na' then if def then (n::l1,l2) else (n::l1,n::l2)
- else l)
- evd.metas ([],[]) in
- match mvnodef, mvl with
- | _,[] ->
- explain_no_such_bound_variable evd id
- | ([n],_|_,[n]) ->
- n
- | _ ->
- errorlabstrm "Evd.meta_with_name"
- (str "Binder name \"" ++ pr_id id ++
- strbrk "\" occurs more than once in clause.")
-
let clear_metas evd = {evd with metas = Metamap.empty}
let meta_merge evd1 evd2 =
@@ -1566,18 +1117,6 @@ let retract_coercible_metas evd =
let metas = Metamap.smartmapi map evd.metas in
!mc, set_metas evd metas
-let subst_defined_metas_evars (bl,el) c =
- let rec substrec c = match kind_of_term c with
- | Meta i ->
- let select (j,_,_) = Int.equal i j in
- substrec (pi2 (List.find select bl))
- | Evar (evk,args) ->
- let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in
- (try substrec (pi3 (List.find select el))
- with Not_found -> map_constr substrec c)
- | _ -> map_constr substrec c
- in try Some (substrec c) with Not_found -> None
-
let evar_source_of_meta mv evd =
match meta_name evd mv with
| Anonymous -> (Loc.ghost,Evar_kinds.GoalEvar)
@@ -1808,11 +1347,11 @@ let pr_evar_universe_context ctx =
if is_empty_evar_universe_context ctx then mt ()
else
(str"UNIVERSES:"++brk(0,1)++
- h 0 (Univ.pr_universe_context_set prl ctx.uctx_local) ++ fnl () ++
+ h 0 (Univ.pr_universe_context_set prl (evar_universe_context_set ctx)) ++ fnl () ++
str"ALGEBRAIC UNIVERSES:"++brk(0,1)++
- h 0 (Univ.LSet.pr prl ctx.uctx_univ_algebraic) ++ fnl() ++
+ h 0 (Univ.LSet.pr prl (UState.algebraics ctx)) ++ fnl() ++
str"UNDEFINED UNIVERSES:"++brk(0,1)++
- h 0 (Universes.pr_universe_opt_subst ctx.uctx_univ_variables) ++ fnl())
+ h 0 (Universes.pr_universe_opt_subst (UState.subst ctx)) ++ fnl())
let print_env_short env =
let pr_body n = function
diff --git a/pretyping/evd.mli b/engine/evd.mli
index 3c16b27ad..b295a431a 100644
--- a/pretyping/evd.mli
+++ b/engine/evd.mli
@@ -119,7 +119,7 @@ val map_evar_info : (constr -> constr) -> evar_info -> evar_info
(** {6 Unification state} **)
-type evar_universe_context
+type evar_universe_context = UState.t
(** The universe context associated to an evar map *)
type evar_map
@@ -143,6 +143,10 @@ val has_undefined : evar_map -> bool
(** [has_undefined sigma] is [true] if and only if
there are uninstantiated evars in [sigma]. *)
+val new_evar : evar_map ->
+ ?naming:Misctypes.intro_pattern_naming_expr -> evar_info -> evar_map * evar
+(** Creates a fresh evar mapping to the given information. *)
+
val add : evar_map -> evar -> evar_info -> evar_map
(** [add sigma ev info] adds [ev] with evar info [info] in sigma.
Precondition: ev must not preexist in [sigma]. *)
@@ -230,14 +234,8 @@ val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool ->
(** {6 Misc} *)
-val evar_declare :
- named_context_val -> evar -> types -> ?src:Loc.t * Evar_kinds.t ->
- ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t ->
- ?naming:Misctypes.intro_pattern_naming_expr -> evar_map -> evar_map
-(** Convenience function. Just a wrapper around {!add}. *)
-
-val restrict : evar -> evar -> Filter.t -> ?candidates:constr list ->
- evar_map -> evar_map
+val restrict : evar -> Filter.t -> ?candidates:constr list ->
+ evar_map -> evar_map * evar
(** Restrict an undefined evar into a new evar by filtering context and
possibly limiting the instances to a set of candidates *)
@@ -442,7 +440,6 @@ val meta_opt_fvalue : evar_map -> metavariable -> (constr freelisted * instance_
val meta_type : evar_map -> metavariable -> types
val meta_ftype : evar_map -> metavariable -> types freelisted
val meta_name : evar_map -> metavariable -> Name.t
-val meta_with_name : evar_map -> Id.t -> metavariable
val meta_declare :
metavariable -> types -> ?name:Name.t -> evar_map -> evar_map
val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map
@@ -459,7 +456,6 @@ val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map
type metabinding = metavariable * constr * instance_status
val retract_coercible_metas : evar_map -> metabinding list * evar_map
-val subst_defined_metas_evars : metabinding list * ('a * existential * constr) list -> constr -> constr option
(** {5 FIXME: Nothing to do here} *)
@@ -468,7 +464,7 @@ val subst_defined_metas_evars : metabinding list * ('a * existential * constr) l
(** Rigid or flexible universe variables *)
-type rigid =
+type rigid = UState.rigid =
| UnivRigid
| UnivFlexible of bool (** Is substitution by an algebraic ok? *)
@@ -478,7 +474,7 @@ val univ_flexible_alg : rigid
type 'a in_evar_universe_context = 'a * evar_universe_context
-val evar_universe_context_set : Univ.universe_context -> evar_universe_context -> Univ.universe_context_set
+val evar_universe_context_set : evar_universe_context -> Univ.universe_context_set
val evar_universe_context_constraints : evar_universe_context -> Univ.constraints
val evar_context_universe_context : evar_universe_context -> Univ.universe_context
val evar_universe_context_of : Univ.universe_context_set -> evar_universe_context
@@ -486,6 +482,8 @@ val empty_evar_universe_context : evar_universe_context
val union_evar_universe_context : evar_universe_context -> evar_universe_context ->
evar_universe_context
val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst
+val constrain_variables : Univ.LSet.t -> evar_universe_context -> Univ.constraints
+
val evar_universe_context_of_binders :
Universes.universe_binders -> evar_universe_context
@@ -496,7 +494,7 @@ val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map
val universe_of_name : evar_map -> string -> Univ.universe_level
val add_universe_name : evar_map -> string -> Univ.universe_level -> evar_map
-val universes : evar_map -> Univ.universes
+val universes : evar_map -> UGraph.t
val add_constraints_context : evar_universe_context ->
Univ.constraints -> evar_universe_context
@@ -540,7 +538,7 @@ val universe_context_set : evar_map -> Univ.universe_context_set
val universe_context : ?names:(Id.t located) list -> evar_map ->
(Id.t * Univ.Level.t) list * Univ.universe_context
val universe_subst : evar_map -> Universes.universe_opt_subst
-val universes : evar_map -> Univ.universes
+val universes : evar_map -> UGraph.t
val merge_universe_context : evar_map -> evar_universe_context -> evar_map
@@ -619,4 +617,6 @@ val pr_evd_level : evar_map -> Univ.Level.t -> Pp.std_ppcmds
val create_evar_defs : evar_map -> evar_map
(** Create an [evar_map] with empty meta map: *)
-val create_goal_evar_defs : evar_map -> evar_map
+(** {5 Summary names} *)
+
+val evar_counter_summary_name : string
diff --git a/proofs/logic_monad.ml b/engine/logic_monad.ml
index e3caa886a..75134e6f1 100644
--- a/proofs/logic_monad.ml
+++ b/engine/logic_monad.ml
@@ -138,46 +138,13 @@ end
(** A view type for the logical monad, which is a form of list, hence
we can decompose it with as a list. *)
-type ('a, 'b) list_view =
- | Nil of Exninfo.iexn
- | Cons of 'a * 'b
+type ('a, 'b, 'e) list_view =
+ | Nil of 'e
+ | Cons of 'a * ('e -> 'b)
-module type Param = sig
-
- (** Read only *)
- type e
-
- (** Write only *)
- type w
-
- (** [w] must be a monoid *)
- val wunit : w
- val wprod : w -> w -> w
-
- (** Read-write *)
- type s
-
- (** Update-only. Essentially a writer on [u->u]. *)
- type u
-
- (** [u] must be pointed. *)
- val uunit : u
-
-end
-
-
-module Logical (P:Param) =
+module BackState =
struct
- (** All three of environment, writer and state are coded as a single
- state-passing-style monad.*)
- type state = {
- rstate : P.e;
- ustate : P.u;
- wstate : P.w;
- sstate : P.s;
- }
-
(** Double-continuation backtracking monads are reasonable folklore
for "search" implementations (including the Tac interactive
prover's tactics). Yet it's quite hard to wrap your head around
@@ -208,32 +175,25 @@ struct
In that vision, [bind] is simply [concat_map] (though the cps
version is significantly simpler), [plus] is concatenation, and
[split] is pattern-matching. *)
- type rich_exn = Exninfo.iexn
-
- type 'a iolist =
- { iolist : 'r. state -> (rich_exn -> 'r NonLogical.t) ->
- ('a -> state -> (rich_exn -> 'r NonLogical.t) -> 'r NonLogical.t) ->
- 'r NonLogical.t }
-
- include Monad.Make(struct
- type 'a t = 'a iolist
+ type ('a, 'i, 'o, 'e) t =
+ { iolist : 'r. 'i -> ('e -> 'r NonLogical.t) ->
+ ('a -> 'o -> ('e -> 'r NonLogical.t) -> 'r NonLogical.t) ->
+ 'r NonLogical.t }
- let return x =
- { iolist = fun s nil cons -> cons x s nil }
+ let return x =
+ { iolist = fun s nil cons -> cons x s nil }
- let (>>=) m f =
- { iolist = fun s nil cons ->
- m.iolist s nil (fun x s next -> (f x).iolist s next cons) }
+ let (>>=) m f =
+ { iolist = fun s nil cons ->
+ m.iolist s nil (fun x s next -> (f x).iolist s next cons) }
- let (>>) m f =
- { iolist = fun s nil cons ->
- m.iolist s nil (fun () s next -> f.iolist s next cons) }
+ let (>>) m f =
+ { iolist = fun s nil cons ->
+ m.iolist s nil (fun () s next -> f.iolist s next cons) }
- let map f m =
- { iolist = fun s nil cons -> m.iolist s nil (fun x s next -> cons (f x) s next) }
-
- end)
+ let map f m =
+ { iolist = fun s nil cons -> m.iolist s nil (fun x s next -> cons (f x) s next) }
let zero e =
{ iolist = fun _ nil cons -> nil e }
@@ -250,27 +210,21 @@ struct
(** State related *)
let get =
- { iolist = fun s nil cons -> cons s.sstate s nil }
+ { iolist = fun s nil cons -> cons s s nil }
- let set (sstate : P.s) =
- { iolist = fun s nil cons -> cons () { s with sstate } nil }
+ let set s =
+ { iolist = fun _ nil cons -> cons () s nil }
- let modify (f : P.s -> P.s) =
- { iolist = fun s nil cons -> cons () { s with sstate = f s.sstate } nil }
+ let modify f =
+ { iolist = fun s nil cons -> cons () (f s) nil }
- let current =
- { iolist = fun s nil cons -> cons s.rstate s nil }
+ (** Exception manipulation *)
- let local e m =
+ let interleave src dst m =
{ iolist = fun s nil cons ->
- m.iolist { s with rstate = e } nil
- (fun x s' next -> cons x {s' with rstate = s.rstate} next) }
-
- let put w =
- { iolist = fun s nil cons -> cons () { s with wstate = P.wprod s.wstate w } nil }
-
- let update (f : P.u -> P.u) =
- { iolist = fun s nil cons -> cons () { s with ustate = f s.ustate } nil }
+ m.iolist s (fun e1 -> nil (src e1))
+ (fun x s next -> cons x s (fun e2 -> next (dst e2)))
+ }
(** List observation *)
@@ -284,9 +238,9 @@ struct
(** For [reflect] and [split] see the "Backtracking, Interleaving,
and Terminating Monad Transformers" paper. *)
- type 'a reified = ('a, rich_exn -> 'a reified) list_view NonLogical.t
+ type ('a, 'e) reified = ('a, ('a, 'e) reified, 'e) list_view NonLogical.t
- let rec reflect (m : ('a * state) reified) : 'a iolist =
+ let rec reflect (m : ('a * 'o, 'e) reified) =
{ iolist = fun s0 nil cons ->
let next = function
| Nil e -> nil e
@@ -295,7 +249,7 @@ struct
NonLogical.(m >>= next)
}
- let split m : ('a, rich_exn -> 'a t) list_view t =
+ let split m : ((_, _, _) list_view, _, _, _) t =
let rnil e = NonLogical.return (Nil e) in
let rcons p s l = NonLogical.return (Cons ((p, s), l)) in
{ iolist = fun s nil cons ->
@@ -307,6 +261,117 @@ struct
cons (Cons (x, l)) s nil
end }
+ let run m s =
+ let rnil e = NonLogical.return (Nil e) in
+ let rcons x s l =
+ let p = (x, s) in
+ NonLogical.return (Cons (p, l))
+ in
+ m.iolist s rnil rcons
+
+ let repr x = x
+end
+
+module type Param = sig
+
+ (** Read only *)
+ type e
+
+ (** Write only *)
+ type w
+
+ (** [w] must be a monoid *)
+ val wunit : w
+ val wprod : w -> w -> w
+
+ (** Read-write *)
+ type s
+
+ (** Update-only. Essentially a writer on [u->u]. *)
+ type u
+
+ (** [u] must be pointed. *)
+ val uunit : u
+
+end
+
+
+module Logical (P:Param) =
+struct
+
+ module Unsafe =
+ struct
+ (** All three of environment, writer and state are coded as a single
+ state-passing-style monad.*)
+ type state = {
+ rstate : P.e;
+ ustate : P.u;
+ wstate : P.w;
+ sstate : P.s;
+ }
+
+ let make m = m
+ let repr m = m
+ end
+
+ open Unsafe
+
+ type state = Unsafe.state
+
+ type iexn = Exninfo.iexn
+
+ type 'a reified = ('a, iexn) BackState.reified
+
+ (** Inherited from Backstate *)
+
+ open BackState
+
+ include Monad.Make(struct
+ type 'a t = ('a, state, state, iexn) BackState.t
+ let return = BackState.return
+ let (>>=) = BackState.(>>=)
+ let (>>) = BackState.(>>)
+ let map = BackState.map
+ end)
+
+ let zero = BackState.zero
+ let plus = BackState.plus
+ let ignore = BackState.ignore
+ let lift = BackState.lift
+ let once = BackState.once
+ let break = BackState.break
+ let reflect = BackState.reflect
+ let split = BackState.split
+ let repr = BackState.repr
+
+ (** State related. We specialize them here to ensure soundness (for reader and
+ writer) and efficiency. *)
+
+ let get =
+ { iolist = fun s nil cons -> cons s.sstate s nil }
+
+ let set (sstate : P.s) =
+ { iolist = fun s nil cons -> cons () { s with sstate } nil }
+
+ let modify (f : P.s -> P.s) =
+ { iolist = fun s nil cons -> cons () { s with sstate = f s.sstate } nil }
+
+ let current =
+ { iolist = fun s nil cons -> cons s.rstate s nil }
+
+ let local e m =
+ { iolist = fun s nil cons ->
+ m.iolist { s with rstate = e } nil
+ (fun x s' next -> cons x {s' with rstate = s.rstate} next) }
+
+ let put w =
+ { iolist = fun s nil cons -> cons () { s with wstate = P.wprod s.wstate w } nil }
+
+ let update (f : P.u -> P.u) =
+ { iolist = fun s nil cons -> cons () { s with ustate = f s.ustate } nil }
+
+ (** Monadic run is specialized to handle reader / writer *)
+
let run m r s =
let s = { wstate = P.wunit; ustate = P.uunit; rstate = r; sstate = s } in
let rnil e = NonLogical.return (Nil e) in
@@ -316,6 +381,4 @@ struct
in
m.iolist s rnil rcons
- let repr x = x
-
end
diff --git a/proofs/logic_monad.mli b/engine/logic_monad.mli
index 84ffda753..42a84f830 100644
--- a/proofs/logic_monad.mli
+++ b/engine/logic_monad.mli
@@ -102,9 +102,48 @@ end
(** A view type for the logical monad, which is a form of list, hence
we can decompose it with as a list. *)
-type ('a, 'b) list_view =
-| Nil of Exninfo.iexn
-| Cons of 'a * 'b
+type ('a, 'b, 'e) list_view =
+| Nil of 'e
+| Cons of 'a * ('e -> 'b)
+
+module BackState : sig
+
+ type (+'a, -'i, +'o, 'e) t
+ val return : 'a -> ('a, 's, 's, 'e) t
+ val (>>=) : ('a, 'i, 'm, 'e) t -> ('a -> ('b, 'm, 'o, 'e) t) -> ('b, 'i, 'o, 'e) t
+ val (>>) : (unit, 'i, 'm, 'e) t -> ('b, 'm, 'o, 'e) t -> ('b, 'i, 'o, 'e) t
+ val map : ('a -> 'b) -> ('a, 'i, 'o, 'e) t -> ('b, 'i, 'o, 'e) t
+
+ val ignore : ('a, 'i, 'o, 'e) t -> (unit, 'i, 'o, 'e) t
+
+ val set : 'o -> (unit, 'i, 'o, 'e) t
+ val get : ('s, 's, 's, 'e) t
+ val modify : ('i -> 'o) -> (unit, 'i, 'o, 'e) t
+
+ val interleave : ('e1 -> 'e2) -> ('e2 -> 'e1) -> ('a, 'i, 'o, 'e1) t ->
+ ('a, 'i, 'o, 'e2) t
+ (** [interleave src dst m] adapts the exceptional content of the monad
+ according to the functions [src] and [dst]. To ensure a meaningful result,
+ those functions must form a retraction, i.e. [dst (src e1) = e1] for all
+ [e1]. This is typically the case when the type ['e1] is [unit]. *)
+
+ val zero : 'e -> ('a, 'i, 'o, 'e) t
+ val plus : ('a, 'i, 'o, 'e) t -> ('e -> ('a, 'i, 'o, 'e) t) -> ('a, 'i, 'o, 'e) t
+
+ val split : ('a, 's, 's, 'e) t ->
+ (('a, ('a, 'i, 's, 'e) t, 'e) list_view, 's, 's, 'e) t
+
+ val once : ('a, 'i, 'o, 'e) t -> ('a, 'i, 'o, 'e) t
+ val break : ('e -> 'e option) -> ('a, 'i, 'o, 'e) t -> ('a, 'i, 'o, 'e) t
+ val lift : 'a NonLogical.t -> ('a, 's, 's, 'e) t
+
+ type ('a, 'e) reified
+
+ val repr : ('a, 'e) reified -> ('a, ('a, 'e) reified, 'e) list_view NonLogical.t
+
+ val run : ('a, 'i, 'o, 'e) t -> 'i -> ('a * 'o, 'e) reified
+
+end
(** The monad is parametrised in the types of state, environment and
writer. *)
@@ -147,16 +186,30 @@ module Logical (P:Param) : sig
val zero : Exninfo.iexn -> 'a t
val plus : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t
- val split : 'a t -> (('a,(Exninfo.iexn->'a t)) list_view) t
+ val split : 'a t -> ('a, 'a t, Exninfo.iexn) list_view t
val once : 'a t -> 'a t
val break : (Exninfo.iexn -> Exninfo.iexn option) -> 'a t -> 'a t
val lift : 'a NonLogical.t -> 'a t
- type 'a reified
+ type 'a reified = ('a, Exninfo.iexn) BackState.reified
- val repr : 'a reified -> ('a, Exninfo.iexn -> 'a reified) list_view NonLogical.t
+ val repr : 'a reified -> ('a, 'a reified, Exninfo.iexn) list_view NonLogical.t
val run : 'a t -> P.e -> P.s -> ('a * P.s * P.w * P.u) reified
+ module Unsafe :
+ sig
+ type state = {
+ rstate : P.e;
+ ustate : P.u;
+ wstate : P.w;
+ sstate : P.s;
+ }
+
+ val make : ('a, state, state, Exninfo.iexn) BackState.t -> 'a t
+ val repr : 'a t -> ('a, state, state, Exninfo.iexn) BackState.t
+
+ end
+
end
diff --git a/pretyping/namegen.ml b/engine/namegen.ml
index a88c2e20e..a88c2e20e 100644
--- a/pretyping/namegen.ml
+++ b/engine/namegen.ml
diff --git a/pretyping/namegen.mli b/engine/namegen.mli
index f66bc6d88..f66bc6d88 100644
--- a/pretyping/namegen.mli
+++ b/engine/namegen.mli
diff --git a/proofs/proofview_monad.ml b/engine/proofview_monad.ml
index 6e68cd2e4..6e68cd2e4 100644
--- a/proofs/proofview_monad.ml
+++ b/engine/proofview_monad.ml
diff --git a/proofs/proofview_monad.mli b/engine/proofview_monad.mli
index d2a2e55fb..d2a2e55fb 100644
--- a/proofs/proofview_monad.mli
+++ b/engine/proofview_monad.mli
diff --git a/engine/sigma.ml b/engine/sigma.ml
new file mode 100644
index 000000000..e3e83b602
--- /dev/null
+++ b/engine/sigma.ml
@@ -0,0 +1,93 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type 'a t = Evd.evar_map
+
+type ('a, 'b) le = unit
+
+let refl = ()
+let cons _ _ = ()
+let (+>) = fun _ _ -> ()
+
+type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma
+
+type 'a evar = Evar.t
+
+let lift_evar evk () = evk
+
+let to_evar_map evd = evd
+let to_evar evk = evk
+
+let here x s = Sigma (x, s, ())
+
+(** API *)
+
+type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh
+
+let new_evar sigma ?naming info =
+ let (sigma, evk) = Evd.new_evar sigma ?naming info in
+ Fresh (evk, sigma, ())
+
+let define evk c sigma =
+ Sigma ((), Evd.define evk c sigma, ())
+
+let fresh_constructor_instance env sigma pc =
+ let (sigma, c) = Evd.fresh_constructor_instance env sigma pc in
+ Sigma (c, sigma, ())
+
+let fresh_global ?rigid ?names env sigma r =
+ let (sigma, c) = Evd.fresh_global ?rigid ?names env sigma r in
+ Sigma (c, sigma, ())
+
+(** Run *)
+
+type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma }
+
+let run sigma f : 'a * Evd.evar_map =
+ let Sigma (x, sigma, ()) = f.run sigma in
+ (x, sigma)
+
+(** Monotonic references *)
+
+type evdref = Evd.evar_map ref
+
+let apply evdref f =
+ let Sigma (x, sigma, ()) = f.run !evdref in
+ evdref := sigma;
+ x
+
+let purify f =
+ let f (sigma : Evd.evar_map) =
+ let evdref = ref sigma in
+ let ans = f evdref in
+ Sigma (ans, !evdref, ())
+ in
+ { run = f }
+
+(** Unsafe primitives *)
+
+module Unsafe =
+struct
+
+let le = ()
+let of_evar_map sigma = sigma
+let of_evar evk = evk
+let of_ref ref = ref
+let of_pair (x, sigma) = Sigma (x, sigma, ())
+
+end
+
+module Notations =
+struct
+ type ('a, 'r) sigma_ = ('a, 'r) sigma =
+ Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_
+
+ let (+>) = fun _ _ -> ()
+
+ type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma }
+end
diff --git a/engine/sigma.mli b/engine/sigma.mli
new file mode 100644
index 000000000..6ac56bb3e
--- /dev/null
+++ b/engine/sigma.mli
@@ -0,0 +1,116 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Names
+open Constr
+
+(** Monotonous state enforced by typing.
+
+ This module allows to constrain uses of evarmaps in a monotonous fashion,
+ and in particular statically suppress evar leaks and the like.
+*)
+
+(** {5 Stages} *)
+
+type ('a, 'b) le
+(** Relationship stating that stage ['a] is anterior to stage ['b] *)
+
+val refl : ('a, 'a) le
+(** Reflexivity of anteriority *)
+
+val cons : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le
+(** Transitivity of anteriority *)
+
+val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le
+(** Alias for {!cons} *)
+
+(** {5 Monotonous evarmaps} *)
+
+type 'r t
+(** Stage-indexed evarmaps. *)
+
+type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma
+(** Return values at a later stage *)
+
+type 'r evar
+(** Stage-indexed evars *)
+
+(** {5 Constructors} *)
+
+val here : 'a -> 'r t -> ('a, 'r) sigma
+(** [here x s] is a shorthand for [Sigma (x, s, refl)] *)
+
+(** {5 Postponing} *)
+
+val lift_evar : 'r evar -> ('r, 's) le -> 's evar
+(** Any evar existing at stage ['r] is also valid at any later stage. *)
+
+(** {5 Downcasting} *)
+
+val to_evar_map : 'r t -> Evd.evar_map
+val to_evar : 'r evar -> Evar.t
+
+(** {5 Monotonous API} *)
+
+type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh
+
+val new_evar : 'r t -> ?naming:Misctypes.intro_pattern_naming_expr ->
+ Evd.evar_info -> 'r fresh
+
+val define : 'r evar -> Constr.t -> 'r t -> (unit, 'r) sigma
+
+(** Polymorphic universes *)
+
+val fresh_constructor_instance : Environ.env -> 'r t -> constructor ->
+ (pconstructor, 'r) sigma
+
+val fresh_global : ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env ->
+ 'r t -> Globnames.global_reference -> (constr, 'r) sigma
+
+(** FILLME *)
+
+(** {5 Run} *)
+
+type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma }
+
+val run : Evd.evar_map -> 'a run -> 'a * Evd.evar_map
+
+(** {5 Imperative monotonic functions} *)
+
+type evdref
+(** Monotonic references over evarmaps *)
+
+val apply : evdref -> 'a run -> 'a
+(** Apply a monotonic function on a reference. *)
+
+val purify : (evdref -> 'a) -> 'a run
+(** Converse of {!apply}. *)
+
+(** {5 Unsafe primitives} *)
+
+module Unsafe :
+sig
+ val le : ('a, 'b) le
+ val of_evar_map : Evd.evar_map -> 'r t
+ val of_evar : Evd.evar -> 'r evar
+ val of_ref : Evd.evar_map ref -> evdref
+ val of_pair : ('a * Evd.evar_map) -> ('a, 'r) sigma
+end
+
+(** {5 Notations} *)
+
+module Notations :
+sig
+ type ('a, 'r) sigma_ = ('a, 'r) sigma =
+ Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_
+
+ type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma }
+
+ val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le
+ (** Alias for {!cons} *)
+end
diff --git a/pretyping/termops.ml b/engine/termops.ml
index 5a55d47fd..5a55d47fd 100644
--- a/pretyping/termops.ml
+++ b/engine/termops.ml
diff --git a/pretyping/termops.mli b/engine/termops.mli
index 4581e2310..6c680005d 100644
--- a/pretyping/termops.mli
+++ b/engine/termops.mli
@@ -134,7 +134,7 @@ val pop : constr -> constr
(** Substitution of an arbitrary large term. Uses equality modulo
reduction of let *)
-(** [subst_term_gen eq d c] replaces [Rel 1] by [d] in [c] using [eq]
+(** [subst_term_gen eq d c] replaces [d] by [Rel 1] in [c] using [eq]
as equality *)
val subst_term_gen :
(constr -> constr -> bool) -> constr -> constr -> constr
@@ -145,7 +145,7 @@ val replace_term_gen :
(constr -> constr -> bool) ->
constr -> constr -> constr -> constr
-(** [subst_term d c] replaces [Rel 1] by [d] in [c] *)
+(** [subst_term d c] replaces [d] by [Rel 1] in [c] *)
val subst_term : constr -> constr -> constr
(** [replace_term d e c] replaces [d] by [e] in [c] *)
diff --git a/engine/uState.ml b/engine/uState.ml
new file mode 100644
index 000000000..61ab5a8fc
--- /dev/null
+++ b/engine/uState.ml
@@ -0,0 +1,467 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Pp
+open Errors
+open Util
+open Names
+
+module StringOrd = struct type t = string let compare = String.compare end
+module UNameMap = struct
+
+ include Map.Make(StringOrd)
+
+ let union s t =
+ if s == t then s
+ else
+ merge (fun k l r ->
+ match l, r with
+ | Some _, _ -> l
+ | _, _ -> r) s t
+end
+
+(* 2nd part used to check consistency on the fly. *)
+type t =
+ { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t;
+ uctx_local : Univ.universe_context_set; (** The local context of variables *)
+ uctx_univ_variables : Universes.universe_opt_subst;
+ (** The local universes that are unification variables *)
+ uctx_univ_algebraic : Univ.universe_set;
+ (** The subset of unification variables that
+ can be instantiated with algebraic universes as they appear in types
+ and universe instances only. *)
+ uctx_universes : UGraph.t; (** The current graph extended with the local constraints *)
+ uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *)
+ }
+
+let empty =
+ { uctx_names = UNameMap.empty, Univ.LMap.empty;
+ uctx_local = Univ.ContextSet.empty;
+ uctx_univ_variables = Univ.LMap.empty;
+ uctx_univ_algebraic = Univ.LSet.empty;
+ uctx_universes = UGraph.initial_universes;
+ uctx_initial_universes = UGraph.initial_universes }
+
+let make u =
+ { empty with
+ uctx_universes = u; uctx_initial_universes = u}
+
+let is_empty ctx =
+ Univ.ContextSet.is_empty ctx.uctx_local &&
+ Univ.LMap.is_empty ctx.uctx_univ_variables
+
+let union ctx ctx' =
+ if ctx == ctx' then ctx
+ else if is_empty ctx' then ctx
+ else
+ let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in
+ let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in
+ let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local)
+ (Univ.ContextSet.levels ctx.uctx_local) in
+ let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in
+ let declarenew g =
+ Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) newus g
+ in
+ let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in
+ { uctx_names = (names, names_rev);
+ uctx_local = local;
+ uctx_univ_variables =
+ Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables;
+ uctx_univ_algebraic =
+ Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic;
+ uctx_initial_universes = declarenew ctx.uctx_initial_universes;
+ uctx_universes =
+ if local == ctx.uctx_local then ctx.uctx_universes
+ else
+ let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in
+ UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes) }
+
+let context_set ctx = ctx.uctx_local
+
+let constraints ctx = snd ctx.uctx_local
+
+let context ctx = Univ.ContextSet.to_context ctx.uctx_local
+
+let of_context_set ctx = { empty with uctx_local = ctx }
+
+let subst ctx = ctx.uctx_univ_variables
+
+let ugraph ctx = ctx.uctx_universes
+
+let algebraics ctx = ctx.uctx_univ_algebraic
+
+let constrain_variables diff ctx =
+ Univ.LSet.fold
+ (fun l cstrs ->
+ try
+ match Univ.LMap.find l ctx.uctx_univ_variables with
+ | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs
+ | None -> cstrs
+ with Not_found | Option.IsNone -> cstrs)
+ diff Univ.Constraint.empty
+
+let add_uctx_names s l (names, names_rev) =
+ (UNameMap.add s l names, Univ.LMap.add l s names_rev)
+
+let of_binders b =
+ let ctx = empty in
+ let names =
+ List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc)
+ ctx.uctx_names b
+ in { ctx with uctx_names = names }
+
+let instantiate_variable l b v =
+ v := Univ.LMap.add l (Some b) !v
+
+exception UniversesDiffer
+
+let process_universe_constraints univs vars alg cstrs =
+ let vars = ref vars in
+ let normalize = Universes.normalize_universe_opt_subst vars in
+ let rec unify_universes fo l d r local =
+ let l = normalize l and r = normalize r in
+ if Univ.Universe.equal l r then local
+ else
+ let varinfo x =
+ match Univ.Universe.level x with
+ | None -> Inl x
+ | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg)
+ in
+ if d == Universes.ULe then
+ if UGraph.check_leq univs l r then
+ (** Keep Prop/Set <= var around if var might be instantiated by prop or set
+ later. *)
+ if Univ.Universe.is_level l then
+ match Univ.Universe.level r with
+ | Some r ->
+ Univ.Constraint.add (Option.get (Univ.Universe.level l),Univ.Le,r) local
+ | _ -> local
+ else local
+ else
+ match Univ.Universe.level r with
+ | None -> error ("Algebraic universe on the right")
+ | Some rl ->
+ if Univ.Level.is_small rl then
+ let levels = Univ.Universe.levels l in
+ Univ.LSet.fold (fun l local ->
+ if Univ.Level.is_small l || Univ.LMap.mem l !vars then
+ unify_universes fo (Univ.Universe.make l) Universes.UEq r local
+ else raise (Univ.UniverseInconsistency (Univ.Le, Univ.Universe.make l, r, None)))
+ levels local
+ else
+ Univ.enforce_leq l r local
+ else if d == Universes.ULub then
+ match varinfo l, varinfo r with
+ | (Inr (l, true, _), Inr (r, _, _))
+ | (Inr (r, _, _), Inr (l, true, _)) ->
+ instantiate_variable l (Univ.Universe.make r) vars;
+ Univ.enforce_eq_level l r local
+ | Inr (_, _, _), Inr (_, _, _) ->
+ unify_universes true l Universes.UEq r local
+ | _, _ -> assert false
+ else (* d = Universes.UEq *)
+ match varinfo l, varinfo r with
+ | Inr (l', lloc, _), Inr (r', rloc, _) ->
+ let () =
+ if lloc then
+ instantiate_variable l' r vars
+ else if rloc then
+ instantiate_variable r' l vars
+ else if not (UGraph.check_eq univs l r) then
+ (* Two rigid/global levels, none of them being local,
+ one of them being Prop/Set, disallow *)
+ if Univ.Level.is_small l' || Univ.Level.is_small r' then
+ raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None))
+ else
+ if fo then
+ raise UniversesDiffer
+ in
+ Univ.enforce_eq_level l' r' local
+ | Inr (l, loc, alg), Inl r
+ | Inl r, Inr (l, loc, alg) ->
+ let inst = Univ.univ_level_rem l r r in
+ if alg then (instantiate_variable l inst vars; local)
+ else
+ let lu = Univ.Universe.make l in
+ if Univ.univ_level_mem l r then
+ Univ.enforce_leq inst lu local
+ else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None))
+ | _, _ (* One of the two is algebraic or global *) ->
+ if UGraph.check_eq univs l r then local
+ else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None))
+ in
+ let local =
+ Universes.Constraints.fold (fun (l,d,r) local -> unify_universes false l d r local)
+ cstrs Univ.Constraint.empty
+ in
+ !vars, local
+
+let add_constraints ctx cstrs =
+ let univs, local = ctx.uctx_local in
+ let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc ->
+ let l = Univ.Universe.make l and r = Univ.Universe.make r in
+ let cstr' =
+ if d == Univ.Lt then (Univ.Universe.super l, Universes.ULe, r)
+ else (l, (if d == Univ.Le then Universes.ULe else Universes.UEq), r)
+ in Universes.Constraints.add cstr' acc)
+ cstrs Universes.Constraints.empty
+ in
+ let vars, local' =
+ process_universe_constraints ctx.uctx_universes
+ ctx.uctx_univ_variables ctx.uctx_univ_algebraic
+ cstrs'
+ in
+ { ctx with uctx_local = (univs, Univ.Constraint.union local local');
+ uctx_univ_variables = vars;
+ uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes }
+
+(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *)
+(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *)
+
+let add_universe_constraints ctx cstrs =
+ let univs, local = ctx.uctx_local in
+ let vars, local' =
+ process_universe_constraints ctx.uctx_universes
+ ctx.uctx_univ_variables ctx.uctx_univ_algebraic
+ cstrs
+ in
+ { ctx with uctx_local = (univs, Univ.Constraint.union local local');
+ uctx_univ_variables = vars;
+ uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes }
+
+let pr_uctx_level uctx =
+ let map, map_rev = uctx.uctx_names in
+ fun l ->
+ try str(Univ.LMap.find l map_rev)
+ with Not_found ->
+ Universes.pr_with_global_universes l
+
+let universe_context ?names ctx =
+ match names with
+ | None -> [], Univ.ContextSet.to_context ctx.uctx_local
+ | Some pl ->
+ let levels = Univ.ContextSet.levels ctx.uctx_local in
+ let newinst, map, left =
+ List.fold_right
+ (fun (loc,id) (newinst, map, acc) ->
+ let l =
+ try UNameMap.find (Id.to_string id) (fst ctx.uctx_names)
+ with Not_found ->
+ user_err_loc (loc, "universe_context",
+ str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.")
+ in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc))
+ pl ([], [], levels)
+ in
+ if not (Univ.LSet.is_empty left) then
+ let n = Univ.LSet.cardinal left in
+ errorlabstrm "universe_context"
+ (str(CString.plural n "Universe") ++ spc () ++
+ Univ.LSet.pr (pr_uctx_level ctx) left ++
+ spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")
+ else
+ let inst = Univ.Instance.of_array (Array.of_list newinst) in
+ let ctx = Univ.UContext.make (inst,
+ Univ.ContextSet.constraints ctx.uctx_local)
+ in map, ctx
+
+let restrict ctx vars =
+ let uctx' = Universes.restrict_universe_context ctx.uctx_local vars in
+ { ctx with uctx_local = uctx' }
+
+type rigid =
+ | UnivRigid
+ | UnivFlexible of bool (** Is substitution by an algebraic ok? *)
+
+let univ_rigid = UnivRigid
+let univ_flexible = UnivFlexible false
+let univ_flexible_alg = UnivFlexible true
+
+let merge sideff rigid uctx ctx' =
+ let open Univ in
+ let levels = ContextSet.levels ctx' in
+ let uctx = if sideff then uctx else
+ match rigid with
+ | UnivRigid -> uctx
+ | UnivFlexible b ->
+ let fold u accu =
+ if LMap.mem u accu then accu
+ else LMap.add u None accu
+ in
+ let uvars' = LSet.fold fold levels uctx.uctx_univ_variables in
+ if b then
+ { uctx with uctx_univ_variables = uvars';
+ uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels }
+ else { uctx with uctx_univ_variables = uvars' }
+ in
+ let uctx_local =
+ if sideff then uctx.uctx_local
+ else ContextSet.append ctx' uctx.uctx_local
+ in
+ let declare g =
+ LSet.fold (fun u g ->
+ try UGraph.add_universe u false g
+ with UGraph.AlreadyDeclared when sideff -> g)
+ levels g
+ in
+ let initial = declare uctx.uctx_initial_universes in
+ let univs = declare uctx.uctx_universes in
+ let uctx_universes = UGraph.merge_constraints (ContextSet.constraints ctx') univs in
+ { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial }
+
+let merge_subst uctx s =
+ { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s }
+
+let emit_side_effects eff u =
+ let uctxs = Safe_typing.universes_of_private eff in
+ List.fold_left (merge true univ_rigid) u uctxs
+
+let new_univ_variable rigid name
+ ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) =
+ let u = Universes.new_univ_level (Global.current_dirpath ()) in
+ let ctx' = Univ.ContextSet.add_universe u ctx in
+ let uctx', pred =
+ match rigid with
+ | UnivRigid -> uctx, true
+ | UnivFlexible b ->
+ let uvars' = Univ.LMap.add u None uvars in
+ if b then {uctx with uctx_univ_variables = uvars';
+ uctx_univ_algebraic = Univ.LSet.add u avars}, false
+ else {uctx with uctx_univ_variables = uvars'}, false
+ in
+ let names =
+ match name with
+ | Some n -> add_uctx_names n u uctx.uctx_names
+ | None -> uctx.uctx_names
+ in
+ let initial =
+ UGraph.add_universe u false uctx.uctx_initial_universes
+ in
+ let uctx' =
+ {uctx' with uctx_names = names; uctx_local = ctx';
+ uctx_universes = UGraph.add_universe u false uctx.uctx_universes;
+ uctx_initial_universes = initial}
+ in uctx', u
+
+let add_global_univ uctx u =
+ let initial =
+ UGraph.add_universe u true uctx.uctx_initial_universes
+ in
+ let univs =
+ UGraph.add_universe u true uctx.uctx_universes
+ in
+ { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local;
+ uctx_initial_universes = initial;
+ uctx_universes = univs }
+
+let make_flexible_variable ctx b u =
+ let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} = ctx in
+ let uvars' = Univ.LMap.add u None uvars in
+ let avars' =
+ if b then
+ let uu = Univ.Universe.make u in
+ let substu_not_alg u' v =
+ Option.cata (fun vu -> Univ.Universe.equal uu vu && not (Univ.LSet.mem u' avars)) false v
+ in
+ if not (Univ.LMap.exists substu_not_alg uvars)
+ then Univ.LSet.add u avars else avars
+ else avars
+ in
+ {ctx with uctx_univ_variables = uvars';
+ uctx_univ_algebraic = avars'}
+
+let is_sort_variable uctx s =
+ match s with
+ | Sorts.Type u ->
+ (match Univ.universe_level u with
+ | Some l as x ->
+ if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x
+ else None
+ | None -> None)
+ | _ -> None
+
+let subst_univs_context_with_def def usubst (ctx, cst) =
+ (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst)
+
+let normalize_variables uctx =
+ let normalized_variables, undef, def, subst =
+ Universes.normalize_univ_variables uctx.uctx_univ_variables
+ in
+ let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in
+ let ctx_local', univs = Universes.refresh_constraints uctx.uctx_initial_universes ctx_local in
+ subst, { uctx with uctx_local = ctx_local';
+ uctx_univ_variables = normalized_variables;
+ uctx_universes = univs }
+
+let abstract_undefined_variables uctx =
+ let vars' =
+ Univ.LMap.fold (fun u v acc ->
+ if v == None then Univ.LSet.remove u acc
+ else acc)
+ uctx.uctx_univ_variables uctx.uctx_univ_algebraic
+ in { uctx with uctx_local = Univ.ContextSet.empty;
+ uctx_univ_algebraic = vars' }
+
+let fix_undefined_variables uctx =
+ let algs', vars' =
+ Univ.LMap.fold (fun u v (algs, vars as acc) ->
+ if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars)
+ else acc)
+ uctx.uctx_univ_variables
+ (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables)
+ in
+ { uctx with uctx_univ_variables = vars';
+ uctx_univ_algebraic = algs' }
+
+let refresh_undefined_univ_variables uctx =
+ let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in
+ let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc)
+ uctx.uctx_univ_algebraic Univ.LSet.empty
+ in
+ let vars =
+ Univ.LMap.fold
+ (fun u v acc ->
+ Univ.LMap.add (Univ.subst_univs_level_level subst u)
+ (Option.map (Univ.subst_univs_level_universe subst) v) acc)
+ uctx.uctx_univ_variables Univ.LMap.empty
+ in
+ let declare g = Univ.LSet.fold (fun u g -> UGraph.add_universe u false g)
+ (Univ.ContextSet.levels ctx') g in
+ let initial = declare uctx.uctx_initial_universes in
+ let univs = declare UGraph.initial_universes in
+ let uctx' = {uctx_names = uctx.uctx_names;
+ uctx_local = ctx';
+ uctx_univ_variables = vars; uctx_univ_algebraic = alg;
+ uctx_universes = univs;
+ uctx_initial_universes = initial } in
+ uctx', subst
+
+let normalize uctx =
+ let rec fixpoint uctx =
+ let ((vars',algs'), us') =
+ Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables
+ uctx.uctx_univ_algebraic
+ in
+ if Univ.ContextSet.equal us' uctx.uctx_local then uctx
+ else
+ let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in
+ let uctx' =
+ { uctx_names = uctx.uctx_names;
+ uctx_local = us';
+ uctx_univ_variables = vars';
+ uctx_univ_algebraic = algs';
+ uctx_universes = universes;
+ uctx_initial_universes = uctx.uctx_initial_universes }
+ in fixpoint uctx'
+ in fixpoint uctx
+
+let universe_of_name uctx s =
+ UNameMap.find s (fst uctx.uctx_names)
+
+let add_universe_name uctx s l =
+ let names' = add_uctx_names s l uctx.uctx_names in
+ { uctx with uctx_names = names' }
diff --git a/engine/uState.mli b/engine/uState.mli
new file mode 100644
index 000000000..6861035fa
--- /dev/null
+++ b/engine/uState.mli
@@ -0,0 +1,115 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Universe unification states *)
+
+open Names
+
+exception UniversesDiffer
+
+type t
+(** Type of universe unification states. They allow the incremental building of
+ universe constraints during an interactive proof. *)
+
+(** {5 Constructors} *)
+
+val empty : t
+
+val make : UGraph.t -> t
+
+val is_empty : t -> bool
+
+val union : t -> t -> t
+
+val of_context_set : Univ.universe_context_set -> t
+
+val of_binders : Universes.universe_binders -> t
+
+(** {5 Projections} *)
+
+val context_set : t -> Univ.universe_context_set
+(** The local context of the state, i.e. a set of bound variables together
+ with their associated constraints. *)
+
+val subst : t -> Universes.universe_opt_subst
+(** The local universes that are unification variables *)
+
+val ugraph : t -> UGraph.t
+(** The current graph extended with the local constraints *)
+
+val algebraics : t -> Univ.LSet.t
+(** The subset of unification variables that can be instantiated with algebraic
+ universes as they appear in types and universe instances only. *)
+
+val constraints : t -> Univ.constraints
+(** Shorthand for {!context_set} composed with {!ContextSet.constraints}. *)
+
+val context : t -> Univ.universe_context
+(** Shorthand for {!context_set} with {!Context_set.to_context}. *)
+
+(** {5 Constraints handling} *)
+
+val add_constraints : t -> Univ.constraints -> t
+(**
+ @raise UniversesDiffer
+*)
+
+val add_universe_constraints : t -> Universes.universe_constraints -> t
+(**
+ @raise UniversesDiffer
+*)
+
+(** {5 Names} *)
+
+val add_universe_name : t -> string -> Univ.Level.t -> t
+(** Associate a human-readable name to a local variable. *)
+
+val universe_of_name : t -> string -> Univ.Level.t
+(** Retrieve the universe associated to the name. *)
+
+(** {5 Unification} *)
+
+val restrict : t -> Univ.universe_set -> t
+
+type rigid =
+ | UnivRigid
+ | UnivFlexible of bool (** Is substitution by an algebraic ok? *)
+
+val univ_rigid : rigid
+val univ_flexible : rigid
+val univ_flexible_alg : rigid
+
+val merge : bool -> rigid -> t -> Univ.universe_context_set -> t
+val merge_subst : t -> Universes.universe_opt_subst -> t
+val emit_side_effects : Safe_typing.private_constants -> t -> t
+
+val new_univ_variable : rigid -> string option -> t -> t * Univ.Level.t
+val add_global_univ : t -> Univ.Level.t -> t
+val make_flexible_variable : t -> bool -> Univ.Level.t -> t
+
+val is_sort_variable : t -> Sorts.t -> Univ.Level.t option
+
+val normalize_variables : t -> Univ.universe_subst * t
+
+val constrain_variables : Univ.LSet.t -> t -> Univ.constraints
+
+val abstract_undefined_variables : t -> t
+
+val fix_undefined_variables : t -> t
+
+val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst
+
+val normalize : t -> t
+
+(** {5 TODO: Document me} *)
+
+val universe_context : ?names:(Id.t Loc.located) list -> t -> (Id.t * Univ.Level.t) list * Univ.universe_context
+
+(** {5 Pretty-printing} *)
+
+val pr_uctx_level : t -> Univ.Level.t -> Pp.std_ppcmds
diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4
index fe0959ddb..08651de64 100644
--- a/grammar/argextend.ml4
+++ b/grammar/argextend.ml4
@@ -51,28 +51,46 @@ let make_rawwit loc arg = <:expr< Genarg.rawwit $make_wit loc arg$ >>
let make_globwit loc arg = <:expr< Genarg.glbwit $make_wit loc arg$ >>
let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >>
-let has_extraarg =
- List.exists (function GramNonTerminal(_,ExtraArgType _,_,_) -> true | _ -> false)
+let has_extraarg l =
+ let check = function
+ | GramNonTerminal(_, t, _, _) ->
+ begin match Genarg.unquote t with
+ | ExtraArgType _ -> true
+ | _ -> false
+ end
+ | _ -> false
+ in
+ List.exists check l
-let rec is_possibly_empty = function
-| Aopt _ | Alist0 _ | Alist0sep _ | Amodifiers _ -> true
-| Alist1 t | Alist1sep (t, _) -> is_possibly_empty t
+let rec is_possibly_empty : type s a. (s, a) entry_key -> bool = function
+| Aopt _ -> true
+| Alist0 _ -> true
+| Alist0sep _ -> true
+| Amodifiers _ -> true
+| Alist1 t -> is_possibly_empty t
+| Alist1sep (t, _) -> is_possibly_empty t
| _ -> false
-let rec get_empty_entry = function
+let rec get_empty_entry : type s a. (s, a) entry_key -> _ = function
| Aopt _ -> <:expr< None >>
-| Alist0 _ | Alist0sep _ | Amodifiers _ -> <:expr< [] >>
-| Alist1 t | Alist1sep (t, _) -> <:expr< [$get_empty_entry t$] >>
+| Alist0 _ -> <:expr< [] >>
+| Alist0sep _ -> <:expr< [] >>
+| Amodifiers _ -> <:expr< [] >>
+| Alist1 t -> <:expr< [$get_empty_entry t$] >>
+| Alist1sep (t, _) -> <:expr< [$get_empty_entry t$] >>
| _ -> assert false
let statically_known_possibly_empty s (prods,_) =
List.for_all (function
- | GramNonTerminal(_,ExtraArgType s',_,_) ->
+ | GramNonTerminal(_,t,e,_) ->
+ begin match Genarg.unquote t with
+ | ExtraArgType s' ->
(* For ExtraArg we don't know (we'll have to test dynamically) *)
(* unless it is a recursive call *)
s <> s'
- | GramNonTerminal(_,_,e,_) ->
+ | _ ->
is_possibly_empty e
+ end
| GramTerminal _ ->
(* This consumes a token for sure *) false)
prods
@@ -86,7 +104,11 @@ let possibly_empty_subentries loc (prods,act) =
| [] -> <:expr< let loc = $default_loc$ in let _ = loc in $act$ >>
| GramNonTerminal(_,_,e,p) :: tl when is_possibly_empty e ->
bind_name p (get_empty_entry e) (aux tl)
- | GramNonTerminal(_,(ExtraArgType _ as t),_,p) :: tl ->
+ | GramNonTerminal(_,t,_,p) :: tl ->
+ let t = match Genarg.unquote t with
+ | ExtraArgType _ as t -> t
+ | _ -> assert false
+ in
(* We check at runtime if extraarg s parses "epsilon" *)
let s = match p with None -> "_" | Some id -> Names.Id.to_string id in
<:expr< let $lid:s$ = match Genarg.default_empty_value $make_wit loc t$ with
@@ -120,25 +142,28 @@ let make_possibly_empty_subentries loc s cl =
let make_act loc act pil =
let rec make = function
- | [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >>
+ | [] -> <:expr< (fun loc -> $act$) >>
| GramNonTerminal (_,t,_,Some p) :: tl ->
+ let t = Genarg.unquote t in
let p = Names.Id.to_string p in
<:expr<
- Pcoq.Gram.action
(fun $lid:p$ ->
let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$)
>>
| (GramTerminal _ | GramNonTerminal (_,_,_,None)) :: tl ->
- <:expr< Pcoq.Gram.action (fun _ -> $make tl$) >> in
+ <:expr< (fun _ -> $make tl$) >> in
make (List.rev pil)
let make_prod_item = function
- | GramTerminal s -> <:expr< Pcoq.gram_token_of_string $str:s$ >>
- | GramNonTerminal (_,_,g,_) ->
- <:expr< Pcoq.symbol_of_prod_entry_key $mlexpr_of_prod_entry_key g$ >>
+ | GramTerminal s -> <:expr< Pcoq.Atoken (Lexer.terminal $mlexpr_of_string s$) >>
+ | GramNonTerminal (_,_,g,_) -> mlexpr_of_prod_entry_key g
+
+let rec make_prod = function
+| [] -> <:expr< Extend.Stop >>
+| item :: prods -> <:expr< Extend.Next $make_prod prods$ $make_prod_item item$ >>
let make_rule loc (prods,act) =
- <:expr< ($mlexpr_of_list make_prod_item prods$,$make_act loc act prods$) >>
+ <:expr< Extend.Rule $make_prod (List.rev prods)$ $make_act loc act prods$ >>
let declare_tactic_argument loc s (typ, pr, f, g, h) cl =
let rawtyp, rawpr, globtyp, globpr = match typ with
@@ -201,8 +226,7 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl =
<:str_item<
value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
<:str_item< do {
- Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a))
- (None, [(None, None, $rules$)]);
+ Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]);
Pptactic.declare_extra_genarg_pprule
$wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$ }
>> ]
@@ -222,8 +246,7 @@ let declare_vernac_argument loc s pr cl =
<:str_item<
value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
<:str_item< do {
- Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a))
- (None, [(None, None, $rules$)]);
+ Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]);
Pptactic.declare_extra_genarg_pprule $wit$
$pr_rules$
(fun _ _ _ _ -> Errors.anomaly (Pp.str "vernac argument needs not globwit printer"))
@@ -272,7 +295,9 @@ EXTEND
[ e = argtype; LIDENT "list" -> ListArgType e
| e = argtype; LIDENT "option" -> OptArgType e ]
| "0"
- [ e = LIDENT -> fst (interp_entry_name false None e "")
+ [ e = LIDENT ->
+ let EntryName (t, _) = interp_entry_name false TgAny e "" in
+ Genarg.unquote t
| "("; e = argtype; ")" -> e ] ]
;
argrule:
@@ -280,10 +305,10 @@ EXTEND
;
genarg:
[ [ e = LIDENT; "("; s = LIDENT; ")" ->
- let t, g = interp_entry_name false None e "" in
+ let EntryName (t, g) = interp_entry_name false TgAny e "" in
GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
| e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
- let t, g = interp_entry_name false None e sep in
+ let EntryName (t, g) = interp_entry_name false TgAny e sep in
GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
| s = STRING ->
if String.length s > 0 && Util.is_letter s.[0] then
diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib
index 60ea0df02..7e4eea641 100644
--- a/grammar/grammar.mllib
+++ b/grammar/grammar.mllib
@@ -51,6 +51,7 @@ Constrexpr_ops
Compat
Tok
Lexer
+Entry
Pcoq
G_prim
G_tactic
diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4
index 18b1ccd3b..19f436f92 100644
--- a/grammar/q_util.ml4
+++ b/grammar/q_util.ml4
@@ -49,7 +49,20 @@ let mlexpr_of_option f = function
| None -> <:expr< None >>
| Some e -> <:expr< Some $f e$ >>
-let rec mlexpr_of_prod_entry_key = function
+let mlexpr_of_token = function
+| Tok.KEYWORD s -> <:expr< Tok.KEYWORD $mlexpr_of_string s$ >>
+| Tok.METAIDENT s -> <:expr< Tok.METAIDENT $mlexpr_of_string s$ >>
+| Tok.PATTERNIDENT s -> <:expr< Tok.PATTERNIDENT $mlexpr_of_string s$ >>
+| Tok.IDENT s -> <:expr< Tok.IDENT $mlexpr_of_string s$ >>
+| Tok.FIELD s -> <:expr< Tok.FIELD $mlexpr_of_string s$ >>
+| Tok.INT s -> <:expr< Tok.INT $mlexpr_of_string s$ >>
+| Tok.STRING s -> <:expr< Tok.STRING $mlexpr_of_string s$ >>
+| Tok.LEFTQMARK -> <:expr< Tok.LEFTQMARK >>
+| Tok.BULLET s -> <:expr< Tok.BULLET $mlexpr_of_string s$ >>
+| Tok.EOI -> <:expr< Tok.EOI >>
+
+let rec mlexpr_of_prod_entry_key : type s a. (s, a) Pcoq.entry_key -> _ = function
+ | Pcoq.Atoken t -> <:expr< Pcoq.Atoken $mlexpr_of_token t$ >>
| Pcoq.Alist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >>
| Pcoq.Alist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >>
| Pcoq.Alist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key s$ >>
@@ -58,7 +71,13 @@ let rec mlexpr_of_prod_entry_key = function
| Pcoq.Amodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >>
| Pcoq.Aself -> <:expr< Pcoq.Aself >>
| Pcoq.Anext -> <:expr< Pcoq.Anext >>
- | Pcoq.Atactic n -> <:expr< Pcoq.Atactic $mlexpr_of_int n$ >>
- | Pcoq.Agram s -> Errors.anomaly (Pp.str "Agram not supported")
- | Pcoq.Aentry ("",s) -> <:expr< Pcoq.Agram (Pcoq.Gram.Entry.name $lid:s$) >>
- | Pcoq.Aentry (u,s) -> <:expr< Pcoq.Aentry $str:u$ $str:s$ >>
+ | Pcoq.Aentry e ->
+ begin match Entry.repr e with
+ | Entry.Dynamic s -> <:expr< Pcoq.Aentry (Pcoq.name_of_entry $lid:s$) >>
+ | Entry.Static (u, s) -> <:expr< Pcoq.Aentry (Entry.unsafe_of_name ($str:u$, $str:s$)) >>
+ end
+ | Pcoq.Aentryl (e, l) ->
+ begin match Entry.repr e with
+ | Entry.Dynamic s -> <:expr< Pcoq.Aentryl (Pcoq.name_of_entry $lid:s$) >>
+ | Entry.Static (u, s) -> <:expr< Pcoq.Aentryl (Entry.unsafe_of_name ($str:u$, $str:s$)) $mlexpr_of_int l$ >>
+ end
diff --git a/grammar/q_util.mli b/grammar/q_util.mli
index 7393a0d58..d01fb1e9a 100644
--- a/grammar/q_util.mli
+++ b/grammar/q_util.mli
@@ -30,4 +30,4 @@ val mlexpr_of_string : string -> MLast.expr
val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr
-val mlexpr_of_prod_entry_key : Pcoq.prod_entry_key -> MLast.expr
+val mlexpr_of_prod_entry_key : ('self, 'a) Pcoq.entry_key -> MLast.expr
diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4
index 66f82fcdf..df2209606 100644
--- a/grammar/tacextend.ml4
+++ b/grammar/tacextend.ml4
@@ -39,13 +39,14 @@ let rec make_when loc = function
let p = Names.Id.to_string p in
let l = make_when loc l in
let loc = CompatLoc.merge loc' loc in
- let t = mlexpr_of_argtype loc' t in
+ let t = mlexpr_of_argtype loc' (Genarg.unquote t) in
<:expr< Genarg.argument_type_eq (Genarg.genarg_tag $lid:p$) $t$ && $l$ >>
| _::l -> make_when loc l
let rec make_let raw e = function
| [] -> <:expr< fun $lid:"ist"$ -> $e$ >>
| GramNonTerminal(loc,t,_,Some p)::l ->
+ let t = Genarg.unquote t in
let loc = of_coqloc loc in
let p = Names.Id.to_string p in
let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in
@@ -58,7 +59,7 @@ let rec make_let raw e = function
let rec extract_signature = function
| [] -> []
- | GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l
+ | GramNonTerminal (_,t,_,_) :: l -> Genarg.unquote t :: extract_signature l
| _::l -> extract_signature l
@@ -77,11 +78,13 @@ let make_clause (pt,_,e) =
let make_fun_clauses loc s l =
check_unicity s l;
- Compat.make_fun loc (List.map make_clause l)
+ let map c = Compat.make_fun loc [make_clause c] in
+ mlexpr_of_list map l
let rec make_args = function
| [] -> <:expr< [] >>
| GramNonTerminal(loc,t,_,Some p)::l ->
+ let t = Genarg.unquote t in
let loc = of_coqloc loc in
let p = Names.Id.to_string p in
<:expr< [ Genarg.in_gen $make_topwit loc t$ $lid:p$ :: $make_args l$ ] >>
@@ -96,11 +99,12 @@ let make_prod_item = function
| GramTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >>
| GramNonTerminal (loc,nt,g,sopt) ->
let loc = of_coqloc loc in
- <:expr< Egramml.GramNonTerminal $default_loc$ $mlexpr_of_argtype loc nt$
+ let nt = Genarg.unquote nt in
+ <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$
$mlexpr_of_prod_entry_key g$ $mlexpr_of_option mlexpr_of_ident sopt$ >>
-let mlexpr_of_clause =
- mlexpr_of_list (fun (a,_,b) -> mlexpr_of_list make_prod_item a)
+let mlexpr_of_clause cl =
+ mlexpr_of_list (fun (a,_,b) -> mlexpr_of_list make_prod_item a) cl
let rec make_tags loc = function
| [] -> <:expr< [] >>
@@ -108,21 +112,23 @@ let rec make_tags loc = function
let loc' = of_coqloc loc' in
let l = make_tags loc l in
let loc = CompatLoc.merge loc' loc in
+ let t = Genarg.unquote t in
let t = mlexpr_of_argtype loc' t in
<:expr< [ $t$ :: $l$ ] >>
| _::l -> make_tags loc l
-let make_one_printing_rule se (pt,_,e) =
+let make_one_printing_rule (pt,_,e) =
let level = mlexpr_of_int 0 in (* only level 0 supported here *)
let loc = MLast.loc_of_expr e in
let prods = mlexpr_of_list mlexpr_terminals_of_grammar_tactic_prod_item_expr pt in
- <:expr< ($se$, { Pptactic.pptac_args = $make_tags loc pt$;
- pptac_prods = ($level$, $prods$) }) >>
+ <:expr< { Pptactic.pptac_args = $make_tags loc pt$;
+ pptac_prods = ($level$, $prods$) } >>
-let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se)
+let make_printing_rule r = mlexpr_of_list make_one_printing_rule r
let make_empty_check = function
| GramNonTerminal(_, t, e, _)->
+ let t = Genarg.unquote t in
let is_extra = match t with ExtraArgType _ -> true | _ -> false in
if is_possibly_empty e || is_extra then
(* This possibly parses epsilon *)
@@ -141,37 +147,31 @@ let make_empty_check = function
(* Idem *)
raise Exit
-let rec possibly_empty_subentries loc = function
- | [] -> []
- | (s,prodsl) :: l ->
- let rec aux = function
- | [] -> (false,<:expr< None >>)
- | prods :: rest ->
- try
- let l = List.map make_empty_check prods in
- if has_extraarg prods then
- (true,<:expr< try Some $mlexpr_of_list (fun x -> x) l$
- with [ Exit -> $snd (aux rest)$ ] >>)
- else
- (true, <:expr< Some $mlexpr_of_list (fun x -> x) l$ >>)
- with Exit -> aux rest in
- let (nonempty,v) = aux prodsl in
- if nonempty then (s,v) :: possibly_empty_subentries loc l
- else possibly_empty_subentries loc l
-
-let possibly_atomic loc prods =
- let l = List.map_filter (function
- | GramTerminal s :: l, _, _ -> Some (s,l)
- | _ -> None) prods
+let rec possibly_atomic loc = function
+| [] -> []
+| ((GramNonTerminal _ :: _ | []), _, _) :: rem ->
+ (** This is not parsed by the TACTIC EXTEND rules *)
+ assert false
+| (GramTerminal s :: prods, _, _) :: rem ->
+ let entry =
+ try
+ let l = List.map make_empty_check prods in
+ let l = mlexpr_of_list (fun x -> x) l in
+ (s, <:expr< try Some $l$ with [ Exit -> None ] >>)
+ with Exit -> (s, <:expr< None >>)
in
- possibly_empty_subentries loc (List.factorize_left String.equal l)
+ entry :: possibly_atomic loc rem
(** Special treatment of constr entries *)
let is_constr_gram = function
| GramTerminal _ -> false
| GramNonTerminal (_, _, e, _) ->
match e with
- | Aentry ("constr", "constr") -> true
+ | Aentry e ->
+ begin match Entry.repr e with
+ | Entry.Static ("constr", "constr") -> true
+ | _ -> false
+ end
| _ -> false
let make_var = function
@@ -188,6 +188,7 @@ let declare_tactic loc s c cl = match cl with
let vars = mlexpr_of_list (mlexpr_of_option mlexpr_of_ident) vars in
let entry = mlexpr_of_string s in
let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in
+ let ml = <:expr< { Tacexpr.mltac_name = $se$; Tacexpr.mltac_index = 0 } >> in
let name = mlexpr_of_string name in
let tac =
(** Special handling of tactics without arguments: such tactics do not do
@@ -202,13 +203,13 @@ let declare_tactic loc s c cl = match cl with
(** Arguments are not passed directly to the ML tactic in the TacML node,
the ML tactic retrieves its arguments in the [ist] environment instead.
This is the rôle of the [lift_constr_tac_to_ml_tac] function. *)
- let body = <:expr< Tacexpr.TacFun ($vars$, Tacexpr.TacML ($dloc$, $se$, [])) >> in
+ let body = <:expr< Tacexpr.TacFun ($vars$, Tacexpr.TacML ($dloc$, $ml$, [])) >> in
let name = <:expr< Names.Id.of_string $name$ >> in
declare_str_items loc
[ <:str_item< do {
let obj () = Tacenv.register_ltac True False $name$ $body$ in
try do {
- Tacenv.register_ml_tactic $se$ $tac$;
+ Tacenv.register_ml_tactic $se$ [|$tac$|];
Mltop.declare_cache_obj obj $plugin_name$; }
with [ e when Errors.noncritical e ->
Pp.msg_warning
@@ -221,7 +222,7 @@ let declare_tactic loc s c cl = match cl with
TacML tactic. *)
let entry = mlexpr_of_string s in
let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in
- let pp = make_printing_rule se cl in
+ let pp = make_printing_rule cl in
let gl = mlexpr_of_clause cl in
let atom =
mlexpr_of_list (mlexpr_of_pair mlexpr_of_string (fun x -> x))
@@ -230,9 +231,9 @@ let declare_tactic loc s c cl = match cl with
declare_str_items loc
[ <:str_item< do {
try do {
- Tacenv.register_ml_tactic $se$ $make_fun_clauses loc s cl$;
+ Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc s cl$);
Mltop.declare_cache_obj $obj$ $plugin_name$;
- List.iter (fun (s, r) -> Pptactic.declare_ml_tactic_pprule s r) $pp$; }
+ Pptactic.declare_ml_tactic_pprule $se$ (Array.of_list $pp$); }
with [ e when Errors.noncritical e ->
Pp.msg_warning
(Pp.app
@@ -265,10 +266,10 @@ EXTEND
;
tacargs:
[ [ e = LIDENT; "("; s = LIDENT; ")" ->
- let t, g = interp_entry_name false None e "" in
+ let EntryName (t, g) = interp_entry_name false TgAny e "" in
GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
| e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
- let t, g = interp_entry_name false None e sep in
+ let EntryName (t, g) = interp_entry_name false TgAny e sep in
GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
| s = STRING ->
if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal.");
diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4
index 03061d8bd..54638556d 100644
--- a/grammar/vernacextend.ml4
+++ b/grammar/vernacextend.ml4
@@ -22,7 +22,7 @@ open Compat
type rule = {
r_head : string option;
(** The first terminal grammar token *)
- r_patt : grammar_prod_item list;
+ r_patt : Vernacexpr.vernac_expr grammar_prod_item list;
(** The remaining tokens of the parsing rule *)
r_class : MLast.expr option;
(** An optional classifier for the STM *)
@@ -35,6 +35,7 @@ type rule = {
let rec make_let e = function
| [] -> e
| GramNonTerminal(loc,t,_,Some p)::l ->
+ let t = Genarg.unquote t in
let loc = of_coqloc loc in
let p = Names.Id.to_string p in
let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in
@@ -181,10 +182,10 @@ EXTEND
;
args:
[ [ e = LIDENT; "("; s = LIDENT; ")" ->
- let t, g = interp_entry_name false None e "" in
+ let EntryName (t, g) = interp_entry_name false TgAny e "" in
GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
| e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
- let t, g = interp_entry_name false None e sep in
+ let EntryName (t, g) = interp_entry_name false TgAny e sep in
GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
| s = STRING ->
GramTerminal s
diff --git a/ide/coq.ml b/ide/coq.ml
index b7753e6e8..a60f327b4 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -125,7 +125,7 @@ and asks_for_coqtop args =
~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in
match pb_mes#run () with
| `YES ->
- let () = current.cmd_coqtop <- None in
+ let () = cmd_coqtop#set None in
let () = custom_coqtop := None in
let () = pb_mes#destroy () in
filter_coq_opts args
@@ -302,13 +302,13 @@ let handle_intermediate_message handle xml =
let logger = match handle.waiting_for with
| Some (_, l) -> l
| None -> function
- | Pp.Error -> Minilib.log ~level:`ERROR
- | Pp.Info -> Minilib.log ~level:`INFO
- | Pp.Notice -> Minilib.log ~level:`NOTICE
- | Pp.Warning -> Minilib.log ~level:`WARNING
- | Pp.Debug _ -> Minilib.log ~level:`DEBUG
+ | Pp.Error -> fun s -> Minilib.log ~level:`ERROR (xml_to_string s)
+ | Pp.Info -> fun s -> Minilib.log ~level:`INFO (xml_to_string s)
+ | Pp.Notice -> fun s -> Minilib.log ~level:`NOTICE (xml_to_string s)
+ | Pp.Warning -> fun s -> Minilib.log ~level:`WARNING (xml_to_string s)
+ | Pp.Debug _ -> fun s -> Minilib.log ~level:`DEBUG (xml_to_string s)
in
- logger level content
+ logger level (Richpp.richpp_of_xml content)
let handle_feedback feedback_processor xml =
let feedback = Feedback.to_feedback xml in
@@ -336,7 +336,7 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all =
let lex = Lexing.from_string s in
let p = Xml_parser.make (Xml_parser.SLexbuf lex) in
let rec loop () =
- let xml = Xml_parser.parse p in
+ let xml = Xml_parser.parse ~do_not_canonicalize:true p in
let l_end = Lexing.lexeme_end lex in
state.fragment <- String.sub s l_end (String.length s - l_end);
state.lexerror <- None;
diff --git a/ide/coqOps.ml b/ide/coqOps.ml
index ba9ab9672..8bfc70b63 100644
--- a/ide/coqOps.ml
+++ b/ide/coqOps.ml
@@ -130,8 +130,6 @@ end = struct
end
open SentenceId
-let prefs = Preferences.current
-
let log msg : unit task =
Coq.lift (fun () -> Minilib.log msg)
@@ -160,12 +158,19 @@ object
end
let flags_to_color f =
- let of_col c = `NAME (Tags.string_of_color c) in
if List.mem `PROCESSING f then `NAME "blue"
else if List.mem `ERROR f then `NAME "red"
else if List.mem `UNSAFE f then `NAME "orange"
else if List.mem `INCOMPLETE f then `NAME "gray"
- else of_col (Tags.get_processed_color ())
+ else `NAME Preferences.processed_color#get
+
+let validate s =
+ let open Xml_datatype in
+ let rec validate = function
+ | PCData s -> Glib.Utf8.validate s
+ | Element (_, _, children) -> List.for_all validate children
+ in
+ validate (Richpp.repr s)
module Doc = Document
@@ -322,7 +327,7 @@ object(self)
method raw_coq_query phrase =
let action = log "raw_coq_query starting now" in
let display_error s =
- if not (Glib.Utf8.validate s) then
+ if not (validate s) then
flash_info "This error is so nasty that I can't even display it."
else messages#add s;
in
@@ -331,7 +336,7 @@ object(self)
let next = function
| Fail (_, _, err) -> display_error err; Coq.return ()
| Good msg ->
- messages#add msg; Coq.return ()
+ messages#add_string msg; Coq.return ()
in
Coq.bind (Coq.seq action query) next
@@ -559,7 +564,7 @@ object(self)
if Queue.is_empty queue then conclude topstack else
match Queue.pop queue, topstack with
| `Skip(start,stop), [] ->
- logger Pp.Error "You muse close the proof with Qed or Admitted";
+ logger Pp.Error (Richpp.richpp_of_string "You muse close the proof with Qed or Admitted");
self#discard_command_queue queue;
conclude []
| `Skip(start,stop), (_,s) :: topstack ->
@@ -575,7 +580,7 @@ object(self)
let handle_answer = function
| Good (id, (Util.Inl (* NewTip *) (), msg)) ->
Doc.assign_tip_id document id;
- logger Pp.Notice msg;
+ logger Pp.Notice (Richpp.richpp_of_string msg);
self#commit_queue_transaction sentence;
loop id []
| Good (id, (Util.Inr (* Unfocus *) tip, msg)) ->
@@ -583,7 +588,7 @@ object(self)
let topstack, _ = Doc.context document in
self#exit_focus;
self#cleanup (Doc.cut_at document tip);
- logger Pp.Notice msg;
+ logger Pp.Notice (Richpp.richpp_of_string msg);
self#mark_as_needed sentence;
if Queue.is_empty queue then loop tip []
else loop tip (List.rev topstack)
@@ -602,7 +607,7 @@ object(self)
let next = function
| Good _ ->
messages#clear;
- messages#push Pp.Info "All proof terms checked by the kernel";
+ messages#push Pp.Info (Richpp.richpp_of_string "All proof terms checked by the kernel");
Coq.return ()
| Fail x -> self#handle_failure x in
Coq.bind (Coq.status ~logger:messages#push true) next
@@ -630,7 +635,7 @@ object(self)
method private process_until_iter iter =
let until _ start stop =
- if prefs.Preferences.stop_before then stop#compare iter > 0
+ if Preferences.stop_before#get then stop#compare iter > 0
else start#compare iter >= 0
in
self#process_until until false
@@ -696,7 +701,7 @@ object(self)
self#cleanup (Doc.cut_at document to_id);
conclusion ()
| Fail (safe_id, loc, msg) ->
- if loc <> None then messages#push Pp.Error "Fixme LOC";
+ if loc <> None then messages#push Pp.Error (Richpp.richpp_of_string "Fixme LOC");
messages#push Pp.Error msg;
if Stateid.equal safe_id Stateid.dummy then self#show_goals
else undo safe_id
@@ -772,7 +777,7 @@ object(self)
self#show_goals
in
let display_error (loc, s) =
- if not (Glib.Utf8.validate s) then
+ if not (validate s) then
flash_info "This error is so nasty that I can't even display it."
else messages#add s
in
@@ -782,10 +787,10 @@ object(self)
let next = function
| Fail (_, l, str) -> (* FIXME: check *)
display_error (l, str);
- messages#add ("Unsuccessfully tried: "^phrase);
+ messages#add (Richpp.richpp_of_string ("Unsuccessfully tried: "^phrase));
more
| Good msg ->
- messages#add msg;
+ messages#add_string msg;
stop Tags.Script.processed
in
Coq.bind (Coq.seq action query) next
@@ -829,7 +834,7 @@ object(self)
method initialize =
let get_initial_state =
let next = function
- | Fail _ -> messages#set ("Couln't initialize Coq"); Coq.return ()
+ | Fail _ -> messages#set (Richpp.richpp_of_string "Couln't initialize Coq"); Coq.return ()
| Good id -> initial_state <- id; Coq.return () in
Coq.bind (Coq.init (get_filename ())) next in
Coq.seq get_initial_state Coq.PrintOpt.enforce
diff --git a/ide/coqide.ml b/ide/coqide.ml
index f15e5fa34..5fdb4a2a4 100644
--- a/ide/coqide.ml
+++ b/ide/coqide.ml
@@ -44,8 +44,6 @@ open Session
(** {2 Some static elements } *)
-let prefs = Preferences.current
-
(** The arguments that will be passed to coqtop. No quoting here, since
no /bin/sh when using create_process instead of open_process. *)
let custom_project_files = ref []
@@ -87,9 +85,9 @@ let make_coqtop_args = function
|None -> "", !sup_args
|Some the_file ->
let get_args f = Project_file.args_from_project f
- !custom_project_files prefs.project_file_name
+ !custom_project_files project_file_name#get
in
- match prefs.read_project with
+ match read_project#get with
|Ignore_args -> "", !sup_args
|Append_args ->
let fname, args = get_args the_file in fname, args @ !sup_args
@@ -164,7 +162,6 @@ let load_file ?(maycreate=false) f =
input_buffer#place_cursor ~where:input_buffer#start_iter;
Sentence.tag_all input_buffer;
session.script#clear_undo ();
- !refresh_editor_hook ();
Minilib.log "Loading: success";
end
with e -> flash_info ("Load failed: "^(Printexc.to_string e))
@@ -250,7 +247,6 @@ module File = struct
let newfile _ =
let session = create_session None in
let index = notebook#append_term session in
- !refresh_editor_hook ();
notebook#goto_page index
let load _ =
@@ -319,13 +315,13 @@ let export kind sn =
| _ -> assert false
in
let cmd =
- local_cd f ^ prefs.cmd_coqdoc ^ " --" ^ kind ^ " -o " ^
+ local_cd f ^ cmd_coqdoc#get ^ " --" ^ kind ^ " -o " ^
(Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1"
in
- sn.messages#set ("Running: "^cmd);
+ sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd));
let finally st = flash_info (cmd ^ pr_exit_status st)
in
- run_command sn.messages#add finally cmd
+ run_command (fun msg -> sn.messages#add_string msg) finally cmd
let export kind = cb_on_current_term (export kind)
@@ -334,8 +330,8 @@ let print sn =
|None -> flash_info "Cannot print: this buffer has no name"
|Some f_name ->
let cmd =
- local_cd f_name ^ prefs.cmd_coqdoc ^ " -ps " ^
- Filename.quote (Filename.basename f_name) ^ " | " ^ prefs.cmd_print
+ local_cd f_name ^ cmd_coqdoc#get ^ " -ps " ^
+ Filename.quote (Filename.basename f_name) ^ " | " ^ cmd_print#get
in
let w = GWindow.window ~title:"Print" ~modal:true
~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" ()
@@ -378,17 +374,17 @@ end
let reset_revert_timer () =
FileOps.revert_timer.kill ();
- if prefs.global_auto_revert then
+ if global_auto_revert#get then
FileOps.revert_timer.run
- ~ms:prefs.global_auto_revert_delay
+ ~ms:global_auto_revert_delay#get
~callback:(fun () -> File.revert_all (); true)
let reset_autosave_timer () =
let autosave sn = try sn.fileops#auto_save with _ -> () in
let autosave_all () = List.iter autosave notebook#pages; true in
FileOps.autosave_timer.kill ();
- if prefs.auto_save then
- FileOps.autosave_timer.run ~ms:prefs.auto_save_delay ~callback:autosave_all
+ if auto_save#get then
+ FileOps.autosave_timer.run ~ms:auto_save_delay#get ~callback:autosave_all
(** Export of functions used in [coqide_main] : *)
@@ -408,8 +404,8 @@ let coq_makefile sn =
match sn.fileops#filename with
|None -> flash_info "Cannot make makefile: this buffer has no name"
|Some f ->
- let cmd = local_cd f ^ prefs.cmd_coqmakefile in
- let finally st = flash_info (current.cmd_coqmakefile ^ pr_exit_status st)
+ let cmd = local_cd f ^ cmd_coqmakefile#get in
+ let finally st = flash_info (cmd_coqmakefile#get ^ pr_exit_status st)
in
run_command ignore finally cmd
@@ -421,7 +417,7 @@ let editor sn =
|Some f ->
File.save ();
let f = Filename.quote f in
- let cmd = Util.subst_command_placeholder prefs.cmd_editor f in
+ let cmd = Util.subst_command_placeholder cmd_editor#get f in
run_command ignore (fun _ -> sn.fileops#revert) cmd
let editor = cb_on_current_term editor
@@ -431,13 +427,13 @@ let compile sn =
match sn.fileops#filename with
|None -> flash_info "Active buffer has no name"
|Some f ->
- let cmd = prefs.cmd_coqc ^ " -I " ^ (Filename.quote (Filename.dirname f))
+ let cmd = cmd_coqc#get ^ " -I " ^ (Filename.quote (Filename.dirname f))
^ " " ^ (Filename.quote f) ^ " 2>&1"
in
let buf = Buffer.create 1024 in
- sn.messages#set ("Running: "^cmd);
+ sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd));
let display s =
- sn.messages#add s;
+ sn.messages#add_string s;
Buffer.add_string buf s
in
let finally st =
@@ -445,8 +441,8 @@ let compile sn =
flash_info (f ^ " successfully compiled")
else begin
flash_info (f ^ " failed to compile");
- sn.messages#set "Compilation output:\n";
- sn.messages#add (Buffer.contents buf);
+ sn.messages#set (Richpp.richpp_of_string "Compilation output:\n");
+ sn.messages#add (Richpp.richpp_of_string (Buffer.contents buf));
end
in
run_command display finally cmd
@@ -467,17 +463,17 @@ let make sn =
|None -> flash_info "Cannot make: this buffer has no name"
|Some f ->
File.saveall ();
- let cmd = local_cd f ^ prefs.cmd_make ^ " 2>&1" in
- sn.messages#set "Compilation output:\n";
+ let cmd = local_cd f ^ cmd_make#get ^ " 2>&1" in
+ sn.messages#set (Richpp.richpp_of_string "Compilation output:\n");
Buffer.reset last_make_buf;
last_make := "";
last_make_index := 0;
last_make_dir := Filename.dirname f;
let display s =
- sn.messages#add s;
+ sn.messages#add_string s;
Buffer.add_string last_make_buf s
in
- let finally st = flash_info (current.cmd_make ^ pr_exit_status st)
+ let finally st = flash_info (cmd_make#get ^ pr_exit_status st)
in
run_command display finally cmd
@@ -512,11 +508,11 @@ let next_error sn =
let stopi = b#get_iter_at_byte ~line:(line-1) stop in
b#apply_tag Tags.Script.error ~start:starti ~stop:stopi;
b#place_cursor ~where:starti;
- sn.messages#set error_msg;
+ sn.messages#set (Richpp.richpp_of_string error_msg);
sn.script#misc#grab_focus ()
with Not_found ->
last_make_index := 0;
- sn.messages#set "No more errors.\n"
+ sn.messages#set (Richpp.richpp_of_string "No more errors.\n")
let next_error = cb_on_current_term next_error
@@ -537,7 +533,7 @@ let update_status sn =
| None -> ""
| Some n -> ", proving " ^ n
in
- display ("Ready"^ (if current.nanoPG then ", [μPG]" else "") ^ path ^ name);
+ display ("Ready"^ (if nanoPG#get then ", [μPG]" else "") ^ path ^ name);
Coq.return ()
in
Coq.bind (Coq.status ~logger:sn.messages#push false) next
@@ -722,7 +718,7 @@ let initial_about () =
else ""
in
let msg = initial_string ^ version_info ^ log_file_message () in
- on_current_term (fun term -> term.messages#add msg)
+ on_current_term (fun term -> term.messages#add_string msg)
let coq_icon () =
(* May raise Nof_found *)
@@ -787,7 +783,7 @@ let coqtop_arguments sn =
let args = String.concat " " args in
let msg = Printf.sprintf "Invalid arguments: %s" args in
let () = sn.messages#clear in
- sn.messages#push Pp.Error msg
+ sn.messages#push Pp.Error (Richpp.richpp_of_string msg)
else dialog#destroy ()
in
let _ = entry#connect#activate ok_cb in
@@ -809,69 +805,19 @@ let zoom_fit sn =
let cols = script#right_margin_position in
let pango_ctx = script#misc#pango_context in
let layout = pango_ctx#create_layout in
- let fsize = Pango.Font.get_size current.text_font in
+ let fsize = Pango.Font.get_size (Pango.Font.from_string text_font#get) in
Pango.Layout.set_text layout (String.make cols 'X');
let tlen = fst (Pango.Layout.get_pixel_size layout) in
- Pango.Font.set_size current.text_font
+ Pango.Font.set_size (Pango.Font.from_string text_font#get)
(fsize * space / tlen / Pango.scale * Pango.scale);
- save_pref ();
- !refresh_editor_hook ()
+ save_pref ()
end
(** Refresh functions *)
-let refresh_editor_prefs () =
- let wrap_mode = if prefs.dynamic_word_wrap then `WORD else `NONE in
- let show_spaces =
- if prefs.show_spaces then 0b1001011 (* SPACE, TAB, NBSP, TRAILING *)
- else 0
- in
- let fd = prefs.text_font in
- let clr = Tags.color_of_string prefs.background_color
- in
- let iter_session sn =
- (* Editor settings *)
- sn.script#set_wrap_mode wrap_mode;
- sn.script#set_show_line_numbers prefs.show_line_number;
- sn.script#set_auto_indent prefs.auto_indent;
- sn.script#set_highlight_current_line prefs.highlight_current_line;
-
- (* Hack to handle missing binding in lablgtk *)
- let conv = { Gobject.name = "draw-spaces"; Gobject.conv = Gobject.Data.int }
- in
- Gobject.set conv sn.script#as_widget show_spaces;
-
- sn.script#set_show_right_margin prefs.show_right_margin;
- if prefs.show_progress_bar then sn.segment#misc#show () else sn.segment#misc#hide ();
- sn.script#set_insert_spaces_instead_of_tabs
- prefs.spaces_instead_of_tabs;
- sn.script#set_tab_width prefs.tab_length;
- sn.script#set_auto_complete prefs.auto_complete;
-
- (* Fonts *)
- sn.script#misc#modify_font fd;
- sn.proof#misc#modify_font fd;
- sn.messages#modify_font fd;
- sn.command#refresh_font ();
-
- (* Colors *)
- Tags.set_processing_color (Tags.color_of_string current.processing_color);
- Tags.set_processed_color (Tags.color_of_string current.processed_color);
- Tags.set_error_color (Tags.color_of_string current.error_color);
- Tags.set_error_fg_color (Tags.color_of_string current.error_fg_color);
- sn.script#misc#modify_base [`NORMAL, `COLOR clr];
- sn.proof#misc#modify_base [`NORMAL, `COLOR clr];
- sn.messages#refresh_color ();
- sn.command#refresh_color ();
- sn.errpage#refresh_color ();
- sn.jobpage#refresh_color ();
-
- in
- List.iter iter_session notebook#pages
-
let refresh_notebook_pos () =
- let pos = match prefs.vertical_tabs, prefs.opposite_tabs with
+ let pos = match vertical_tabs#get, opposite_tabs#get with
| false, false -> `TOP
| false, true -> `BOTTOM
| true , false -> `LEFT
@@ -906,7 +852,7 @@ let toggle_items menu_name l =
let f d =
let label = d.Opt.label in
let k, name = get_shortcut label in
- let accel = Option.map ((^) prefs.modifier_for_display) k in
+ let accel = Option.map ((^) modifier_for_display#get) k in
toggle_item name ~label ?accel ~active:d.Opt.init
~callback:(printopts_callback d.Opt.opts)
menu_name
@@ -948,7 +894,7 @@ let alpha_items menu_name item_name l =
Caveat: the offset is now from the start of the text. *)
let template_item (text, offset, len, key) =
- let modifier = prefs.modifier_for_templates in
+ let modifier = modifier_for_templates#get in
let idx = String.index text ' ' in
let name = String.sub text 0 idx in
let label = "_"^name^" __" in
@@ -976,7 +922,7 @@ let build_ui () =
let w = GWindow.window
~wm_class:"CoqIde" ~wm_name:"CoqIde"
~allow_grow:true ~allow_shrink:true
- ~width:prefs.window_width ~height:prefs.window_height
+ ~width:window_width#get ~height:window_height#get
~title:"CoqIde" ()
in
let () =
@@ -1074,77 +1020,60 @@ let build_ui () =
~callback:(fun _ -> notebook#next_page ());
item "Zoom in" ~label:"_Zoom in" ~accel:("<Control>plus")
~stock:`ZOOM_IN ~callback:(fun _ ->
- Pango.Font.set_size current.text_font
- (Pango.Font.get_size current.text_font + Pango.scale);
- save_pref ();
- !refresh_editor_hook ());
+ let ft = Pango.Font.from_string text_font#get in
+ Pango.Font.set_size ft (Pango.Font.get_size ft + Pango.scale);
+ text_font#set (Pango.Font.to_string ft);
+ save_pref ());
item "Zoom out" ~label:"_Zoom out" ~accel:("<Control>minus")
~stock:`ZOOM_OUT ~callback:(fun _ ->
- Pango.Font.set_size current.text_font
- (Pango.Font.get_size current.text_font - Pango.scale);
- save_pref ();
- !refresh_editor_hook ());
+ let ft = Pango.Font.from_string text_font#get in
+ Pango.Font.set_size ft (Pango.Font.get_size ft - Pango.scale);
+ text_font#set (Pango.Font.to_string ft);
+ save_pref ());
item "Zoom fit" ~label:"_Zoom fit" ~accel:("<Control>0")
~stock:`ZOOM_FIT ~callback:(cb_on_current_term MiscMenu.zoom_fit);
toggle_item "Show Toolbar" ~label:"Show _Toolbar"
- ~active:(prefs.show_toolbar)
- ~callback:(fun _ ->
- prefs.show_toolbar <- not prefs.show_toolbar;
- !refresh_toolbar_hook ());
+ ~active:(show_toolbar#get)
+ ~callback:(fun _ -> show_toolbar#set (not show_toolbar#get));
item "Query Pane" ~label:"_Query Pane"
~accel:"F1"
~callback:(cb_on_current_term MiscMenu.show_hide_query_pane)
];
toggle_items view_menu Coq.PrintOpt.bool_items;
- menu navigation_menu [
- item "Navigation" ~label:"_Navigation";
- item "Forward" ~label:"_Forward" ~stock:`GO_DOWN ~callback:Nav.forward_one
- ~tooltip:"Forward one command"
- ~accel:(prefs.modifier_for_navigation^"Down");
- item "Backward" ~label:"_Backward" ~stock:`GO_UP ~callback:Nav.backward_one
- ~tooltip:"Backward one command"
- ~accel:(prefs.modifier_for_navigation^"Up");
- item "Go to" ~label:"_Go to" ~stock:`JUMP_TO ~callback:Nav.goto
- ~tooltip:"Go to cursor"
- ~accel:(prefs.modifier_for_navigation^"Right");
- item "Start" ~label:"_Start" ~stock:`GOTO_TOP ~callback:Nav.restart
- ~tooltip:"Restart coq"
- ~accel:(prefs.modifier_for_navigation^"Home");
- item "End" ~label:"_End" ~stock:`GOTO_BOTTOM ~callback:Nav.goto_end
- ~tooltip:"Go to end"
- ~accel:(prefs.modifier_for_navigation^"End");
- item "Interrupt" ~label:"_Interrupt" ~stock:`STOP ~callback:Nav.interrupt
- ~tooltip:"Interrupt computations"
- ~accel:(prefs.modifier_for_navigation^"Break");
-(* wait for this available in GtkSourceView !
- item "Hide" ~label:"_Hide" ~stock:`MISSING_IMAGE
- ~callback:(fun _ -> let sess = notebook#current_term in
- toggle_proof_visibility sess.buffer
- sess.analyzed_view#get_insert) ~tooltip:"Hide proof"
- ~accel:(prefs.modifier_for_navigation^"h");*)
- item "Previous" ~label:"_Previous" ~stock:`GO_BACK
- ~callback:Nav.previous_occ
- ~tooltip:"Previous occurrence"
- ~accel:(prefs.modifier_for_navigation^"less");
- item "Next" ~label:"_Next" ~stock:`GO_FORWARD ~callback:Nav.next_occ
- ~tooltip:"Next occurrence"
- ~accel:(prefs.modifier_for_navigation^"greater");
- item "Force" ~label:"_Force" ~stock:`EXECUTE ~callback:Nav.join_document
- ~tooltip:"Fully check the document"
- ~accel:(current.modifier_for_navigation^"f");
- ];
+ let navitem (text, label, stock, callback, tooltip, accel) =
+ let accel = modifier_for_navigation#get ^ accel in
+ item text ~label ~stock ~callback ~tooltip ~accel
+ in
+ menu navigation_menu begin
+ [
+ (fun e -> item "Navigation" ~label:"_Navigation" e);
+ ] @ List.map navitem [
+ ("Forward", "_Forward", `GO_DOWN, Nav.forward_one, "Forward one command", "Down");
+ ("Backward", "_Backward", `GO_UP, Nav.backward_one, "Backward one command", "Up");
+ ("Go to", "_Go to", `JUMP_TO, Nav.goto, "Go to cursor", "Right");
+ ("Start", "_Start", `GOTO_TOP, Nav.restart, "Restart coq", "Home");
+ ("End", "_End", `GOTO_BOTTOM, Nav.goto_end, "Go to end", "End");
+ ("Interrupt", "_Interrupt", `STOP, Nav.interrupt, "Interrupt computations", "Break");
+ (* wait for this available in GtkSourceView !
+ ("Hide", "_Hide", `MISSING_IMAGE,
+ ~callback:(fun _ -> let sess = notebook#current_term in
+ toggle_proof_visibility sess.buffer sess.analyzed_view#get_insert), "Hide proof", "h"); *)
+ ("Previous", "_Previous", `GO_BACK, Nav.previous_occ, "Previous occurrence", "less");
+ ("Next", "_Next", `GO_FORWARD, Nav.next_occ, "Next occurrence", "greater");
+ ("Force", "_Force", `EXECUTE, Nav.join_document, "Fully check the document", "f");
+ ] end;
let tacitem s sc =
item s ~label:("_"^s)
- ~accel:(prefs.modifier_for_tactics^sc)
+ ~accel:(modifier_for_tactics#get^sc)
~callback:(tactic_wizard_callback [s])
in
menu tactics_menu [
item "Try Tactics" ~label:"_Try Tactics";
item "Wizard" ~label:"<Proof Wizard>" ~stock:`DIALOG_INFO
- ~tooltip:"Proof Wizard" ~accel:(prefs.modifier_for_tactics^"dollar")
- ~callback:(tactic_wizard_callback prefs.automatic_tactics);
+ ~tooltip:"Proof Wizard" ~accel:(modifier_for_tactics#get^"dollar")
+ ~callback:(tactic_wizard_callback automatic_tactics#get);
tacitem "auto" "a";
tacitem "auto with *" "asterisk";
tacitem "eauto" "e";
@@ -1166,7 +1095,7 @@ let build_ui () =
template_item ("Fixpoint ident (_ : _) {struct _} : _ :=\n.\n", 9,5, "F");
template_item ("Scheme new_scheme := Induction for _ Sort _\n" ^
"with _ := Induction for _ Sort _.\n", 7,10, "S");
- item "match" ~label:"match ..." ~accel:(prefs.modifier_for_templates^"M")
+ item "match" ~label:"match ..." ~accel:(modifier_for_templates#get^"M")
~callback:match_callback
];
alpha_items templates_menu "Template" Coq_commands.commands;
@@ -1211,17 +1140,17 @@ let build_ui () =
item "Help" ~label:"_Help";
item "Browse Coq Manual" ~label:"Browse Coq _Manual"
~callback:(fun _ ->
- browse notebook#current_term.messages#add (doc_url ()));
+ browse notebook#current_term.messages#add_string (doc_url ()));
item "Browse Coq Library" ~label:"Browse Coq _Library"
~callback:(fun _ ->
- browse notebook#current_term.messages#add prefs.library_url);
+ browse notebook#current_term.messages#add_string library_url#get);
item "Help for keyword" ~label:"Help for _keyword" ~stock:`HELP
~callback:(fun _ -> on_current_term (fun sn ->
- browse_keyword sn.messages#add (get_current_word sn)));
+ browse_keyword sn.messages#add_string (get_current_word sn)));
item "Help for μPG mode" ~label:"Help for μPG mode"
~callback:(fun _ -> on_current_term (fun sn ->
sn.messages#clear;
- sn.messages#add (NanoPG.get_documentation ())));
+ sn.messages#add_string (NanoPG.get_documentation ())));
item "About Coq" ~label:"_About" ~stock:`ABOUT
~callback:MiscMenu.about
];
@@ -1259,7 +1188,7 @@ let build_ui () =
(* Reset on tab switch *)
let _ = notebook#connect#switch_page ~callback:(fun _ ->
- if prefs.reset_on_tab_switch then Nav.restart ())
+ if reset_on_tab_switch#get then Nav.restart ())
in
(* Vertical Separator between Scripts and Goals *)
@@ -1267,7 +1196,7 @@ let build_ui () =
let () = refresh_notebook_pos () in
let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
let () = lower_hbox#pack ~expand:true status#coerce in
- let () = push_info ("Ready"^ if current.nanoPG then ", [μPG]" else "") in
+ let () = push_info ("Ready"^ if nanoPG#get then ", [μPG]" else "") in
(* Location display *)
let l = GMisc.label
@@ -1310,43 +1239,33 @@ let build_ui () =
let _ = Glib.Timeout.add ~ms:300 ~callback in
(* Initializing hooks *)
- let refresh_toolbar () =
- if prefs.show_toolbar
- then toolbar#misc#show ()
- else toolbar#misc#hide ()
- in
- let refresh_style () =
- let style = style_manager#style_scheme prefs.source_style in
+ let refresh_style style =
+ let style = style_manager#style_scheme style in
let iter_session v = v.script#source_buffer#set_style_scheme style in
List.iter iter_session notebook#pages
in
- let refresh_language () =
- let lang = lang_manager#language prefs.source_language in
+ let refresh_language lang =
+ let lang = lang_manager#language lang in
let iter_session v = v.script#source_buffer#set_language lang in
List.iter iter_session notebook#pages
in
- let resize_window () =
- w#resize ~width:prefs.window_width ~height:prefs.window_height
+ let refresh_toolbar b =
+ if b then toolbar#misc#show () else toolbar#misc#hide ()
in
- refresh_toolbar ();
- refresh_toolbar_hook := refresh_toolbar;
- refresh_style_hook := refresh_style;
- refresh_language_hook := refresh_language;
- refresh_editor_hook := refresh_editor_prefs;
- resize_window_hook := resize_window;
- refresh_tabs_hook := refresh_notebook_pos;
+ stick show_toolbar toolbar refresh_toolbar;
+ let _ = source_style#connect#changed refresh_style in
+ let _ = source_language#connect#changed refresh_language in
(* Color configuration *)
Tags.Script.incomplete#set_property
(`BACKGROUND_STIPPLE
(Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\x01\x02"));
- Tags.Script.incomplete#set_property
- (`BACKGROUND_GDK (Tags.get_processed_color ()));
(* Showtime ! *)
w#show ()
+
(** {2 Coqide main function } *)
let make_file_buffer f =
@@ -1356,7 +1275,7 @@ let make_file_buffer f =
let make_scratch_buffer () =
let session = create_session None in
let _ = notebook#append_term session in
- !refresh_editor_hook ()
+ ()
let main files =
build_ui ();
diff --git a/ide/fileOps.ml b/ide/fileOps.ml
index 03b3fcd4e..eccd61d0d 100644
--- a/ide/fileOps.ml
+++ b/ide/fileOps.ml
@@ -8,8 +8,6 @@
open Ideutils
-let prefs = Preferences.current
-
let revert_timer = mktimer ()
let autosave_timer = mktimer ()
@@ -87,7 +85,7 @@ object(self)
flash_info "Could not overwrite file"
| _ ->
Minilib.log "Auto revert set to false";
- prefs.Preferences.global_auto_revert <- false;
+ Preferences.global_auto_revert#set false;
revert_timer.kill ()
method save f =
@@ -120,9 +118,9 @@ object(self)
| None -> None
| Some f ->
let dir = Filename.dirname f in
- let base = (fst prefs.Preferences.auto_save_name) ^
+ let base = (fst Preferences.auto_save_name#get) ^
(Filename.basename f) ^
- (snd prefs.Preferences.auto_save_name)
+ (snd Preferences.auto_save_name#get)
in Some (Filename.concat dir base)
method private need_auto_save =
diff --git a/ide/ide.mllib b/ide/ide.mllib
index e082bd18c..83b314283 100644
--- a/ide/ide.mllib
+++ b/ide/ide.mllib
@@ -9,7 +9,6 @@ Configwin
Editable_cells
Config_parser
Tags
-Wg_Segment
Wg_Notebook
Config_lexer
Utf8_convert
@@ -21,6 +20,7 @@ Coq
Coq_lex
Sentence
Gtk_parsing
+Wg_Segment
Wg_ProofView
Wg_MessageView
Wg_Detachable
diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml
index 041f2f83b..a6c42b28c 100644
--- a/ide/ide_slave.ml
+++ b/ide/ide_slave.ml
@@ -184,12 +184,13 @@ let process_goal sigma g =
let id = Goal.uid g in
let ccl =
let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in
- string_of_ppcmds (pr_goal_concl_style_env env sigma norm_constr) in
+ Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr)
+ in
let process_hyp d (env,l) =
let d = Context.map_named_list_declaration (Reductionops.nf_evar sigma) d in
let d' = List.map (fun x -> (x, pi2 d, pi3 d)) (pi1 d) in
(List.fold_right Environ.push_named d' env,
- (string_of_ppcmds (pr_var_list_decl env sigma d)) :: l) in
+ (Richpp.richpp_of_pp (pr_var_list_decl env sigma d)) :: l) in
let (_env, hyps) =
Context.fold_named_list_context process_hyp
(Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in
@@ -333,10 +334,14 @@ let handle_exn (e, info) =
let loc_of e = match Loc.get_loc e with
| Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc)
| _ -> None in
- let mk_msg () = read_stdout ()^"\n"^string_of_ppcmds (Errors.print ~info e) in
+ let mk_msg () =
+ let msg = read_stdout () in
+ let msg = str msg ++ fnl () ++ Errors.print ~info e in
+ Richpp.richpp_of_pp msg
+ in
match e with
- | Errors.Drop -> dummy, None, "Drop is not allowed by coqide!"
- | Errors.Quit -> dummy, None, "Quit is not allowed by coqide!"
+ | Errors.Drop -> dummy, None, Richpp.richpp_of_string "Drop is not allowed by coqide!"
+ | Errors.Quit -> dummy, None, Richpp.richpp_of_string "Quit is not allowed by coqide!"
| e ->
match Stateid.get info with
| Some (valid, _) -> valid, loc_of info, mk_msg ()
@@ -432,12 +437,12 @@ let print_xml =
let slave_logger xml_oc level message =
(* convert the message into XML *)
- let msg = string_of_ppcmds (hov 0 message) in
+ let msg = hov 0 message in
let message = {
Pp.message_level = level;
- Pp.message_content = msg;
+ Pp.message_content = (Richpp.repr (Richpp.richpp_of_pp msg));
} in
- let () = pr_debug (Printf.sprintf "-> %S" msg) in
+ let () = pr_debug (Printf.sprintf "-> %S" (string_of_ppcmds msg)) in
let xml = Pp.of_message message in
print_xml xml_oc xml
@@ -469,7 +474,7 @@ let loop () =
try
let xml_query = Xml_parser.parse xml_ic in
(* pr_with_pid (Xml_printer.to_string_fmt xml_query); *)
- let q = Xmlprotocol.to_call xml_query in
+ let Xmlprotocol.Unknown q = Xmlprotocol.to_call xml_query in
let () = pr_debug_call q in
let r = eval_call xml_oc (slave_logger xml_oc Pp.Notice) q in
let () = pr_debug_answer q r in
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index 5892fb3d9..2e4adba73 100644
--- a/ide/ideutils.ml
+++ b/ide/ideutils.ml
@@ -37,7 +37,34 @@ let flash_info =
let flash_context = status#new_context ~name:"Flash" in
(fun ?(delay=5000) s -> flash_context#flash ~delay s)
-
+let xml_to_string xml =
+ let open Xml_datatype in
+ let buf = Buffer.create 1024 in
+ let rec iter = function
+ | PCData s -> Buffer.add_string buf s
+ | Element (_, _, children) ->
+ List.iter iter children
+ in
+ let () = iter (Richpp.repr xml) in
+ Buffer.contents buf
+
+let translate s = s
+
+let insert_xml ?(tags = []) (buf : #GText.buffer_skel) msg =
+ let open Xml_datatype in
+ let tag name =
+ let name = translate name in
+ match GtkText.TagTable.lookup buf#tag_table name with
+ | None -> raise Not_found
+ | Some tag -> new GText.tag tag
+ in
+ let rec insert tags = function
+ | PCData s -> buf#insert ~tags:(List.rev tags) s
+ | Element (t, _, children) ->
+ let tags = try tag t :: tags with Not_found -> tags in
+ List.iter (fun xml -> insert tags xml) children
+ in
+ insert tags (Richpp.repr msg)
let set_location = ref (function s -> failwith "not ready")
@@ -74,7 +101,7 @@ let do_convert s =
in
let s =
if Glib.Utf8.validate s then (Minilib.log "Input is UTF-8"; s)
- else match current.encoding with
+ else match encoding#get with
|Preferences.Eutf8 | Preferences.Elocale -> from_loc ()
|Emanual enc -> try from_manual enc with _ -> from_loc ()
in
@@ -90,7 +117,7 @@ Please choose a correct encoding in the preference panel.*)";;
let try_export file_name s =
let s =
- try match current.encoding with
+ try match encoding#get with
|Eutf8 -> Minilib.log "UTF-8 is enforced" ; s
|Elocale ->
let is_unicode,char_set = Glib.Convert.get_charset () in
@@ -140,7 +167,7 @@ let filter_coq_files () = GFile.filter
~name:"Coq source code"
~patterns:[ "*.v"] ()
-let current_dir () = match current.project_path with
+let current_dir () = match project_path#get with
| None -> ""
| Some dir -> dir
@@ -164,7 +191,7 @@ let select_file_for_open ~title ?filename () =
match file_chooser#filename with
| None -> None
| Some _ as f ->
- current.project_path <- file_chooser#current_folder; f
+ project_path#set file_chooser#current_folder; f
end
| `DELETE_EVENT | `CANCEL -> None in
file_chooser#destroy ();
@@ -193,7 +220,7 @@ let select_file_for_save ~title ?filename () =
file := file_chooser#filename;
match !file with
None -> ()
- | Some s -> current.project_path <- file_chooser#current_folder
+ | Some s -> project_path#set file_chooser#current_folder
end
| `DELETE_EVENT | `CANCEL -> ()
end ;
@@ -238,7 +265,7 @@ let coqtop_path () =
let file = match !custom_coqtop with
| Some s -> s
| None ->
- match current.cmd_coqtop with
+ match cmd_coqtop#get with
| Some s -> s
| None ->
let prog = String.copy Sys.executable_name in
@@ -272,7 +299,7 @@ let textview_width (view : #GText.view_skel) =
let char_width = GPango.to_pixels metrics#approx_char_width in
pixel_width / char_width
-type logger = Pp.message_level -> string -> unit
+type logger = Pp.message_level -> Richpp.richpp -> unit
let default_logger level message =
let level = match level with
@@ -282,7 +309,7 @@ let default_logger level message =
| Pp.Warning -> `WARNING
| Pp.Error -> `ERROR
in
- Minilib.log ~level message
+ Minilib.log ~level (xml_to_string message)
(** {6 File operations} *)
@@ -364,7 +391,7 @@ let run_command display finally cmd =
(** Web browsing *)
let browse prerr url =
- let com = Util.subst_command_placeholder current.cmd_browse url in
+ let com = Util.subst_command_placeholder cmd_browse#get url in
let finally = function
| Unix.WEXITED 127 ->
prerr
@@ -375,13 +402,13 @@ let browse prerr url =
run_command (fun _ -> ()) finally com
let doc_url () =
- if current.doc_url = use_default_doc_url || current.doc_url = ""
+ if doc_url#get = use_default_doc_url || doc_url#get = ""
then
let addr = List.fold_left Filename.concat (Coq_config.docdir)
["html";"refman";"index.html"]
in
if Sys.file_exists addr then "file://"^addr else Coq_config.wwwrefman
- else current.doc_url
+ else doc_url#get
let url_for_keyword =
let ht = Hashtbl.create 97 in
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
index 1fb30e4d7..db2dce5a3 100644
--- a/ide/ideutils.mli
+++ b/ide/ideutils.mli
@@ -52,6 +52,11 @@ val pop_info : unit -> unit
val clear_info : unit -> unit
val flash_info : ?delay:int -> string -> unit
+val xml_to_string : Richpp.richpp -> string
+
+val insert_xml : ?tags:GText.tag list ->
+ #GText.buffer_skel -> Richpp.richpp -> unit
+
val set_location : (string -> unit) ref
(* In win32, when a command-line is to be executed via cmd.exe
@@ -64,9 +69,9 @@ val requote : string -> string
val textview_width : #GText.view_skel -> int
(** Returns an approximate value of the character width of a textview *)
-type logger = Pp.message_level -> string -> unit
+type logger = Pp.message_level -> Richpp.richpp -> unit
-val default_logger : Pp.message_level -> string -> unit
+val default_logger : logger
(** Default logger. It logs messages that the casual user should not see. *)
(** {6 I/O operations} *)
diff --git a/ide/interface.mli b/ide/interface.mli
index 767c49d2b..f2f121ac0 100644
--- a/ide/interface.mli
+++ b/ide/interface.mli
@@ -12,14 +12,15 @@
type raw = bool
type verbose = bool
+type richpp = Richpp.richpp
(** The type of coqtop goals *)
type goal = {
goal_id : string;
(** Unique goal identifier *)
- goal_hyp : string list;
+ goal_hyp : richpp list;
(** List of hypotheses *)
- goal_ccl : string;
+ goal_ccl : richpp;
(** Goal conclusion *)
}
@@ -118,7 +119,7 @@ type edit_id = Feedback.edit_id
should probably retract to that point *)
type 'a value =
| Good of 'a
- | Fail of (state_id * location * string)
+ | Fail of (state_id * location * richpp)
type ('a, 'b) union = ('a, 'b) Util.union
@@ -202,7 +203,7 @@ type about_sty = unit
type about_rty = coq_info
type handle_exn_sty = Exninfo.iexn
-type handle_exn_rty = state_id * location * string
+type handle_exn_rty = state_id * location * richpp
(* Retrocompatibility stuff *)
type interp_sty = (raw * verbose) * string
diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml
index 805ace935..0668ad09f 100644
--- a/ide/nanoPG.ml
+++ b/ide/nanoPG.ml
@@ -303,7 +303,7 @@ let init w nb ags =
then false
else begin
eprintf "got key %s\n%!" (pr_key t);
- if current.nanoPG then begin
+ if nanoPG#get then begin
match find gui !cur t with
| `Do e ->
eprintf "run (%s) %s on %s\n%!" e.keyname e.doc (pr_status !status);
diff --git a/ide/preferences.ml b/ide/preferences.ml
index 90862d064..a605014f2 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -17,19 +17,66 @@ let style_manager = GSourceView2.source_style_scheme_manager ~default:true
let () = style_manager#set_search_path
((Minilib.coqide_data_dirs ())@style_manager#search_path)
-let get_config_file name =
- let find_config dir = Sys.file_exists (Filename.concat dir name) in
- let config_dir = List.find find_config (Minilib.coqide_config_dirs ()) in
- Filename.concat config_dir name
+type tag = {
+ tag_fg_color : string option;
+ tag_bg_color : string option;
+ tag_bold : bool;
+ tag_italic : bool;
+ tag_underline : bool;
+}
-(* Small hack to handle v8.3 to v8.4 change in configuration file *)
-let loaded_pref_file =
- try get_config_file "coqiderc"
- with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqiderc"
+(** Generic preferences *)
-let loaded_accel_file =
- try get_config_file "coqide.keys"
- with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys"
+type obj = {
+ set : string list -> unit;
+ get : unit -> string list;
+}
+
+let preferences : obj Util.String.Map.t ref = ref Util.String.Map.empty
+
+class type ['a] repr =
+object
+ method into : string list -> 'a option
+ method from : 'a -> string list
+end
+
+class ['a] preference_signals ~(changed : 'a GUtil.signal) =
+object
+ inherit GUtil.ml_signals [changed#disconnect]
+ method changed = changed#connect ~after
+end
+
+class ['a] preference ~(name : string list) ~(init : 'a) ~(repr : 'a repr) =
+object (self)
+ initializer
+ let set v = match repr#into v with None -> () | Some s -> self#set s in
+ let get () = repr#from self#get in
+ let obj = { set = set; get = get; } in
+ let name = String.concat "." name in
+ if Util.String.Map.mem name !preferences then
+ invalid_arg ("Preference " ^ name ^ " already exists")
+ else
+ preferences := Util.String.Map.add name obj !preferences
+
+ val default = init
+ val mutable data = init
+ val changed : 'a GUtil.signal = new GUtil.signal ()
+ val name : string list = name
+ method connect = new preference_signals ~changed
+ method get = data
+ method set (n : 'a) = data <- n; changed#call n
+ method reset () = self#set default
+ method default = default
+end
+
+let stick (pref : 'a preference) (obj : #GObj.widget as 'obj)
+ (cb : 'a -> unit) =
+ let _ = cb pref#get in
+ let p_id = pref#connect#changed (fun v -> cb v) in
+ let _ = obj#misc#connect#destroy (fun () -> pref#connect#disconnect p_id) in
+ ()
+
+(** Useful marshallers *)
let mod_to_str m =
match m with
@@ -74,359 +121,510 @@ let inputenc_of_string s =
else if s = "LOCALE" then Elocale
else Emanual s)
+let use_default_doc_url = "(automatic)"
+
+module Repr =
+struct
+
+let string : string repr =
+object
+ method from s = [s]
+ method into = function [s] -> Some s | _ -> None
+end
+
+let string_pair : (string * string) repr =
+object
+ method from (s1, s2) = [s1; s2]
+ method into = function [s1; s2] -> Some (s1, s2) | _ -> None
+end
+
+let string_list : string list repr =
+object
+ method from s = s
+ method into s = Some s
+end
+
+let bool : bool repr =
+object
+ method from s = [string_of_bool s]
+ method into = function
+ | ["true"] -> Some true
+ | ["false"] -> Some false
+ | _ -> None
+end
+
+let int : int repr =
+object
+ method from s = [string_of_int s]
+ method into = function
+ | [i] -> (try Some (int_of_string i) with _ -> None)
+ | _ -> None
+end
+
+let option (r : 'a repr) : 'a option repr =
+object
+ method from = function None -> [] | Some v -> "" :: r#from v
+ method into = function
+ | [] -> Some None
+ | "" :: s -> Some (r#into s)
+ | _ -> None
+end
+
+let custom (from : 'a -> string) (into : string -> 'a) : 'a repr =
+object
+ method from x = try [from x] with _ -> []
+ method into = function
+ | [s] -> (try Some (into s) with _ -> None)
+ | _ -> None
+end
+
+let tag : tag repr =
+let _to s = if s = "" then None else Some s in
+let _of = function None -> "" | Some s -> s in
+object
+ method from tag = [
+ _of tag.tag_fg_color;
+ _of tag.tag_bg_color;
+ string_of_bool tag.tag_bold;
+ string_of_bool tag.tag_italic;
+ string_of_bool tag.tag_underline;
+ ]
+ method into = function
+ | [fg; bg; bd; it; ul] ->
+ (try Some {
+ tag_fg_color = _to fg;
+ tag_bg_color = _to bg;
+ tag_bold = bool_of_string bd;
+ tag_italic = bool_of_string it;
+ tag_underline = bool_of_string ul;
+ }
+ with _ -> None)
+ | _ -> None
+end
+
+end
+
+let get_config_file name =
+ let find_config dir = Sys.file_exists (Filename.concat dir name) in
+ let config_dir = List.find find_config (Minilib.coqide_config_dirs ()) in
+ Filename.concat config_dir name
+
+(* Small hack to handle v8.3 to v8.4 change in configuration file *)
+let loaded_pref_file =
+ try get_config_file "coqiderc"
+ with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqiderc"
+
+let loaded_accel_file =
+ try get_config_file "coqide.keys"
+ with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys"
(** Hooks *)
-let refresh_style_hook = ref (fun () -> ())
-let refresh_language_hook = ref (fun () -> ())
-let refresh_editor_hook = ref (fun () -> ())
-let refresh_toolbar_hook = ref (fun () -> ())
-let contextual_menus_on_goal_hook = ref (fun x -> ())
-let resize_window_hook = ref (fun () -> ())
-let refresh_tabs_hook = ref (fun () -> ())
+(** New style preferences *)
-type pref =
- {
- mutable cmd_coqtop : string option;
- mutable cmd_coqc : string;
- mutable cmd_make : string;
- mutable cmd_coqmakefile : string;
- mutable cmd_coqdoc : string;
+let cmd_coqtop =
+ new preference ~name:["cmd_coqtop"] ~init:None ~repr:Repr.(option string)
- mutable source_language : string;
- mutable source_style : string;
+let cmd_coqc =
+ new preference ~name:["cmd_coqc"] ~init:"coqc" ~repr:Repr.(string)
- mutable global_auto_revert : bool;
- mutable global_auto_revert_delay : int;
+let cmd_make =
+ new preference ~name:["cmd_make"] ~init:"make" ~repr:Repr.(string)
- mutable auto_save : bool;
- mutable auto_save_delay : int;
- mutable auto_save_name : string * string;
+let cmd_coqmakefile =
+ new preference ~name:["cmd_coqmakefile"] ~init:"coq_makefile -o makefile *.v" ~repr:Repr.(string)
- mutable read_project : project_behavior;
- mutable project_file_name : string;
- mutable project_path : string option;
+let cmd_coqdoc =
+ new preference ~name:["cmd_coqdoc"] ~init:"coqdoc -q -g" ~repr:Repr.(string)
- mutable encoding : inputenc;
+let source_language =
+ new preference ~name:["source_language"] ~init:"coq" ~repr:Repr.(string)
- mutable automatic_tactics : string list;
- mutable cmd_print : string;
+let source_style =
+ new preference ~name:["source_style"] ~init:"coq_style" ~repr:Repr.(string)
- mutable modifier_for_navigation : string;
- mutable modifier_for_templates : string;
- mutable modifier_for_tactics : string;
- mutable modifier_for_display : string;
- mutable modifiers_valid : string;
+let global_auto_revert =
+ new preference ~name:["global_auto_revert"] ~init:false ~repr:Repr.(bool)
- mutable cmd_browse : string;
- mutable cmd_editor : string;
+let global_auto_revert_delay =
+ new preference ~name:["global_auto_revert_delay"] ~init:10000 ~repr:Repr.(int)
- mutable text_font : Pango.font_description;
+let auto_save =
+ new preference ~name:["auto_save"] ~init:true ~repr:Repr.(bool)
- mutable doc_url : string;
- mutable library_url : string;
+let auto_save_delay =
+ new preference ~name:["auto_save_delay"] ~init:10000 ~repr:Repr.(int)
- mutable show_toolbar : bool;
- mutable contextual_menus_on_goal : bool;
- mutable window_width : int;
- mutable window_height :int;
- mutable query_window_width : int;
- mutable query_window_height : int;
-(*
- mutable use_utf8_notation : bool;
-*)
- mutable auto_complete : bool;
- mutable stop_before : bool;
- mutable reset_on_tab_switch : bool;
- mutable vertical_tabs : bool;
- mutable opposite_tabs : bool;
-
- mutable background_color : string;
- mutable processing_color : string;
- mutable processed_color : string;
- mutable error_color : string;
- mutable error_fg_color : string;
-
- mutable dynamic_word_wrap : bool;
- mutable show_line_number : bool;
- mutable auto_indent : bool;
- mutable show_spaces : bool;
- mutable show_right_margin : bool;
- mutable show_progress_bar : bool;
- mutable spaces_instead_of_tabs : bool;
- mutable tab_length : int;
- mutable highlight_current_line : bool;
-
- mutable nanoPG : bool;
+let auto_save_name =
+ new preference ~name:["auto_save_name"] ~init:("#","#") ~repr:Repr.(string_pair)
-}
+let read_project =
+ let repr = Repr.custom string_of_project_behavior project_behavior_of_string in
+ new preference ~name:["read_project"] ~init:Append_args ~repr
-let use_default_doc_url = "(automatic)"
+let project_file_name =
+ new preference ~name:["project_file_name"] ~init:"_CoqProject" ~repr:Repr.(string)
-let current = {
- cmd_coqtop = None;
- cmd_coqc = "coqc";
- cmd_make = "make";
- cmd_coqmakefile = "coq_makefile -o makefile *.v";
- cmd_coqdoc = "coqdoc -q -g";
- cmd_print = "lpr";
+let project_path =
+ new preference ~name:["project_path"] ~init:None ~repr:Repr.(option string)
- global_auto_revert = false;
- global_auto_revert_delay = 10000;
+let encoding =
+ let repr = Repr.custom string_of_inputenc inputenc_of_string in
+ let init = if Sys.os_type = "Win32" then Eutf8 else Elocale in
+ new preference ~name:["encoding"] ~init ~repr
- auto_save = true;
- auto_save_delay = 10000;
- auto_save_name = "#","#";
+let automatic_tactics =
+ let init = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ] in
+ new preference ~name:["automatic_tactics"] ~init ~repr:Repr.(string_list)
- source_language = "coq";
- source_style = "coq_style";
+let cmd_print =
+ new preference ~name:["cmd_print"] ~init:"lpr" ~repr:Repr.(string)
- read_project = Append_args;
- project_file_name = "_CoqProject";
- project_path = None;
+let attach_modifiers (pref : string preference) prefix =
+ let cb mds =
+ let mds = str_to_mod_list mds in
+ let change ~path ~key ~modi ~changed =
+ if CString.is_sub prefix path 0 then
+ ignore (GtkData.AccelMap.change_entry ~key ~modi:mds ~replace:true path)
+ in
+ GtkData.AccelMap.foreach change
+ in
+ pref#connect#changed cb
- encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale;
+let modifier_for_navigation =
+ new preference ~name:["modifier_for_navigation"] ~init:"<Control>" ~repr:Repr.(string)
- automatic_tactics = ["trivial"; "tauto"; "auto"; "omega";
- "auto with *"; "intuition" ];
+let modifier_for_templates =
+ new preference ~name:["modifier_for_templates"] ~init:"<Control><Shift>" ~repr:Repr.(string)
+
+let modifier_for_tactics =
+ new preference ~name:["modifier_for_tactics"] ~init:"<Control><Alt>" ~repr:Repr.(string)
- modifier_for_navigation = "<Control>";
- modifier_for_templates = "<Control><Shift>";
- modifier_for_tactics = "<Control><Alt>";
- modifier_for_display = "<Alt><Shift>";
- modifiers_valid = "<Alt><Control><Shift>";
+let modifier_for_display =
+ new preference ~name:["modifier_for_display"] ~init:"<Alt><Shift>" ~repr:Repr.(string)
+let _ = attach_modifiers modifier_for_navigation "<Actions>/Navigation/"
+let _ = attach_modifiers modifier_for_templates "<Actions>/Templates/"
+let _ = attach_modifiers modifier_for_tactics "<Actions>/Tactics/"
+let _ = attach_modifiers modifier_for_display "<Actions>/View/"
- cmd_browse = Flags.browser_cmd_fmt;
- cmd_editor = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s";
+let modifiers_valid =
+ new preference ~name:["modifiers_valid"] ~init:"<Alt><Control><Shift>" ~repr:Repr.(string)
-(* text_font = Pango.Font.from_string "sans 12";*)
- text_font = Pango.Font.from_string (match Coq_config.gtk_platform with
- |`QUARTZ -> "Arial Unicode MS 11"
- |_ -> "Monospace 10");
+let cmd_browse =
+ new preference ~name:["cmd_browse"] ~init:Flags.browser_cmd_fmt ~repr:Repr.(string)
- doc_url = Coq_config.wwwrefman;
- library_url = Coq_config.wwwstdlib;
+let cmd_editor =
+ let init = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s" in
+ new preference ~name:["cmd_editor"] ~init ~repr:Repr.(string)
- show_toolbar = true;
- contextual_menus_on_goal = true;
- window_width = 800;
- window_height = 600;
- query_window_width = 600;
- query_window_height = 400;
-(*
- use_utf8_notation = false;
-*)
- auto_complete = false;
- stop_before = true;
- reset_on_tab_switch = false;
- vertical_tabs = false;
- opposite_tabs = false;
-
- background_color = Tags.default_color;
- processed_color = Tags.default_processed_color;
- processing_color = Tags.default_processing_color;
- error_color = Tags.default_error_color;
- error_fg_color = Tags.default_error_fg_color;
-
- dynamic_word_wrap = false;
- show_line_number = false;
- auto_indent = false;
- show_spaces = true;
- show_right_margin = false;
- show_progress_bar = true;
- spaces_instead_of_tabs = true;
- tab_length = 2;
- highlight_current_line = false;
-
- nanoPG = false;
- }
+let text_font =
+ let init = match Coq_config.gtk_platform with
+ | `QUARTZ -> "Arial Unicode MS 11"
+ | _ -> "Monospace 10"
+ in
+ new preference ~name:["text_font"] ~init ~repr:Repr.(string)
+
+let doc_url =
+object
+ inherit [string] preference
+ ~name:["doc_url"] ~init:Coq_config.wwwrefman ~repr:Repr.(string)
+ as super
+
+ method set v =
+ if not (Flags.is_standard_doc_url v) &&
+ v <> use_default_doc_url &&
+ (* Extra hack to support links to last released doc version *)
+ v <> Coq_config.wwwcoq ^ "doc" &&
+ v <> Coq_config.wwwcoq ^ "doc/"
+ then super#set v
+
+end
+
+let library_url =
+ new preference ~name:["library_url"] ~init:Coq_config.wwwstdlib ~repr:Repr.(string)
+
+let show_toolbar =
+ new preference ~name:["show_toolbar"] ~init:true ~repr:Repr.(bool)
+
+let contextual_menus_on_goal =
+ new preference ~name:["contextual_menus_on_goal"] ~init:true ~repr:Repr.(bool)
+
+let window_width =
+ new preference ~name:["window_width"] ~init:800 ~repr:Repr.(int)
+
+let window_height =
+ new preference ~name:["window_height"] ~init:600 ~repr:Repr.(int)
+
+let auto_complete =
+ new preference ~name:["auto_complete"] ~init:false ~repr:Repr.(bool)
+
+let stop_before =
+ new preference ~name:["stop_before"] ~init:true ~repr:Repr.(bool)
+
+let reset_on_tab_switch =
+ new preference ~name:["reset_on_tab_switch"] ~init:false ~repr:Repr.(bool)
+
+let vertical_tabs =
+ new preference ~name:["vertical_tabs"] ~init:false ~repr:Repr.(bool)
+
+let opposite_tabs =
+ new preference ~name:["opposite_tabs"] ~init:false ~repr:Repr.(bool)
+
+let background_color =
+ new preference ~name:["background_color"] ~init:"cornsilk" ~repr:Repr.(string)
+
+let attach_bg (pref : string preference) (tag : GText.tag) =
+ pref#connect#changed (fun c -> tag#set_property (`BACKGROUND c))
+
+let attach_fg (pref : string preference) (tag : GText.tag) =
+ pref#connect#changed (fun c -> tag#set_property (`FOREGROUND c))
+
+let processing_color =
+ new preference ~name:["processing_color"] ~init:"light blue" ~repr:Repr.(string)
+
+let _ = attach_bg processing_color Tags.Script.to_process
+let _ = attach_bg processing_color Tags.Script.incomplete
+
+let default_tag = {
+ tag_fg_color = None;
+ tag_bg_color = None;
+ tag_bold = false;
+ tag_italic = false;
+ tag_underline = false;
+}
+
+let tags = ref Util.String.Map.empty
+
+let list_tags () = !tags
+
+let make_tag ?fg ?bg ?(bold = false) ?(italic = false) ?(underline = false) () = {
+ tag_fg_color = fg;
+ tag_bg_color = bg;
+ tag_bold = bold;
+ tag_italic = italic;
+ tag_underline = underline;
+}
+
+let create_tag name default =
+ let pref = new preference ~name:[name] ~init:default ~repr:Repr.(tag) in
+ let set_tag tag =
+ begin match pref#get.tag_bg_color with
+ | None -> tag#set_property (`BACKGROUND_SET false)
+ | Some c ->
+ tag#set_property (`BACKGROUND_SET true);
+ tag#set_property (`BACKGROUND c)
+ end;
+ begin match pref#get.tag_fg_color with
+ | None -> tag#set_property (`FOREGROUND_SET false)
+ | Some c ->
+ tag#set_property (`FOREGROUND_SET true);
+ tag#set_property (`FOREGROUND c)
+ end;
+ begin match pref#get.tag_bold with
+ | false -> tag#set_property (`WEIGHT_SET false)
+ | true ->
+ tag#set_property (`WEIGHT_SET true);
+ tag#set_property (`WEIGHT `BOLD)
+ end;
+ begin match pref#get.tag_italic with
+ | false -> tag#set_property (`STYLE_SET false)
+ | true ->
+ tag#set_property (`STYLE_SET true);
+ tag#set_property (`STYLE `ITALIC)
+ end;
+ begin match pref#get.tag_underline with
+ | false -> tag#set_property (`UNDERLINE_SET false)
+ | true ->
+ tag#set_property (`UNDERLINE_SET true);
+ tag#set_property (`UNDERLINE `SINGLE)
+ end;
+ in
+ let iter table =
+ let tag = GText.tag ~name () in
+ table#add tag#as_tag;
+ pref#connect#changed (fun _ -> set_tag tag);
+ set_tag tag;
+ in
+ List.iter iter [Tags.Script.table; Tags.Proof.table; Tags.Message.table];
+ tags := Util.String.Map.add name pref !tags
+
+let () =
+ let iter (name, tag) = create_tag name tag in
+ List.iter iter [
+ ("constr.evar", make_tag ());
+ ("constr.keyword", make_tag ~fg:"dark green" ());
+ ("constr.notation", make_tag ());
+ ("constr.path", make_tag ());
+ ("constr.reference", make_tag ~fg:"navy"());
+ ("constr.type", make_tag ~fg:"#008080" ());
+ ("constr.variable", make_tag ());
+ ("message.debug", make_tag ());
+ ("message.error", make_tag ());
+ ("message.warning", make_tag ());
+ ("module.definition", make_tag ~fg:"orange red" ~bold:true ());
+ ("module.keyword", make_tag ());
+ ("tactic.keyword", make_tag ());
+ ("tactic.primitive", make_tag ());
+ ("tactic.string", make_tag ());
+ ]
+
+let processed_color =
+ new preference ~name:["processed_color"] ~init:"light green" ~repr:Repr.(string)
+
+let _ = attach_bg processed_color Tags.Script.processed
+let _ = attach_bg processed_color Tags.Proof.highlight
+
+let error_color =
+ new preference ~name:["error_color"] ~init:"#FFCCCC" ~repr:Repr.(string)
+
+let _ = attach_bg error_color Tags.Script.error_bg
+
+let error_fg_color =
+ new preference ~name:["error_fg_color"] ~init:"red" ~repr:Repr.(string)
+
+let _ = attach_fg error_fg_color Tags.Script.error
+
+let dynamic_word_wrap =
+ new preference ~name:["dynamic_word_wrap"] ~init:false ~repr:Repr.(bool)
+
+let show_line_number =
+ new preference ~name:["show_line_number"] ~init:false ~repr:Repr.(bool)
+
+let auto_indent =
+ new preference ~name:["auto_indent"] ~init:false ~repr:Repr.(bool)
+
+let show_spaces =
+ new preference ~name:["show_spaces"] ~init:true ~repr:Repr.(bool)
+
+let show_right_margin =
+ new preference ~name:["show_right_margin"] ~init:false ~repr:Repr.(bool)
+
+let show_progress_bar =
+ new preference ~name:["show_progress_bar"] ~init:true ~repr:Repr.(bool)
+
+let spaces_instead_of_tabs =
+ new preference ~name:["spaces_instead_of_tabs"] ~init:true ~repr:Repr.(bool)
+
+let tab_length =
+ new preference ~name:["tab_length"] ~init:2 ~repr:Repr.(int)
+
+let highlight_current_line =
+ new preference ~name:["highlight_current_line"] ~init:false ~repr:Repr.(bool)
+
+let nanoPG =
+ new preference ~name:["nanoPG"] ~init:false ~repr:Repr.(bool)
+
+class tag_button (box : Gtk.box Gtk.obj) =
+object (self)
+
+ inherit GObj.widget box
+
+ val fg_color = GButton.color_button ()
+ val fg_unset = GButton.toggle_button ()
+ val bg_color = GButton.color_button ()
+ val bg_unset = GButton.toggle_button ()
+ val bold = GButton.toggle_button ()
+ val italic = GButton.toggle_button ()
+ val underline = GButton.toggle_button ()
+
+ method set_tag tag =
+ let track c but set = match c with
+ | None -> set#set_active true
+ | Some c ->
+ set#set_active false;
+ but#set_color (Tags.color_of_string c)
+ in
+ track tag.tag_bg_color bg_color bg_unset;
+ track tag.tag_fg_color fg_color fg_unset;
+ bold#set_active tag.tag_bold;
+ italic#set_active tag.tag_italic;
+ underline#set_active tag.tag_underline;
+
+ method tag =
+ let get but set =
+ if set#active then None
+ else Some (Tags.string_of_color but#color)
+ in
+ {
+ tag_bg_color = get bg_color bg_unset;
+ tag_fg_color = get fg_color fg_unset;
+ tag_bold = bold#active;
+ tag_italic = italic#active;
+ tag_underline = underline#active;
+ }
+
+ initializer
+ let box = new GPack.box box in
+ let set_stock button stock =
+ let stock = GMisc.image ~stock ~icon_size:`BUTTON () in
+ button#set_image stock#coerce
+ in
+ set_stock fg_unset `CANCEL;
+ set_stock bg_unset `CANCEL;
+ set_stock bold `BOLD;
+ set_stock italic `ITALIC;
+ set_stock underline `UNDERLINE;
+ box#pack fg_color#coerce;
+ box#pack fg_unset#coerce;
+ box#pack bg_color#coerce;
+ box#pack bg_unset#coerce;
+ box#pack bold#coerce;
+ box#pack italic#coerce;
+ box#pack underline#coerce;
+ let cb but obj = obj#set_sensitive (not but#active) in
+ let _ = fg_unset#connect#toggled (fun () -> cb fg_unset fg_color#misc) in
+ let _ = bg_unset#connect#toggled (fun () -> cb bg_unset bg_color#misc) in
+ ()
+
+end
+
+let tag_button () =
+ let box = GPack.hbox () in
+ new tag_button (Gobject.unsafe_cast box#as_widget)
+
+(** Old style preferences *)
let save_pref () =
if not (Sys.file_exists (Minilib.coqide_config_home ()))
then Unix.mkdir (Minilib.coqide_config_home ()) 0o700;
let () = try GtkData.AccelMap.save accel_file with _ -> () in
- let p = current in
-
- let add = Util.String.Map.add in
- let (++) x f = f x in
- Util.String.Map.empty ++
- add "cmd_coqtop" (match p.cmd_coqtop with | None -> [] | Some v-> [v]) ++
- add "cmd_coqc" [p.cmd_coqc] ++
- add "cmd_make" [p.cmd_make] ++
- add "cmd_coqmakefile" [p.cmd_coqmakefile] ++
- add "cmd_coqdoc" [p.cmd_coqdoc] ++
- add "source_language" [p.source_language] ++
- add "source_style" [p.source_style] ++
- add "global_auto_revert" [string_of_bool p.global_auto_revert] ++
- add "global_auto_revert_delay"
- [string_of_int p.global_auto_revert_delay] ++
- add "auto_save" [string_of_bool p.auto_save] ++
- add "auto_save_delay" [string_of_int p.auto_save_delay] ++
- add "auto_save_name" [fst p.auto_save_name; snd p.auto_save_name] ++
-
- add "project_options" [string_of_project_behavior p.read_project] ++
- add "project_file_name" [p.project_file_name] ++
- add "project_path" (match p.project_path with None -> [] | Some s -> [s]) ++
-
- add "encoding" [string_of_inputenc p.encoding] ++
-
- add "automatic_tactics" p.automatic_tactics ++
- add "cmd_print" [p.cmd_print] ++
- add "modifier_for_navigation" [p.modifier_for_navigation] ++
- add "modifier_for_templates" [p.modifier_for_templates] ++
- add "modifier_for_tactics" [p.modifier_for_tactics] ++
- add "modifier_for_display" [p.modifier_for_display] ++
- add "modifiers_valid" [p.modifiers_valid] ++
- add "cmd_browse" [p.cmd_browse] ++
- add "cmd_editor" [p.cmd_editor] ++
-
- add "text_font" [Pango.Font.to_string p.text_font] ++
-
- add "doc_url" [p.doc_url] ++
- add "library_url" [p.library_url] ++
- add "show_toolbar" [string_of_bool p.show_toolbar] ++
- add "contextual_menus_on_goal"
- [string_of_bool p.contextual_menus_on_goal] ++
- add "window_height" [string_of_int p.window_height] ++
- add "window_width" [string_of_int p.window_width] ++
- add "query_window_height" [string_of_int p.query_window_height] ++
- add "query_window_width" [string_of_int p.query_window_width] ++
- add "auto_complete" [string_of_bool p.auto_complete] ++
- add "stop_before" [string_of_bool p.stop_before] ++
- add "reset_on_tab_switch" [string_of_bool p.reset_on_tab_switch] ++
- add "vertical_tabs" [string_of_bool p.vertical_tabs] ++
- add "opposite_tabs" [string_of_bool p.opposite_tabs] ++
- add "background_color" [p.background_color] ++
- add "processing_color" [p.processing_color] ++
- add "processed_color" [p.processed_color] ++
- add "error_color" [p.error_color] ++
- add "error_fg_color" [p.error_fg_color] ++
- add "dynamic_word_wrap" [string_of_bool p.dynamic_word_wrap] ++
- add "show_line_number" [string_of_bool p.show_line_number] ++
- add "auto_indent" [string_of_bool p.auto_indent] ++
- add "show_spaces" [string_of_bool p.show_spaces] ++
- add "show_right_margin" [string_of_bool p.show_right_margin] ++
- add "show_progress_bar" [string_of_bool p.show_progress_bar] ++
- add "spaces_instead_of_tabs" [string_of_bool p.spaces_instead_of_tabs] ++
- add "tab_length" [string_of_int p.tab_length] ++
- add "highlight_current_line" [string_of_bool p.highlight_current_line] ++
- add "nanoPG" [string_of_bool p.nanoPG] ++
+ let add = Util.String.Map.add in
+ let (++) x f = f x in
+ let fold key obj accu = add key (obj.get ()) accu in
+
+ (Util.String.Map.fold fold !preferences Util.String.Map.empty) ++
Config_lexer.print_file pref_file
let load_pref () =
let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in
let m = Config_lexer.load_file loaded_pref_file in
- let np = current in
- let set k f = try let v = Util.String.Map.find k m in f v with _ -> () in
- let set_hd k f = set k (fun v -> f (List.hd v)) in
- let set_bool k f = set_hd k (fun v -> f (bool_of_string v)) in
- let set_int k f = set_hd k (fun v -> f (int_of_string v)) in
- let set_pair k f = set k (function [v1;v2] -> f v1 v2 | _ -> raise Exit) in
- let set_command_with_pair_compat k f =
- set k (function [v1;v2] -> f (v1^"%s"^v2) | [v] -> f v | _ -> raise Exit)
+ let iter name v =
+ try (Util.String.Map.find name !preferences).set v
+ with _ -> ()
in
- let set_option k f = set k (fun v -> f (match v with |[] -> None |h::_ -> Some h)) in
- set_option "cmd_coqtop" (fun v -> np.cmd_coqtop <- v);
- set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v);
- set_hd "cmd_make" (fun v -> np.cmd_make <- v);
- set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v);
- set_hd "cmd_coqdoc" (fun v -> np.cmd_coqdoc <- v);
- set_hd "source_language" (fun v -> np.source_language <- v);
- set_hd "source_style" (fun v -> np.source_style <- v);
- set_bool "global_auto_revert" (fun v -> np.global_auto_revert <- v);
- set_int "global_auto_revert_delay"
- (fun v -> np.global_auto_revert_delay <- v);
- set_bool "auto_save" (fun v -> np.auto_save <- v);
- set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v);
- set_pair "auto_save_name" (fun v1 v2 -> np.auto_save_name <- (v1,v2));
- set_hd "encoding" (fun v -> np.encoding <- (inputenc_of_string v));
- set_hd "project_options"
- (fun v -> np.read_project <- (project_behavior_of_string v));
- set_hd "project_file_name" (fun v -> np.project_file_name <- v);
- set_option "project_path" (fun v -> np.project_path <- v);
- set "automatic_tactics"
- (fun v -> np.automatic_tactics <- v);
- set_hd "cmd_print" (fun v -> np.cmd_print <- v);
- set_hd "modifier_for_navigation"
- (fun v -> np.modifier_for_navigation <- v);
- set_hd "modifier_for_templates"
- (fun v -> np.modifier_for_templates <- v);
- set_hd "modifier_for_tactics"
- (fun v -> np.modifier_for_tactics <- v);
- set_hd "modifier_for_display"
- (fun v -> np.modifier_for_display <- v);
- set_hd "modifiers_valid"
- (fun v ->
- np.modifiers_valid <- v);
- set_command_with_pair_compat "cmd_browse" (fun v -> np.cmd_browse <- v);
- set_command_with_pair_compat "cmd_editor" (fun v -> np.cmd_editor <- v);
- set_hd "text_font" (fun v -> np.text_font <- Pango.Font.from_string v);
- set_hd "doc_url" (fun v ->
- if not (Flags.is_standard_doc_url v) &&
- v <> use_default_doc_url &&
- (* Extra hack to support links to last released doc version *)
- v <> Coq_config.wwwcoq ^ "doc" &&
- v <> Coq_config.wwwcoq ^ "doc/"
- then
- (* ("Warning: Non-standard URL for Coq documentation in preference file: "^v);*)
- np.doc_url <- v);
- set_hd "library_url" (fun v -> np.library_url <- v);
- set_bool "show_toolbar" (fun v -> np.show_toolbar <- v);
- set_bool "contextual_menus_on_goal"
- (fun v -> np.contextual_menus_on_goal <- v);
- set_int "window_width" (fun v -> np.window_width <- v);
- set_int "window_height" (fun v -> np.window_height <- v);
- set_int "query_window_width" (fun v -> np.query_window_width <- v);
- set_int "query_window_height" (fun v -> np.query_window_height <- v);
- set_bool "auto_complete" (fun v -> np.auto_complete <- v);
- set_bool "stop_before" (fun v -> np.stop_before <- v);
- set_bool "reset_on_tab_switch" (fun v -> np.reset_on_tab_switch <- v);
- set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v);
- set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v);
- set_hd "background_color" (fun v -> np.background_color <- v);
- set_hd "processing_color" (fun v -> np.processing_color <- v);
- set_hd "processed_color" (fun v -> np.processed_color <- v);
- set_hd "error_color" (fun v -> np.error_color <- v);
- set_hd "error_fg_color" (fun v -> np.error_fg_color <- v);
- set_bool "dynamic_word_wrap" (fun v -> np.dynamic_word_wrap <- v);
- set_bool "show_line_number" (fun v -> np.show_line_number <- v);
- set_bool "auto_indent" (fun v -> np.auto_indent <- v);
- set_bool "show_spaces" (fun v -> np.show_spaces <- v);
- set_bool "show_right_margin" (fun v -> np.show_right_margin <- v);
- set_bool "show_progress_bar" (fun v -> np.show_progress_bar <- v);
- set_bool "spaces_instead_of_tabs" (fun v -> np.spaces_instead_of_tabs <- v);
- set_int "tab_length" (fun v -> np.tab_length <- v);
- set_bool "highlight_current_line" (fun v -> np.highlight_current_line <- v);
- set_bool "nanoPG" (fun v -> np.nanoPG <- v);
- ()
+ Util.String.Map.iter iter m
+
+let pstring name p = string ~f:p#set name p#get
+let pbool name p = bool ~f:p#set name p#get
+let pmodifiers ?(all = false) name p = modifiers
+ ?allow:(if all then None else Some (str_to_mod_list modifiers_valid#get))
+ ~f:(fun l -> p#set (mod_list_to_str l))
+ ~help:"restart to apply"
+ name
+ (str_to_mod_list p#get)
let configure ?(apply=(fun () -> ())) () =
let cmd_coqtop =
string
- ~f:(fun s -> current.cmd_coqtop <- if s = "AUTO" then None else Some s)
- " coqtop" (match current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in
- let cmd_coqc =
- string
- ~f:(fun s -> current.cmd_coqc <- s)
- " coqc" current.cmd_coqc in
- let cmd_make =
- string
- ~f:(fun s -> current.cmd_make <- s)
- " make" current.cmd_make in
- let cmd_coqmakefile =
- string
- ~f:(fun s -> current.cmd_coqmakefile <- s)
- "coqmakefile" current.cmd_coqmakefile in
- let cmd_coqdoc =
- string
- ~f:(fun s -> current.cmd_coqdoc <- s)
- " coqdoc" current.cmd_coqdoc in
- let cmd_print =
- string
- ~f:(fun s -> current.cmd_print <- s)
- " Print ps" current.cmd_print in
+ ~f:(fun s -> cmd_coqtop#set (if s = "AUTO" then None else Some s))
+ " coqtop" (match cmd_coqtop#get with |None -> "AUTO" | Some x -> x) in
+ let cmd_coqc = pstring " coqc" cmd_coqc in
+ let cmd_make = pstring " make" cmd_make in
+ let cmd_coqmakefile = pstring "coqmakefile" cmd_coqmakefile in
+ let cmd_coqdoc = pstring " coqdoc" cmd_coqdoc in
+ let cmd_print = pstring " Print ps" cmd_print in
let config_font =
let box = GPack.hbox () in
@@ -435,18 +633,13 @@ let configure ?(apply=(fun () -> ())) () =
"Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z).";
box#pack ~expand:true w#coerce;
ignore (w#misc#connect#realize
- ~callback:(fun () -> w#set_font_name
- (Pango.Font.to_string current.text_font)));
+ ~callback:(fun () -> w#set_font_name text_font#get));
custom
~label:"Fonts for text"
box
(fun () ->
let fd = w#font_name in
- current.text_font <- (Pango.Font.from_string fd) ;
-(*
- Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string current.text_font);
-*)
- !refresh_editor_hook ())
+ text_font#set fd)
true
in
@@ -458,121 +651,98 @@ let configure ?(apply=(fun () -> ())) () =
~border_width:2
~packing:(box#pack ~expand:true) ()
in
- let background_label = GMisc.label
- ~text:"Background color"
- ~packing:(table#attach ~expand:`X ~left:0 ~top:0) ()
- in
- let processed_label = GMisc.label
- ~text:"Background color of processed text"
- ~packing:(table#attach ~expand:`X ~left:0 ~top:1) ()
- in
- let processing_label = GMisc.label
- ~text:"Background color of text being processed"
- ~packing:(table#attach ~expand:`X ~left:0 ~top:2) ()
- in
- let error_label = GMisc.label
- ~text:"Background color of errors"
- ~packing:(table#attach ~expand:`X ~left:0 ~top:3) ()
- in
- let error_fg_label = GMisc.label
- ~text:"Foreground color of errors"
- ~packing:(table#attach ~expand:`X ~left:0 ~top:4) ()
- in
- let () = background_label#set_xalign 0. in
- let () = processed_label#set_xalign 0. in
- let () = processing_label#set_xalign 0. in
- let () = error_label#set_xalign 0. in
- let () = error_fg_label#set_xalign 0. in
- let background_button = GButton.color_button
- ~color:(Tags.color_of_string (current.background_color))
- ~packing:(table#attach ~left:1 ~top:0) ()
- in
- let processed_button = GButton.color_button
- ~color:(Tags.get_processed_color ())
- ~packing:(table#attach ~left:1 ~top:1) ()
+ let reset_button = GButton.button
+ ~label:"Reset"
+ ~packing:box#pack ()
in
- let processing_button = GButton.color_button
- ~color:(Tags.get_processing_color ())
- ~packing:(table#attach ~left:1 ~top:2) ()
+ let iter i (text, pref) =
+ let label = GMisc.label
+ ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:i) ()
+ in
+ let () = label#set_xalign 0. in
+ let button = GButton.color_button
+ ~color:(Tags.color_of_string pref#get)
+ ~packing:(table#attach ~left:1 ~top:i) ()
+ in
+ let _ = button#connect#color_set begin fun () ->
+ pref#set (Tags.string_of_color button#color)
+ end in
+ let reset _ =
+ pref#reset ();
+ button#set_color Tags.(color_of_string pref#get)
+ in
+ let _ = reset_button#connect#clicked ~callback:reset in
+ ()
in
- let error_button = GButton.color_button
- ~color:(Tags.get_error_color ())
- ~packing:(table#attach ~left:1 ~top:3) ()
+ let () = Util.List.iteri iter [
+ ("Background color", background_color);
+ ("Background color of processed text", processed_color);
+ ("Background color of text being processed", processing_color);
+ ("Background color of errors", error_color);
+ ("Foreground color of errors", error_fg_color);
+ ] in
+ let label = "Color configuration" in
+ let callback () = () in
+ custom ~label box callback true
+ in
+
+ let config_tags =
+ let box = GPack.vbox () in
+ let scroll = GBin.scrolled_window
+ ~hpolicy:`NEVER
+ ~vpolicy:`AUTOMATIC
+ ~packing:(box#pack ~expand:true)
+ ()
in
- let error_fg_button = GButton.color_button
- ~color:(Tags.get_error_fg_color ())
- ~packing:(table#attach ~left:1 ~top:4) ()
+ let table = GPack.table
+ ~row_spacings:5
+ ~col_spacings:5
+ ~border_width:2
+ ~packing:scroll#add_with_viewport ()
in
let reset_button = GButton.button
~label:"Reset"
~packing:box#pack ()
in
- let reset_cb () =
- background_button#set_color Tags.(color_of_string default_color);
- processing_button#set_color Tags.(color_of_string default_processing_color);
- processed_button#set_color Tags.(color_of_string default_processed_color);
- error_button#set_color Tags.(color_of_string default_error_color);
- in
- let _ = reset_button#connect#clicked ~callback:reset_cb in
- let label = "Color configuration" in
- let callback () =
- current.background_color <- Tags.string_of_color background_button#color;
- current.processing_color <- Tags.string_of_color processing_button#color;
- current.processed_color <- Tags.string_of_color processed_button#color;
- current.error_color <- Tags.string_of_color error_button#color;
- current.error_fg_color <- Tags.string_of_color error_fg_button#color;
- !refresh_editor_hook ();
- Tags.set_processing_color processing_button#color;
- Tags.set_processed_color processed_button#color;
- Tags.set_error_color error_button#color;
- Tags.set_error_fg_color error_fg_button#color
+ let i = ref 0 in
+ let cb = ref [] in
+ let iter text tag =
+ let label = GMisc.label
+ ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:!i) ()
+ in
+ let () = label#set_xalign 0. in
+ let button = tag_button () in
+ let callback () = tag#set button#tag in
+ button#set_tag tag#get;
+ table#attach ~left:1 ~top:!i button#coerce;
+ incr i;
+ cb := callback :: !cb;
in
+ let () = Util.String.Map.iter iter !tags in
+ let label = "Tag configuration" in
+ let callback () = List.iter (fun f -> f ()) !cb in
custom ~label box callback true
in
let config_editor =
let label = "Editor configuration" in
let box = GPack.vbox () in
- let gen_button text active =
- GButton.check_button ~label:text ~active ~packing:box#pack () in
- let wrap = gen_button "Dynamic word wrap" current.dynamic_word_wrap in
- let line = gen_button "Show line number" current.show_line_number in
- let auto_indent = gen_button "Auto indentation" current.auto_indent in
- let auto_complete = gen_button "Auto completion" current.auto_complete in
- let show_spaces = gen_button "Show spaces" current.show_spaces in
- let show_right_margin = gen_button "Show right margin" current.show_right_margin in
- let show_progress_bar = gen_button "Show progress bar" current.show_progress_bar in
- let spaces_instead_of_tabs =
- gen_button "Insert spaces instead of tabs"
- current.spaces_instead_of_tabs
- in
- let highlight_current_line =
- gen_button "Highlight current line"
- current.highlight_current_line
- in
- let nanoPG = gen_button "Emacs/PG keybindings (μPG mode)" current.nanoPG in
-(* let lbox = GPack.hbox ~packing:box#pack () in *)
-(* let _ = GMisc.label ~text:"Tab width" *)
-(* ~xalign:0. *)
-(* ~packing:(lbox#pack ~expand:true) () *)
-(* in *)
-(* let tab_width = GEdit.spin_button *)
-(* ~digits:0 ~packing:lbox#pack () *)
-(* in *)
- let callback () =
- current.dynamic_word_wrap <- wrap#active;
- current.show_line_number <- line#active;
- current.auto_indent <- auto_indent#active;
- current.show_spaces <- show_spaces#active;
- current.show_right_margin <- show_right_margin#active;
- current.show_progress_bar <- show_progress_bar#active;
- current.spaces_instead_of_tabs <- spaces_instead_of_tabs#active;
- current.highlight_current_line <- highlight_current_line#active;
- current.nanoPG <- nanoPG#active;
- current.auto_complete <- auto_complete#active;
-(* current.tab_length <- tab_width#value_as_int; *)
- !refresh_editor_hook ()
+ let button text (pref : bool preference) =
+ let active = pref#get in
+ let but = GButton.check_button ~label:text ~active ~packing:box#pack () in
+ ignore (but#connect#toggled (fun () -> pref#set but#active))
in
+ let () = button "Dynamic word wrap" dynamic_word_wrap in
+ let () = button "Show line number" show_line_number in
+ let () = button "Auto indentation" auto_indent in
+ let () = button "Auto completion" auto_complete in
+ let () = button "Show spaces" show_spaces in
+ let () = button "Show right margin" show_right_margin in
+ let () = button "Show progress bar" show_progress_bar in
+ let () = button "Insert spaces instead of tabs" spaces_instead_of_tabs in
+ let () = button "Highlight current line" highlight_current_line in
+ let () = button "Emacs/PG keybindings (μPG mode)" nanoPG in
+ let callback () = () in
custom ~label box callback true
in
@@ -600,193 +770,98 @@ let configure ?(apply=(fun () -> ())) () =
(string_of_int current.window_width)
in
*)
-(* let use_utf8_notation =
- bool
- ~f:(fun b ->
- current.use_utf8_notation <- b;
- )
- "Use Unicode Notation: " current.use_utf8_notation
- in
-*)
(*
let config_appearance = [show_toolbar; window_width; window_height] in
*)
- let global_auto_revert =
- bool
- ~f:(fun s -> current.global_auto_revert <- s)
- "Enable global auto revert" current.global_auto_revert
- in
+ let global_auto_revert = pbool "Enable global auto revert" global_auto_revert in
let global_auto_revert_delay =
string
- ~f:(fun s -> current.global_auto_revert_delay <-
+ ~f:(fun s -> global_auto_revert_delay#set
(try int_of_string s with _ -> 10000))
"Global auto revert delay (ms)"
- (string_of_int current.global_auto_revert_delay)
+ (string_of_int global_auto_revert_delay#get)
in
- let auto_save =
- bool
- ~f:(fun s -> current.auto_save <- s)
- "Enable auto save" current.auto_save
- in
+ let auto_save = pbool "Enable auto save" auto_save in
let auto_save_delay =
string
- ~f:(fun s -> current.auto_save_delay <-
+ ~f:(fun s -> auto_save_delay#set
(try int_of_string s with _ -> 10000))
"Auto save delay (ms)"
- (string_of_int current.auto_save_delay)
+ (string_of_int auto_save_delay#get)
in
- let stop_before =
- bool
- ~f:(fun s -> current.stop_before <- s)
- "Stop interpreting before the current point" current.stop_before
- in
+ let stop_before = pbool "Stop interpreting before the current point" stop_before in
- let reset_on_tab_switch =
- bool
- ~f:(fun s -> current.reset_on_tab_switch <- s)
- "Reset coqtop on tab switch" current.reset_on_tab_switch
- in
+ let reset_on_tab_switch = pbool "Reset coqtop on tab switch" reset_on_tab_switch in
- let vertical_tabs =
- bool
- ~f:(fun s -> current.vertical_tabs <- s; !refresh_tabs_hook ())
- "Vertical tabs" current.vertical_tabs
- in
+ let vertical_tabs = pbool "Vertical tabs" vertical_tabs in
- let opposite_tabs =
- bool
- ~f:(fun s -> current.opposite_tabs <- s; !refresh_tabs_hook ())
- "Tabs on opposite side" current.opposite_tabs
- in
+ let opposite_tabs = pbool "Tabs on opposite side" opposite_tabs in
let encodings =
combo
"File charset encoding "
- ~f:(fun s -> current.encoding <- (inputenc_of_string s))
+ ~f:(fun s -> encoding#set (inputenc_of_string s))
~new_allowed: true
- ("UTF-8"::"LOCALE":: match current.encoding with
+ ("UTF-8"::"LOCALE":: match encoding#get with
|Emanual s -> [s]
|_ -> []
)
- (string_of_inputenc current.encoding)
+ (string_of_inputenc encoding#get)
in
let source_style =
- let f s =
- current.source_style <- s;
- !refresh_style_hook ()
- in
combo "Highlighting style:"
- ~f ~new_allowed:false
- style_manager#style_scheme_ids current.source_style
+ ~f:source_style#set ~new_allowed:false
+ style_manager#style_scheme_ids source_style#get
in
let source_language =
- let f s =
- current.source_language <- s;
- !refresh_language_hook ()
- in
combo "Language:"
- ~f ~new_allowed:false
+ ~f:source_language#set ~new_allowed:false
(List.filter
(fun x -> Str.string_match (Str.regexp "^coq") x 0)
lang_manager#language_ids)
- current.source_language
+ source_language#get
in
let read_project =
combo
"Project file options are"
- ~f:(fun s -> current.read_project <- project_behavior_of_string s)
+ ~f:(fun s -> read_project#set (project_behavior_of_string s))
~editable:false
[string_of_project_behavior Subst_args;
string_of_project_behavior Append_args;
string_of_project_behavior Ignore_args]
- (string_of_project_behavior current.read_project)
- in
- let project_file_name =
- string "Default name for project file"
- ~f:(fun s -> current.project_file_name <- s)
- current.project_file_name
- in
- let update_modifiers prefix mds =
- let change ~path ~key ~modi ~changed =
- if CString.is_sub prefix path 0 then
- ignore (GtkData.AccelMap.change_entry ~key ~modi:mds ~replace:true path)
- in
- GtkData.AccelMap.foreach change
+ (string_of_project_behavior read_project#get)
in
- let help_string =
- "restart to apply"
- in
- let the_valid_mod = str_to_mod_list current.modifiers_valid in
+ let project_file_name = pstring "Default name for project file" project_file_name in
let modifier_for_tactics =
- let cb l =
- current.modifier_for_tactics <- mod_list_to_str l;
- update_modifiers "<Actions>/Tactics/" l
- in
- modifiers
- ~allow:the_valid_mod
- ~f:cb
- ~help:help_string
- "Modifiers for Tactics Menu"
- (str_to_mod_list current.modifier_for_tactics)
+ pmodifiers "Modifiers for Tactics Menu" modifier_for_tactics
in
let modifier_for_templates =
- let cb l =
- current.modifier_for_templates <- mod_list_to_str l;
- update_modifiers "<Actions>/Templates/" l
- in
- modifiers
- ~allow:the_valid_mod
- ~f:cb
- ~help:help_string
- "Modifiers for Templates Menu"
- (str_to_mod_list current.modifier_for_templates)
+ pmodifiers "Modifiers for Templates Menu" modifier_for_templates
in
let modifier_for_navigation =
- let cb l =
- current.modifier_for_navigation <- mod_list_to_str l;
- update_modifiers "<Actions>/Navigation/" l
- in
- modifiers
- ~allow:the_valid_mod
- ~f:cb
- ~help:help_string
- "Modifiers for Navigation Menu"
- (str_to_mod_list current.modifier_for_navigation)
+ pmodifiers "Modifiers for Navigation Menu" modifier_for_navigation
in
let modifier_for_display =
- let cb l =
- current.modifier_for_display <- mod_list_to_str l;
- update_modifiers "<Actions>/View/" l
- in
- modifiers
- ~allow:the_valid_mod
- ~f:cb
- ~help:help_string
- "Modifiers for View Menu"
- (str_to_mod_list current.modifier_for_display)
+ pmodifiers "Modifiers for View Menu" modifier_for_display
in
let modifiers_valid =
- modifiers
- ~f:(fun l ->
- current.modifiers_valid <- mod_list_to_str l)
- "Allowed modifiers"
- the_valid_mod
+ pmodifiers ~all:true "Allowed modifiers" modifiers_valid
in
let cmd_editor =
let predefined = [ "emacs %s"; "vi %s"; "NOTEPAD %s" ] in
combo
~help:"(%s for file name)"
"External editor"
- ~f:(fun s -> current.cmd_editor <- s)
+ ~f:cmd_editor#set
~new_allowed: true
- (predefined@[if List.mem current.cmd_editor predefined then ""
- else current.cmd_editor])
- current.cmd_editor
+ (predefined@[if List.mem cmd_editor#get predefined then ""
+ else cmd_editor#get])
+ cmd_editor#get
in
let cmd_browse =
let predefined = [
@@ -799,11 +874,11 @@ let configure ?(apply=(fun () -> ())) () =
combo
~help:"(%s for url)"
"Browser"
- ~f:(fun s -> current.cmd_browse <- s)
+ ~f:cmd_browse#set
~new_allowed: true
- (predefined@[if List.mem current.cmd_browse predefined then ""
- else current.cmd_browse])
- current.cmd_browse
+ (predefined@[if List.mem cmd_browse#get predefined then ""
+ else cmd_browse#get])
+ cmd_browse#get
in
let doc_url =
let predefined = [
@@ -813,11 +888,11 @@ let configure ?(apply=(fun () -> ())) () =
] in
combo
"Manual URL"
- ~f:(fun s -> current.doc_url <- s)
+ ~f:doc_url#set
~new_allowed: true
- (predefined@[if List.mem current.doc_url predefined then ""
- else current.doc_url])
- current.doc_url in
+ (predefined@[if List.mem doc_url#get predefined then ""
+ else doc_url#get])
+ doc_url#get in
let library_url =
let predefined = [
"file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"stdlib";""]);
@@ -825,28 +900,22 @@ let configure ?(apply=(fun () -> ())) () =
] in
combo
"Library URL"
- ~f:(fun s -> current.library_url <- s)
+ ~f:(fun s -> library_url#set s)
~new_allowed: true
- (predefined@[if List.mem current.library_url predefined then ""
- else current.library_url])
- current.library_url
+ (predefined@[if List.mem library_url#get predefined then ""
+ else library_url#get])
+ library_url#get
in
let automatic_tactics =
strings
- ~f:(fun l -> current.automatic_tactics <- l)
+ ~f:automatic_tactics#set
~add:(fun () -> ["<edit me>"])
"Wizard tactics to try in order"
- current.automatic_tactics
+ automatic_tactics#get
in
- let contextual_menus_on_goal =
- bool
- ~f:(fun s ->
- current.contextual_menus_on_goal <- s;
- !contextual_menus_on_goal_hook s)
- "Contextual menus on goal" current.contextual_menus_on_goal
- in
+ let contextual_menus_on_goal = pbool "Contextual menus on goal" contextual_menus_on_goal in
let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch;
vertical_tabs;opposite_tabs] in
@@ -858,6 +927,8 @@ let configure ?(apply=(fun () -> ())) () =
[config_font]);
Section("Colors", Some `SELECT_COLOR,
[config_color; source_language; source_style]);
+ Section("Tags", Some `SELECT_COLOR,
+ [config_tags]);
Section("Editor", Some `EDIT, [config_editor]);
Section("Files", Some `DIRECTORY,
[global_auto_revert;global_auto_revert_delay;
diff --git a/ide/preferences.mli b/ide/preferences.mli
index 1e4f152c2..b5c7ea222 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -12,95 +12,96 @@ val style_manager : GSourceView2.source_style_scheme_manager
type project_behavior = Ignore_args | Append_args | Subst_args
type inputenc = Elocale | Eutf8 | Emanual of string
-type pref =
- {
- mutable cmd_coqtop : string option;
- mutable cmd_coqc : string;
- mutable cmd_make : string;
- mutable cmd_coqmakefile : string;
- mutable cmd_coqdoc : string;
-
- mutable source_language : string;
- mutable source_style : string;
-
- mutable global_auto_revert : bool;
- mutable global_auto_revert_delay : int;
-
- mutable auto_save : bool;
- mutable auto_save_delay : int;
- mutable auto_save_name : string * string;
-
- mutable read_project : project_behavior;
- mutable project_file_name : string;
- mutable project_path : string option;
-
- mutable encoding : inputenc;
-
- mutable automatic_tactics : string list;
- mutable cmd_print : string;
-
- mutable modifier_for_navigation : string;
- mutable modifier_for_templates : string;
- mutable modifier_for_tactics : string;
- mutable modifier_for_display : string;
- mutable modifiers_valid : string;
-
- mutable cmd_browse : string;
- mutable cmd_editor : string;
-
- mutable text_font : Pango.font_description;
-
- mutable doc_url : string;
- mutable library_url : string;
-
- mutable show_toolbar : bool;
- mutable contextual_menus_on_goal : bool;
- mutable window_width : int;
- mutable window_height : int;
- mutable query_window_width : int;
- mutable query_window_height : int;
-(*
- mutable use_utf8_notation : bool;
-*)
- mutable auto_complete : bool;
- mutable stop_before : bool;
- mutable reset_on_tab_switch : bool;
- mutable vertical_tabs : bool;
- mutable opposite_tabs : bool;
-
- mutable background_color : string;
- mutable processing_color : string;
- mutable processed_color : string;
- mutable error_color : string;
- mutable error_fg_color : string;
-
- mutable dynamic_word_wrap : bool;
- mutable show_line_number : bool;
- mutable auto_indent : bool;
- mutable show_spaces : bool;
- mutable show_right_margin : bool;
- mutable show_progress_bar : bool;
- mutable spaces_instead_of_tabs : bool;
- mutable tab_length : int;
- mutable highlight_current_line : bool;
-
- mutable nanoPG : bool;
-
- }
+type tag = {
+ tag_fg_color : string option;
+ tag_bg_color : string option;
+ tag_bold : bool;
+ tag_italic : bool;
+ tag_underline : bool;
+}
+
+class type ['a] repr =
+object
+ method into : string list -> 'a option
+ method from : 'a -> string list
+end
+
+class ['a] preference_signals : changed:'a GUtil.signal ->
+object
+ inherit GUtil.ml_signals
+ method changed : callback:('a -> unit) -> GtkSignal.id
+end
+
+class ['a] preference : name:string list -> init:'a -> repr:'a repr ->
+object
+ method connect : 'a preference_signals
+ method get : 'a
+ method set : 'a -> unit
+ method reset : unit -> unit
+ method default : 'a
+end
+
+val list_tags : unit -> tag preference Util.String.Map.t
+
+val cmd_coqtop : string option preference
+val cmd_coqc : string preference
+val cmd_make : string preference
+val cmd_coqmakefile : string preference
+val cmd_coqdoc : string preference
+val source_language : string preference
+val source_style : string preference
+val global_auto_revert : bool preference
+val global_auto_revert_delay : int preference
+val auto_save : bool preference
+val auto_save_delay : int preference
+val auto_save_name : (string * string) preference
+val read_project : project_behavior preference
+val project_file_name : string preference
+val project_path : string option preference
+val encoding : inputenc preference
+val automatic_tactics : string list preference
+val cmd_print : string preference
+val modifier_for_navigation : string preference
+val modifier_for_templates : string preference
+val modifier_for_tactics : string preference
+val modifier_for_display : string preference
+val modifiers_valid : string preference
+val cmd_browse : string preference
+val cmd_editor : string preference
+val text_font : string preference
+val doc_url : string preference
+val library_url : string preference
+val show_toolbar : bool preference
+val contextual_menus_on_goal : bool preference
+val window_width : int preference
+val window_height : int preference
+val auto_complete : bool preference
+val stop_before : bool preference
+val reset_on_tab_switch : bool preference
+val vertical_tabs : bool preference
+val opposite_tabs : bool preference
+val background_color : string preference
+val processing_color : string preference
+val processed_color : string preference
+val error_color : string preference
+val error_fg_color : string preference
+val dynamic_word_wrap : bool preference
+val show_line_number : bool preference
+val auto_indent : bool preference
+val show_spaces : bool preference
+val show_right_margin : bool preference
+val show_progress_bar : bool preference
+val spaces_instead_of_tabs : bool preference
+val tab_length : int preference
+val highlight_current_line : bool preference
+val nanoPG : bool preference
val save_pref : unit -> unit
val load_pref : unit -> unit
-val current : pref
-
val configure : ?apply:(unit -> unit) -> unit -> unit
-(* Hooks *)
-val refresh_editor_hook : (unit -> unit) ref
-val refresh_style_hook : (unit -> unit) ref
-val refresh_language_hook : (unit -> unit) ref
-val refresh_toolbar_hook : (unit -> unit) ref
-val resize_window_hook : (unit -> unit) ref
-val refresh_tabs_hook : (unit -> unit) ref
+val stick : 'a preference ->
+ (#GObj.widget as 'obj) -> ('a -> unit) -> unit
val use_default_doc_url : string
diff --git a/ide/session.ml b/ide/session.ml
index a795f6331..e4cc17742 100644
--- a/ide/session.ml
+++ b/ide/session.ml
@@ -8,8 +8,6 @@
open Preferences
-let prefs = Preferences.current
-
(** A session is a script buffer + proof + messages,
interacting with a coqtop, and a few other elements around *)
@@ -18,7 +16,6 @@ class type ['a] page =
inherit GObj.widget
method update : 'a -> unit
method on_update : callback:('a -> unit) -> unit
- method refresh_color : unit -> unit
end
class type control =
@@ -50,8 +47,8 @@ let create_buffer () =
let buffer = GSourceView2.source_buffer
~tag_table:Tags.Script.table
~highlight_matching_brackets:true
- ?language:(lang_manager#language prefs.source_language)
- ?style_scheme:(style_manager#style_scheme prefs.source_style)
+ ?language:(lang_manager#language source_language#get)
+ ?style_scheme:(style_manager#style_scheme source_style#get)
()
in
let _ = buffer#create_mark ~name:"start_of_input" buffer#start_iter in
@@ -254,10 +251,9 @@ let make_table_widget ?sort cd cb =
~model:store ~packing:frame#add () in
let () = data#set_headers_visible true in
let () = data#set_headers_clickable true in
- let refresh () =
- let clr = Tags.color_of_string current.background_color in
- data#misc#modify_base [`NORMAL, `COLOR clr]
- in
+ let refresh clr = data#misc#modify_base [`NORMAL, `NAME clr] in
+ let _ = background_color#connect#changed refresh in
+ let _ = data#misc#connect#realize (fun () -> refresh background_color#get) in
let mk_rend c = GTree.cell_renderer_text [], ["text",c] in
let cols =
List.map2 (fun (_,c) (_,n,v) ->
@@ -285,10 +281,10 @@ let make_table_widget ?sort cd cb =
data#connect#row_activated ~callback:(fun tp vc -> cb columns store tp vc)
);
let () = match sort with None -> () | Some (i, t) -> store#set_sort_column_id i t in
- frame, (fun f -> f columns store), refresh
+ frame, (fun f -> f columns store)
let create_errpage (script : Wg_ScriptView.script_view) : errpage =
- let table, access, refresh =
+ let table, access =
make_table_widget ~sort:(0, `ASCENDING)
[`Int,"Line",true; `String,"Error message",true]
(fun columns store tp vc ->
@@ -320,11 +316,10 @@ let create_errpage (script : Wg_ScriptView.script_view) : errpage =
errs
end
method on_update ~callback:cb = callback := cb
- method refresh_color () = refresh ()
end
let create_jobpage coqtop coqops : jobpage =
- let table, access, refresh =
+ let table, access =
make_table_widget ~sort:(0, `ASCENDING)
[`String,"Worker",true; `String,"Job name",true]
(fun columns store tp vc ->
@@ -360,7 +355,6 @@ let create_jobpage coqtop coqops : jobpage =
jobs
end
method on_update ~callback:cb = callback := cb
- method refresh_color () = refresh ()
end
let create_proof () =
diff --git a/ide/session.mli b/ide/session.mli
index 52e557218..3a6b45858 100644
--- a/ide/session.mli
+++ b/ide/session.mli
@@ -14,7 +14,6 @@ class type ['a] page =
inherit GObj.widget
method update : 'a -> unit
method on_update : callback:('a -> unit) -> unit
- method refresh_color : unit -> unit
end
class type control =
diff --git a/ide/tags.ml b/ide/tags.ml
index c9b57af4c..09b562530 100644
--- a/ide/tags.ml
+++ b/ide/tags.ml
@@ -13,28 +13,15 @@ let make_tag (tt:GText.tag_table) ~name prop =
tt#add new_tag#as_tag;
new_tag
-(* These work fine for colorblind people too *)
-let default_processed_color = "light green"
-let default_processing_color = "light blue"
-let default_error_color = "#FFCCCC"
-let default_error_fg_color = "red"
-let default_color = "cornsilk"
-
-let processed_color = ref default_processed_color
-let processing_color = ref default_processing_color
-let error_color = ref default_error_color
-let error_fg_color = ref default_error_fg_color
-
module Script =
struct
let table = GText.tag_table ()
let comment = make_tag table ~name:"comment" []
- let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE ; `FOREGROUND !error_fg_color]
- let error_bg = make_tag table ~name:"error_bg" [`BACKGROUND !error_color]
- let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color]
- let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color]
+ let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE]
+ let error_bg = make_tag table ~name:"error_bg" []
+ let to_process = make_tag table ~name:"to_process" []
+ let processed = make_tag table ~name:"processed" []
let incomplete = make_tag table ~name:"incomplete" [
- `BACKGROUND !processing_color;
`BACKGROUND_STIPPLE_SET true;
]
let unjustified = make_tag table ~name:"unjustified" [`BACKGROUND "gold"]
@@ -56,7 +43,7 @@ end
module Proof =
struct
let table = GText.tag_table ()
- let highlight = make_tag table ~name:"highlight" [`BACKGROUND !processed_color]
+ let highlight = make_tag table ~name:"highlight" []
let hypothesis = make_tag table ~name:"hypothesis" []
let goal = make_tag table ~name:"goal" []
end
@@ -77,34 +64,3 @@ let string_of_color clr =
let color_of_string s =
let colormap = Gdk.Color.get_system_colormap () in
Gdk.Color.alloc ~colormap (`NAME s)
-
-let get_processed_color () = color_of_string !processed_color
-
-let set_processed_color clr =
- let s = string_of_color clr in
- processed_color := s;
- Script.processed#set_property (`BACKGROUND s);
- Proof.highlight#set_property (`BACKGROUND s)
-
-let get_processing_color () = color_of_string !processing_color
-
-let set_processing_color clr =
- let s = string_of_color clr in
- processing_color := s;
- Script.incomplete#set_property (`BACKGROUND s);
- Script.to_process#set_property (`BACKGROUND s)
-
-let get_error_color () = color_of_string !error_color
-
-let set_error_color clr =
- let s = string_of_color clr in
- error_color := s;
- Script.error_bg#set_property (`BACKGROUND s)
-
-let get_error_fg_color () = color_of_string !error_fg_color
-
-let set_error_fg_color clr =
- let s = string_of_color clr in
- error_fg_color := s;
- Script.error#set_property (`FOREGROUND s)
-
diff --git a/ide/tags.mli b/ide/tags.mli
index 14cfd0dbf..6418d1b2e 100644
--- a/ide/tags.mli
+++ b/ide/tags.mli
@@ -41,22 +41,3 @@ end
val string_of_color : Gdk.color -> string
val color_of_string : string -> Gdk.color
-
-val get_processed_color : unit -> Gdk.color
-val set_processed_color : Gdk.color -> unit
-
-val get_processing_color : unit -> Gdk.color
-val set_processing_color : Gdk.color -> unit
-
-val get_error_color : unit -> Gdk.color
-val set_error_color : Gdk.color -> unit
-
-val get_error_fg_color : unit -> Gdk.color
-val set_error_fg_color : Gdk.color -> unit
-
-val default_processed_color : string
-val default_processing_color : string
-val default_error_color : string
-val default_error_fg_color : string
-val default_color : string
-
diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml
index 7dad92ed6..7d8993aa8 100644
--- a/ide/wg_Command.ml
+++ b/ide/wg_Command.ml
@@ -85,9 +85,11 @@ object(self)
~packing:(vbox#pack ~fill:true ~expand:true) () in
let result = GText.view ~packing:r_bin#add () in
views <- (frame#coerce, result, combo#entry) :: views;
- result#misc#modify_font current.text_font;
- let clr = Tags.color_of_string current.background_color in
- result#misc#modify_base [`NORMAL, `COLOR clr];
+ let cb clr = result#misc#modify_base [`NORMAL, `NAME clr] in
+ let _ = background_color#connect#changed cb in
+ let _ = result#misc#connect#realize (fun () -> cb background_color#get) in
+ let cb ft = result#misc#modify_font (Pango.Font.from_string ft) in
+ stick text_font result cb;
result#misc#set_can_focus true; (* false causes problems for selection *)
result#set_editable false;
let callback () =
@@ -98,11 +100,14 @@ object(self)
if Str.string_match (Str.regexp "\\. *$") com 0 then com
else com ^ " " ^ arg ^" . "
in
- let log level message = result#buffer#insert (message^"\n") in
+ let log level message =
+ Ideutils.insert_xml result#buffer message;
+ result#buffer#insert "\n";
+ in
let process =
Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function
| Interface.Fail (_,l,str) ->
- result#buffer#insert str;
+ Ideutils.insert_xml result#buffer str;
notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce;
Coq.return ()
| Interface.Good res ->
@@ -144,13 +149,9 @@ object(self)
method visible =
frame#visible
-
- method refresh_font () =
- let iter (_,view,_) = view#misc#modify_font current.text_font in
- List.iter iter views
- method refresh_color () =
- let clr = Tags.color_of_string current.background_color in
+ method private refresh_color clr =
+ let clr = Tags.color_of_string clr in
let iter (_,view,_) = view#misc#modify_base [`NORMAL, `COLOR clr] in
List.iter iter views
@@ -158,6 +159,8 @@ object(self)
self#new_page_maker;
self#new_query_aux ~grab_now:false ();
frame#misc#hide ();
+ let _ = background_color#connect#changed self#refresh_color in
+ self#refresh_color background_color#get;
ignore(notebook#event#connect#key_press ~callback:(fun ev ->
if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then (self#hide; true)
else false
diff --git a/ide/wg_Command.mli b/ide/wg_Command.mli
index 91a8f26ca..1f0e31988 100644
--- a/ide/wg_Command.mli
+++ b/ide/wg_Command.mli
@@ -10,8 +10,6 @@ class command_window : string -> Coq.coqtop ->
object
method new_query : ?command:string -> ?term:string -> unit -> unit
method pack_in : (GObj.widget -> unit) -> unit
- method refresh_font : unit -> unit
- method refresh_color : unit -> unit
method show : unit
method hide : unit
method visible : bool
diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml
index 3f5ae4bd5..7d77679ce 100644
--- a/ide/wg_Completion.ml
+++ b/ide/wg_Completion.ml
@@ -258,7 +258,7 @@ object (self)
method private refresh_style () =
let (renderer, _) = renderer in
- let font = Preferences.current.Preferences.text_font in
+ let font = Pango.Font.from_string Preferences.text_font#get in
renderer#set_properties [`FONT_DESC font; `XPAD 10]
method private coordinates pos =
diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml
index 211db537e..615e989de 100644
--- a/ide/wg_MessageView.ml
+++ b/ide/wg_MessageView.ml
@@ -6,11 +6,13 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+open Preferences
+
class type message_view_signals =
object
inherit GObj.misc_signals
inherit GUtil.add_ml_signals
- method pushed : callback:(Pp.message_level -> string -> unit) -> GtkSignal.id
+ method pushed : callback:Ideutils.logger -> GtkSignal.id
end
class message_view_signals_impl obj (pushed : 'a GUtil.signal) : message_view_signals =
@@ -26,14 +28,13 @@ class type message_view =
inherit GObj.widget
method connect : message_view_signals
method clear : unit
- method add : string -> unit
- method set : string -> unit
- method push : Pp.message_level -> string -> unit
+ method add : Richpp.richpp -> unit
+ method add_string : string -> unit
+ method set : Richpp.richpp -> unit
+ method push : Ideutils.logger
(** same as [add], but with an explicit level instead of [Notice] *)
method buffer : GText.buffer
(** for more advanced text edition *)
- method modify_font : Pango.font_description -> unit
- method refresh_color : unit -> unit
end
let message_view () : message_view =
@@ -53,6 +54,12 @@ let message_view () : message_view =
let default_clipboard = GData.clipboard Gdk.Atom.primary in
let _ = buffer#add_selection_clipboard default_clipboard in
let () = view#set_left_margin 2 in
+ view#misc#show ();
+ let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in
+ let _ = background_color#connect#changed cb in
+ let _ = view#misc#connect#realize (fun () -> cb background_color#get) in
+ let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in
+ stick text_font view cb;
object (self)
inherit GObj.widget box#as_widget
@@ -70,23 +77,23 @@ let message_view () : message_view =
| Pp.Warning -> [Tags.Message.warning]
| _ -> []
in
- if msg <> "" then begin
- buffer#insert ~tags msg;
- buffer#insert ~tags "\n";
+ let rec non_empty = function
+ | Xml_datatype.PCData "" -> false
+ | Xml_datatype.PCData _ -> true
+ | Xml_datatype.Element (_, _, children) -> List.exists non_empty children
+ in
+ if non_empty (Richpp.repr msg) then begin
+ Ideutils.insert_xml buffer ~tags msg;
+ buffer#insert (*~tags*) "\n";
push#call (level, msg)
end
method add msg = self#push Pp.Notice msg
+ method add_string s = self#add (Richpp.richpp_of_string s)
+
method set msg = self#clear; self#add msg
method buffer = text_buffer
- method modify_font fd = view#misc#modify_font fd
-
- method refresh_color () =
- let open Preferences in
- let clr = Tags.color_of_string current.background_color in
- view#misc#modify_base [`NORMAL, `COLOR clr]
-
end
diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli
index 23c94f404..388ab259f 100644
--- a/ide/wg_MessageView.mli
+++ b/ide/wg_MessageView.mli
@@ -10,7 +10,7 @@ class type message_view_signals =
object
inherit GObj.misc_signals
inherit GUtil.add_ml_signals
- method pushed : callback:(Pp.message_level -> string -> unit) -> GtkSignal.id
+ method pushed : callback:Ideutils.logger -> GtkSignal.id
end
class type message_view =
@@ -18,14 +18,13 @@ class type message_view =
inherit GObj.widget
method connect : message_view_signals
method clear : unit
- method add : string -> unit
- method set : string -> unit
- method push : Pp.message_level -> string -> unit
+ method add : Richpp.richpp -> unit
+ method add_string : string -> unit
+ method set : Richpp.richpp -> unit
+ method push : Ideutils.logger
(** same as [add], but with an explicit level instead of [Notice] *)
method buffer : GText.buffer
(** for more advanced text edition *)
- method modify_font : Pango.font_description -> unit
- method refresh_color : unit -> unit
end
val message_view : unit -> message_view
diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml
index 69d460b01..148add6e9 100644
--- a/ide/wg_ProofView.ml
+++ b/ide/wg_ProofView.ml
@@ -7,6 +7,8 @@
(************************************************************************)
open Util
+open Preferences
+open Ideutils
class type proof_view =
object
@@ -82,7 +84,8 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with
let () = hook_tag_cb tag hint sel_cb on_hover in
[tag], hints
in
- let () = proof#buffer#insert ~tags (hyp ^ "\n") in
+ let () = insert_xml ~tags proof#buffer hyp in
+ proof#buffer#insert "\n";
insert_hyp rem_hints hs
in
let () = proof#buffer#insert head_str in
@@ -95,13 +98,14 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with
else []
in
proof#buffer#insert (goal_str 1 goals_cnt);
- proof#buffer#insert ~tags cur_goal;
+ insert_xml proof#buffer cur_goal;
proof#buffer#insert "\n"
in
(* Insert remaining goals (no hypotheses) *)
let fold_goal i _ { Interface.goal_ccl = g } =
proof#buffer#insert (goal_str i goals_cnt);
- proof#buffer#insert (g ^ "\n")
+ insert_xml proof#buffer g;
+ proof#buffer#insert "\n"
in
let () = Util.List.fold_left_i fold_goal 2 () rem_goals in
@@ -115,10 +119,12 @@ let mode_cesar (proof : #GText.view_skel) = function
| { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: _ ->
proof#buffer#insert " *** Declarative Mode ***\n";
List.iter
- (fun hyp -> proof#buffer#insert (hyp^"\n"))
+ (fun hyp -> insert_xml proof#buffer hyp; proof#buffer#insert "\n")
hyps;
proof#buffer#insert "______________________________________\n";
- proof#buffer#insert ("thesis := \n "^cur_goal^"\n");
+ proof#buffer#insert "thesis := \n ";
+ insert_xml proof#buffer cur_goal;
+ proof#buffer#insert "\n";
ignore (proof#scroll_to_iter (proof#buffer#get_iter_at_mark `INSERT))
let rec flatten = function
@@ -151,8 +157,8 @@ let display mode (view : #GText.view_skel) goals hints evars =
(* The proof is finished, with the exception of given up goals. *)
view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n";
let iter goal =
- let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
- view#buffer#insert msg
+ insert_xml view#buffer goal.Interface.goal_ccl;
+ view#buffer#insert "\n"
in
List.iter iter given_up_goals;
view#buffer#insert "\nYou need to go back and solve them."
@@ -160,8 +166,8 @@ let display mode (view : #GText.view_skel) goals hints evars =
(* All the goals have been resolved but those on the shelf. *)
view#buffer#insert "All the remaining goals are on the shelf:\n\n";
let iter goal =
- let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
- view#buffer#insert msg
+ insert_xml view#buffer goal.Interface.goal_ccl;
+ view#buffer#insert "\n"
in
List.iter iter shelved_goals
| _, _, _, _ ->
@@ -173,8 +179,8 @@ let display mode (view : #GText.view_skel) goals hints evars =
view#buffer#insert "This subproof is complete, but there are some unfocused goals:\n\n";
let iter i goal =
let () = view#buffer#insert (goal_str (succ i)) in
- let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
- view#buffer#insert msg
+ insert_xml view#buffer goal.Interface.goal_ccl;
+ view#buffer#insert "\n"
in
List.iteri iter bg
end
@@ -193,6 +199,12 @@ let proof_view () =
let () = Gtk_parsing.fix_double_click view in
let default_clipboard = GData.clipboard Gdk.Atom.primary in
let _ = buffer#add_selection_clipboard default_clipboard in
+ let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in
+ let _ = background_color#connect#changed cb in
+ let _ = view#misc#connect#realize (fun () -> cb background_color#get) in
+ let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in
+ stick text_font view cb;
+
object
inherit GObj.widget view#as_widget
val mutable goals = None
diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml
index ae50b2837..b672e016b 100644
--- a/ide/wg_ScriptView.ml
+++ b/ide/wg_ScriptView.ml
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+open Preferences
+
type insert_action = {
ins_val : string;
ins_off : int;
@@ -456,6 +458,33 @@ object (self)
if not proceed then GtkSignal.stop_emit ()
in
let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in
+ (** Plug on preferences *)
+ let cb clr = self#misc#modify_base [`NORMAL, `NAME clr] in
+ let _ = background_color#connect#changed cb in
+ let _ = self#misc#connect#realize (fun () -> cb background_color#get) in
+
+ let cb b = self#set_wrap_mode (if b then `WORD else `NONE) in
+ stick dynamic_word_wrap self cb;
+ stick show_line_number self self#set_show_line_numbers;
+ stick auto_indent self self#set_auto_indent;
+ stick highlight_current_line self self#set_highlight_current_line;
+
+ (* Hack to handle missing binding in lablgtk *)
+ let cb b =
+ let flag = if b then 0b1001011 (* SPACE, TAB, NBSP, TRAILING *) else 0 in
+ let conv = Gobject.({ name = "draw-spaces"; conv = Data.int }) in
+ Gobject.set conv self#as_widget flag
+ in
+ stick show_spaces self cb;
+
+ stick show_right_margin self self#set_show_right_margin;
+ stick spaces_instead_of_tabs self self#set_insert_spaces_instead_of_tabs;
+ stick tab_length self self#set_tab_width;
+ stick auto_complete self self#set_auto_complete;
+
+ let cb ft = self#misc#modify_font (Pango.Font.from_string ft) in
+ stick text_font self cb;
+
()
end
diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml
index 25a031d6e..2ee288454 100644
--- a/ide/wg_Segment.ml
+++ b/ide/wg_Segment.ml
@@ -7,6 +7,7 @@
(************************************************************************)
open Util
+open Preferences
type color = GDraw.color
@@ -122,6 +123,8 @@ object (self)
true
in
let _ = eventbox#event#connect#button_press clicked_cb in
+ let cb show = if show then self#misc#show () else self#misc#hide () in
+ stick show_progress_bar self cb;
(** Initial pixmap *)
draw#set_pixmap pixmap
diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml
index 84fd8929b..bb6a18158 100644
--- a/ide/xmlprotocol.ml
+++ b/ide/xmlprotocol.ml
@@ -10,7 +10,7 @@
(** WARNING: TO BE UPDATED WHEN MODIFIED! *)
-let protocol_version = "20140312"
+let protocol_version = "20150913"
(** * Interface of calls to Coq by CoqIde *)
@@ -92,7 +92,7 @@ let of_value f = function
| None -> []
| Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in
let id = Stateid.to_xml id in
- Element ("value", ["val", "fail"] @ loc, [id;PCData msg])
+ Element ("value", ["val", "fail"] @ loc, [id; Richpp.of_richpp msg])
let to_value f = function
| Element ("value", attrs, l) ->
let ans = massoc "val" attrs in
@@ -105,8 +105,9 @@ let to_value f = function
Some (loc_s, loc_e)
with Marshal_error | Failure _ -> None
in
- let id = Stateid.of_xml (List.hd l) in
- let msg = raw_string (List.tl l) in
+ let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise Marshal_error in
+ let id = Stateid.of_xml id in
+ let msg = Richpp.to_richpp msg in
Fail (id, loc, msg)
else raise Marshal_error
| _ -> raise Marshal_error
@@ -133,14 +134,14 @@ let to_evar = function
| _ -> raise Marshal_error
let of_goal g =
- let hyp = of_list of_string g.goal_hyp in
- let ccl = of_string g.goal_ccl in
+ let hyp = of_list Richpp.of_richpp g.goal_hyp in
+ let ccl = Richpp.of_richpp g.goal_ccl in
let id = of_string g.goal_id in
Element ("goal", [], [id; hyp; ccl])
let to_goal = function
| Element ("goal", [], [id; hyp; ccl]) ->
- let hyp = to_list to_string hyp in
- let ccl = to_string ccl in
+ let hyp = to_list Richpp.to_richpp hyp in
+ let ccl = Richpp.to_richpp ccl in
let id = to_string id in
{ goal_hyp = hyp; goal_ccl = ccl; goal_id = id; }
| _ -> raise Marshal_error
@@ -220,22 +221,31 @@ module ReifType : sig
end = struct
- type value_type =
- | Unit | String | Int | Bool | Xml
+ type _ val_t =
+ | Unit : unit val_t
+ | String : string val_t
+ | Int : int val_t
+ | Bool : bool val_t
+ | Xml : Xml_datatype.xml val_t
- | Option of value_type
- | List of value_type
- | Pair of value_type * value_type
- | Union of value_type * value_type
+ | Option : 'a val_t -> 'a option val_t
+ | List : 'a val_t -> 'a list val_t
+ | Pair : 'a val_t * 'b val_t -> ('a * 'b) val_t
+ | Union : 'a val_t * 'b val_t -> ('a, 'b) union val_t
- | Goals | Evar | State | Option_state | Option_value | Coq_info
- | Coq_object of value_type
- | State_id
- | Search_cst
+ | Goals : goals val_t
+ | Evar : evar val_t
+ | State : status val_t
+ | Option_state : option_state val_t
+ | Option_value : option_value val_t
+ | Coq_info : coq_info val_t
+ | Coq_object : 'a val_t -> 'a coq_object val_t
+ | State_id : state_id val_t
+ | Search_cst : search_constraint val_t
- type 'a val_t = value_type
+ type value_type = Value_type : 'a val_t -> value_type
- let erase (x : 'a val_t) : value_type = x
+ let erase (x : 'a val_t) = Value_type x
let unit_t = Unit
let string_t = String
@@ -259,48 +269,48 @@ end = struct
let search_cst_t = Search_cst
let of_value_type (ty : 'a val_t) : 'a -> xml =
- let rec convert ty : 'a -> xml = match ty with
- | Unit -> Obj.magic of_unit
- | Bool -> Obj.magic of_bool
- | Xml -> Obj.magic (fun x -> x)
- | String -> Obj.magic of_string
- | Int -> Obj.magic of_int
- | State -> Obj.magic of_status
- | Option_state -> Obj.magic of_option_state
- | Option_value -> Obj.magic of_option_value
- | Coq_info -> Obj.magic of_coq_info
- | Goals -> Obj.magic of_goals
- | Evar -> Obj.magic of_evar
- | List t -> Obj.magic (of_list (convert t))
- | Option t -> Obj.magic (of_option (convert t))
- | Coq_object t -> Obj.magic (of_coq_object (convert t))
- | Pair (t1,t2) -> Obj.magic (of_pair (convert t1) (convert t2))
- | Union (t1,t2) -> Obj.magic (of_union (convert t1) (convert t2))
- | State_id -> Obj.magic Stateid.to_xml
- | Search_cst -> Obj.magic of_search_cst
+ let rec convert : type a. a val_t -> a -> xml = function
+ | Unit -> of_unit
+ | Bool -> of_bool
+ | Xml -> (fun x -> x)
+ | String -> of_string
+ | Int -> of_int
+ | State -> of_status
+ | Option_state -> of_option_state
+ | Option_value -> of_option_value
+ | Coq_info -> of_coq_info
+ | Goals -> of_goals
+ | Evar -> of_evar
+ | List t -> (of_list (convert t))
+ | Option t -> (of_option (convert t))
+ | Coq_object t -> (of_coq_object (convert t))
+ | Pair (t1,t2) -> (of_pair (convert t1) (convert t2))
+ | Union (t1,t2) -> (of_union (convert t1) (convert t2))
+ | State_id -> Stateid.to_xml
+ | Search_cst -> of_search_cst
in
convert ty
let to_value_type (ty : 'a val_t) : xml -> 'a =
- let rec convert ty : xml -> 'a = match ty with
- | Unit -> Obj.magic to_unit
- | Bool -> Obj.magic to_bool
- | Xml -> Obj.magic (fun x -> x)
- | String -> Obj.magic to_string
- | Int -> Obj.magic to_int
- | State -> Obj.magic to_status
- | Option_state -> Obj.magic to_option_state
- | Option_value -> Obj.magic to_option_value
- | Coq_info -> Obj.magic to_coq_info
- | Goals -> Obj.magic to_goals
- | Evar -> Obj.magic to_evar
- | List t -> Obj.magic (to_list (convert t))
- | Option t -> Obj.magic (to_option (convert t))
- | Coq_object t -> Obj.magic (to_coq_object (convert t))
- | Pair (t1,t2) -> Obj.magic (to_pair (convert t1) (convert t2))
- | Union (t1,t2) -> Obj.magic (to_union (convert t1) (convert t2))
- | State_id -> Obj.magic Stateid.of_xml
- | Search_cst -> Obj.magic to_search_cst
+ let rec convert : type a. a val_t -> xml -> a = function
+ | Unit -> to_unit
+ | Bool -> to_bool
+ | Xml -> (fun x -> x)
+ | String -> to_string
+ | Int -> to_int
+ | State -> to_status
+ | Option_state -> to_option_state
+ | Option_value -> to_option_value
+ | Coq_info -> to_coq_info
+ | Goals -> to_goals
+ | Evar -> to_evar
+ | List t -> (to_list (convert t))
+ | Option t -> (to_option (convert t))
+ | Coq_object t -> (to_coq_object (convert t))
+ | Pair (t1,t2) -> (to_pair (convert t1) (convert t2))
+ | Union (t1,t2) -> (to_union (convert t1) (convert t2))
+ | State_id -> Stateid.of_xml
+ | Search_cst -> to_search_cst
in
convert ty
@@ -320,10 +330,9 @@ end = struct
(List.length lg + List.length rg) pr_focus l in
Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals
else
- let pr_menu s = s in
let pr_goal { goal_hyp = hyps; goal_ccl = goal } =
- "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^
- pr_menu goal ^ "]" in
+ "[" ^ String.concat "; " (List.map Richpp.raw_print hyps) ^ " |- " ^
+ Richpp.raw_print goal ^ "]" in
String.concat " " (List.map pr_goal g.fg_goals)
let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]"
let pr_status (s : status) =
@@ -350,6 +359,7 @@ end = struct
let pr_coq_object (o : 'a coq_object) = "FIXME"
let pr_pair pr1 pr2 (a,b) = "("^pr1 a^","^pr2 b^")"
let pr_union pr1 pr2 = function Inl x -> "Inl "^pr1 x | Inr x -> "Inr "^pr2 x
+ let pr_state_id = Stateid.to_string
let pr_search_cst = function
| Name_Pattern s -> "Name_Pattern " ^ s
@@ -358,30 +368,30 @@ end = struct
| In_Module s -> "In_Module " ^ String.concat "." s
| Include_Blacklist -> "Include_Blacklist"
- let rec print = function
- | Unit -> Obj.magic pr_unit
- | Bool -> Obj.magic pr_bool
- | String -> Obj.magic pr_string
- | Xml -> Obj.magic Xml_printer.to_string_fmt
- | Int -> Obj.magic pr_int
- | State -> Obj.magic pr_status
- | Option_state -> Obj.magic pr_option_state
- | Option_value -> Obj.magic pr_option_value
- | Search_cst -> Obj.magic pr_search_cst
- | Coq_info -> Obj.magic pr_coq_info
- | Goals -> Obj.magic pr_goal
- | Evar -> Obj.magic pr_evar
- | List t -> Obj.magic (pr_list (print t))
- | Option t -> Obj.magic (pr_option (print t))
- | Coq_object t -> Obj.magic pr_coq_object
- | Pair (t1,t2) -> Obj.magic (pr_pair (print t1) (print t2))
- | Union (t1,t2) -> Obj.magic (pr_union (print t1) (print t2))
- | State_id -> Obj.magic pr_int
+ let rec print : type a. a val_t -> a -> string = function
+ | Unit -> pr_unit
+ | Bool -> pr_bool
+ | String -> pr_string
+ | Xml -> Xml_printer.to_string_fmt
+ | Int -> pr_int
+ | State -> pr_status
+ | Option_state -> pr_option_state
+ | Option_value -> pr_option_value
+ | Search_cst -> pr_search_cst
+ | Coq_info -> pr_coq_info
+ | Goals -> pr_goal
+ | Evar -> pr_evar
+ | List t -> (pr_list (print t))
+ | Option t -> (pr_option (print t))
+ | Coq_object t -> pr_coq_object
+ | Pair (t1,t2) -> (pr_pair (print t1) (print t2))
+ | Union (t1,t2) -> (pr_union (print t1) (print t2))
+ | State_id -> pr_state_id
(* This is to break if a rename/refactoring makes the strings below outdated *)
type 'a exists = bool
- let rec print_type = function
+ let rec print_val_t : type a. a val_t -> string = function
| Unit -> "unit"
| Bool -> "bool"
| String -> "string"
@@ -394,33 +404,35 @@ end = struct
| Coq_info -> assert(true : coq_info exists); "Interface.coq_info"
| Goals -> assert(true : goals exists); "Interface.goals"
| Evar -> assert(true : evar exists); "Interface.evar"
- | List t -> Printf.sprintf "(%s list)" (print_type t)
- | Option t -> Printf.sprintf "(%s option)" (print_type t)
+ | List t -> Printf.sprintf "(%s list)" (print_val_t t)
+ | Option t -> Printf.sprintf "(%s option)" (print_val_t t)
| Coq_object t -> assert(true : 'a coq_object exists);
- Printf.sprintf "(%s Interface.coq_object)" (print_type t)
- | Pair (t1,t2) -> Printf.sprintf "(%s * %s)" (print_type t1) (print_type t2)
+ Printf.sprintf "(%s Interface.coq_object)" (print_val_t t)
+ | Pair (t1,t2) -> Printf.sprintf "(%s * %s)" (print_val_t t1) (print_val_t t2)
| Union (t1,t2) -> assert(true : ('a,'b) CSig.union exists);
- Printf.sprintf "((%s, %s) CSig.union)" (print_type t1) (print_type t2)
+ Printf.sprintf "((%s, %s) CSig.union)" (print_val_t t1) (print_val_t t2)
| State_id -> assert(true : Stateid.t exists); "Stateid.t"
+ let print_type = function Value_type ty -> print_val_t ty
+
let document_type_encoding pr_xml =
Printf.printf "\n=== Data encoding by examples ===\n\n";
- Printf.printf "%s:\n\n%s\n\n" (print_type Unit) (pr_xml (of_unit ()));
- Printf.printf "%s:\n\n%s\n%s\n\n" (print_type Bool)
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t Unit) (pr_xml (of_unit ()));
+ Printf.printf "%s:\n\n%s\n%s\n\n" (print_val_t Bool)
(pr_xml (of_bool true)) (pr_xml (of_bool false));
- Printf.printf "%s:\n\n%s\n\n" (print_type String) (pr_xml (of_string "hello"));
- Printf.printf "%s:\n\n%s\n\n" (print_type Int) (pr_xml (of_int 256));
- Printf.printf "%s:\n\n%s\n\n" (print_type State_id) (pr_xml (Stateid.to_xml Stateid.initial));
- Printf.printf "%s:\n\n%s\n\n" (print_type (List Int)) (pr_xml (of_list of_int [3;4;5]));
- Printf.printf "%s:\n\n%s\n%s\n\n" (print_type (Option Int))
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t String) (pr_xml (of_string "hello"));
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t Int) (pr_xml (of_int 256));
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t State_id) (pr_xml (Stateid.to_xml Stateid.initial));
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t (List Int)) (pr_xml (of_list of_int [3;4;5]));
+ Printf.printf "%s:\n\n%s\n%s\n\n" (print_val_t (Option Int))
(pr_xml (of_option of_int (Some 3))) (pr_xml (of_option of_int None));
- Printf.printf "%s:\n\n%s\n\n" (print_type (Pair (Bool,Int)))
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t (Pair (Bool,Int)))
(pr_xml (of_pair of_bool of_int (false,3)));
- Printf.printf "%s:\n\n%s\n\n" (print_type (Union (Bool,Int)))
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t (Union (Bool,Int)))
(pr_xml (of_union of_bool of_int (Inl false)));
print_endline ("All other types are records represented by a node named like the OCaml\n"^
"type which contains a flattened n-tuple. We provide one example.\n");
- Printf.printf "%s:\n\n%s\n\n" (print_type Option_state)
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t Option_state)
(pr_xml (of_option_state { opt_sync = true; opt_depr = false;
opt_name = "name1"; opt_value = IntValue (Some 37) }));
@@ -496,27 +508,27 @@ let calls = [|
|]
type 'a call =
- | Add of add_sty
- | Edit_at of edit_at_sty
- | Query of query_sty
- | Goal of goals_sty
- | Evars of evars_sty
- | Hints of hints_sty
- | Status of status_sty
- | Search of search_sty
- | GetOptions of get_options_sty
- | SetOptions of set_options_sty
- | MkCases of mkcases_sty
- | Quit of quit_sty
- | About of about_sty
- | Init of init_sty
- | StopWorker of stop_worker_sty
+ | Add : add_sty -> add_rty call
+ | Edit_at : edit_at_sty -> edit_at_rty call
+ | Query : query_sty -> query_rty call
+ | Goal : goals_sty -> goals_rty call
+ | Evars : evars_sty -> evars_rty call
+ | Hints : hints_sty -> hints_rty call
+ | Status : status_sty -> status_rty call
+ | Search : search_sty -> search_rty call
+ | GetOptions : get_options_sty -> get_options_rty call
+ | SetOptions : set_options_sty -> set_options_rty call
+ | MkCases : mkcases_sty -> mkcases_rty call
+ | Quit : quit_sty -> quit_rty call
+ | About : about_sty -> about_rty call
+ | Init : init_sty -> init_rty call
+ | StopWorker : stop_worker_sty -> stop_worker_rty call
(* retrocompatibility *)
- | Interp of interp_sty
- | PrintAst of print_ast_sty
- | Annotate of annotate_sty
+ | Interp : interp_sty -> interp_rty call
+ | PrintAst : print_ast_sty -> print_ast_rty call
+ | Annotate : annotate_sty -> annotate_rty call
-let id_of_call = function
+let id_of_call : type a. a call -> int = function
| Add _ -> 0
| Edit_at _ -> 1
| Query _ -> 2
@@ -538,7 +550,7 @@ let id_of_call = function
let str_of_call c = pi1 calls.(id_of_call c)
-type unknown
+type unknown_call = Unknown : 'a call -> unknown_call
(** We use phantom types and GADT to protect ourselves against wild casts *)
let add x : add_rty call = Add x
@@ -559,8 +571,8 @@ let stop_worker x : stop_worker_rty call = StopWorker x
let print_ast x : print_ast_rty call = PrintAst x
let annotate x : annotate_rty call = Annotate x
-let abstract_eval_call handler (c : 'a call) : 'a value =
- let mkGood x : 'a value = Good (Obj.magic x) in
+let abstract_eval_call : type a. _ -> a call -> a value = fun handler c ->
+ let mkGood : type a. a -> a value = fun x -> Good x in
try
match c with
| Add x -> mkGood (handler.add x)
@@ -586,47 +598,47 @@ let abstract_eval_call handler (c : 'a call) : 'a value =
Fail (handler.handle_exn any)
(** brain dead code, edit if protocol messages are added/removed *)
-let of_answer (q : 'a call) (v : 'a value) : xml = match q with
- | Add _ -> of_value (of_value_type add_rty_t ) (Obj.magic v)
- | Edit_at _ -> of_value (of_value_type edit_at_rty_t ) (Obj.magic v)
- | Query _ -> of_value (of_value_type query_rty_t ) (Obj.magic v)
- | Goal _ -> of_value (of_value_type goals_rty_t ) (Obj.magic v)
- | Evars _ -> of_value (of_value_type evars_rty_t ) (Obj.magic v)
- | Hints _ -> of_value (of_value_type hints_rty_t ) (Obj.magic v)
- | Status _ -> of_value (of_value_type status_rty_t ) (Obj.magic v)
- | Search _ -> of_value (of_value_type search_rty_t ) (Obj.magic v)
- | GetOptions _ -> of_value (of_value_type get_options_rty_t) (Obj.magic v)
- | SetOptions _ -> of_value (of_value_type set_options_rty_t) (Obj.magic v)
- | MkCases _ -> of_value (of_value_type mkcases_rty_t ) (Obj.magic v)
- | Quit _ -> of_value (of_value_type quit_rty_t ) (Obj.magic v)
- | About _ -> of_value (of_value_type about_rty_t ) (Obj.magic v)
- | Init _ -> of_value (of_value_type init_rty_t ) (Obj.magic v)
- | Interp _ -> of_value (of_value_type interp_rty_t ) (Obj.magic v)
- | StopWorker _ -> of_value (of_value_type stop_worker_rty_t) (Obj.magic v)
- | PrintAst _ -> of_value (of_value_type print_ast_rty_t ) (Obj.magic v)
- | Annotate _ -> of_value (of_value_type annotate_rty_t ) (Obj.magic v)
-
-let to_answer (q : 'a call) (x : xml) : 'a value = match q with
- | Add _ -> Obj.magic (to_value (to_value_type add_rty_t ) x)
- | Edit_at _ -> Obj.magic (to_value (to_value_type edit_at_rty_t ) x)
- | Query _ -> Obj.magic (to_value (to_value_type query_rty_t ) x)
- | Goal _ -> Obj.magic (to_value (to_value_type goals_rty_t ) x)
- | Evars _ -> Obj.magic (to_value (to_value_type evars_rty_t ) x)
- | Hints _ -> Obj.magic (to_value (to_value_type hints_rty_t ) x)
- | Status _ -> Obj.magic (to_value (to_value_type status_rty_t ) x)
- | Search _ -> Obj.magic (to_value (to_value_type search_rty_t ) x)
- | GetOptions _ -> Obj.magic (to_value (to_value_type get_options_rty_t) x)
- | SetOptions _ -> Obj.magic (to_value (to_value_type set_options_rty_t) x)
- | MkCases _ -> Obj.magic (to_value (to_value_type mkcases_rty_t ) x)
- | Quit _ -> Obj.magic (to_value (to_value_type quit_rty_t ) x)
- | About _ -> Obj.magic (to_value (to_value_type about_rty_t ) x)
- | Init _ -> Obj.magic (to_value (to_value_type init_rty_t ) x)
- | Interp _ -> Obj.magic (to_value (to_value_type interp_rty_t ) x)
- | StopWorker _ -> Obj.magic (to_value (to_value_type stop_worker_rty_t) x)
- | PrintAst _ -> Obj.magic (to_value (to_value_type print_ast_rty_t ) x)
- | Annotate _ -> Obj.magic (to_value (to_value_type annotate_rty_t ) x)
-
-let of_call (q : 'a call) : xml =
+let of_answer : type a. a call -> a value -> xml = function
+ | Add _ -> of_value (of_value_type add_rty_t )
+ | Edit_at _ -> of_value (of_value_type edit_at_rty_t )
+ | Query _ -> of_value (of_value_type query_rty_t )
+ | Goal _ -> of_value (of_value_type goals_rty_t )
+ | Evars _ -> of_value (of_value_type evars_rty_t )
+ | Hints _ -> of_value (of_value_type hints_rty_t )
+ | Status _ -> of_value (of_value_type status_rty_t )
+ | Search _ -> of_value (of_value_type search_rty_t )
+ | GetOptions _ -> of_value (of_value_type get_options_rty_t)
+ | SetOptions _ -> of_value (of_value_type set_options_rty_t)
+ | MkCases _ -> of_value (of_value_type mkcases_rty_t )
+ | Quit _ -> of_value (of_value_type quit_rty_t )
+ | About _ -> of_value (of_value_type about_rty_t )
+ | Init _ -> of_value (of_value_type init_rty_t )
+ | Interp _ -> of_value (of_value_type interp_rty_t )
+ | StopWorker _ -> of_value (of_value_type stop_worker_rty_t)
+ | PrintAst _ -> of_value (of_value_type print_ast_rty_t )
+ | Annotate _ -> of_value (of_value_type annotate_rty_t )
+
+let to_answer : type a. a call -> xml -> a value = function
+ | Add _ -> to_value (to_value_type add_rty_t )
+ | Edit_at _ -> to_value (to_value_type edit_at_rty_t )
+ | Query _ -> to_value (to_value_type query_rty_t )
+ | Goal _ -> to_value (to_value_type goals_rty_t )
+ | Evars _ -> to_value (to_value_type evars_rty_t )
+ | Hints _ -> to_value (to_value_type hints_rty_t )
+ | Status _ -> to_value (to_value_type status_rty_t )
+ | Search _ -> to_value (to_value_type search_rty_t )
+ | GetOptions _ -> to_value (to_value_type get_options_rty_t)
+ | SetOptions _ -> to_value (to_value_type set_options_rty_t)
+ | MkCases _ -> to_value (to_value_type mkcases_rty_t )
+ | Quit _ -> to_value (to_value_type quit_rty_t )
+ | About _ -> to_value (to_value_type about_rty_t )
+ | Init _ -> to_value (to_value_type init_rty_t )
+ | Interp _ -> to_value (to_value_type interp_rty_t )
+ | StopWorker _ -> to_value (to_value_type stop_worker_rty_t)
+ | PrintAst _ -> to_value (to_value_type print_ast_rty_t )
+ | Annotate _ -> to_value (to_value_type annotate_rty_t )
+
+let of_call : type a. a call -> xml = fun q ->
let mkCall x = constructor "call" (str_of_call q) [x] in
match q with
| Add x -> mkCall (of_value_type add_sty_t x)
@@ -648,59 +660,59 @@ let of_call (q : 'a call) : xml =
| PrintAst x -> mkCall (of_value_type print_ast_sty_t x)
| Annotate x -> mkCall (of_value_type annotate_sty_t x)
-let to_call : xml -> unknown call =
+let to_call : xml -> unknown_call =
do_match "call" (fun s a ->
let mkCallArg vt a = to_value_type vt (singleton a) in
match s with
- | "Add" -> Add (mkCallArg add_sty_t a)
- | "Edit_at" -> Edit_at (mkCallArg edit_at_sty_t a)
- | "Query" -> Query (mkCallArg query_sty_t a)
- | "Goal" -> Goal (mkCallArg goals_sty_t a)
- | "Evars" -> Evars (mkCallArg evars_sty_t a)
- | "Hints" -> Hints (mkCallArg hints_sty_t a)
- | "Status" -> Status (mkCallArg status_sty_t a)
- | "Search" -> Search (mkCallArg search_sty_t a)
- | "GetOptions" -> GetOptions (mkCallArg get_options_sty_t a)
- | "SetOptions" -> SetOptions (mkCallArg set_options_sty_t a)
- | "MkCases" -> MkCases (mkCallArg mkcases_sty_t a)
- | "Quit" -> Quit (mkCallArg quit_sty_t a)
- | "About" -> About (mkCallArg about_sty_t a)
- | "Init" -> Init (mkCallArg init_sty_t a)
- | "Interp" -> Interp (mkCallArg interp_sty_t a)
- | "StopWorker" -> StopWorker (mkCallArg stop_worker_sty_t a)
- | "PrintAst" -> PrintAst (mkCallArg print_ast_sty_t a)
- | "Annotate" -> Annotate (mkCallArg annotate_sty_t a)
+ | "Add" -> Unknown (Add (mkCallArg add_sty_t a))
+ | "Edit_at" -> Unknown (Edit_at (mkCallArg edit_at_sty_t a))
+ | "Query" -> Unknown (Query (mkCallArg query_sty_t a))
+ | "Goal" -> Unknown (Goal (mkCallArg goals_sty_t a))
+ | "Evars" -> Unknown (Evars (mkCallArg evars_sty_t a))
+ | "Hints" -> Unknown (Hints (mkCallArg hints_sty_t a))
+ | "Status" -> Unknown (Status (mkCallArg status_sty_t a))
+ | "Search" -> Unknown (Search (mkCallArg search_sty_t a))
+ | "GetOptions" -> Unknown (GetOptions (mkCallArg get_options_sty_t a))
+ | "SetOptions" -> Unknown (SetOptions (mkCallArg set_options_sty_t a))
+ | "MkCases" -> Unknown (MkCases (mkCallArg mkcases_sty_t a))
+ | "Quit" -> Unknown (Quit (mkCallArg quit_sty_t a))
+ | "About" -> Unknown (About (mkCallArg about_sty_t a))
+ | "Init" -> Unknown (Init (mkCallArg init_sty_t a))
+ | "Interp" -> Unknown (Interp (mkCallArg interp_sty_t a))
+ | "StopWorker" -> Unknown (StopWorker (mkCallArg stop_worker_sty_t a))
+ | "PrintAst" -> Unknown (PrintAst (mkCallArg print_ast_sty_t a))
+ | "Annotate" -> Unknown (Annotate (mkCallArg annotate_sty_t a))
| _ -> raise Marshal_error)
(** Debug printing *)
let pr_value_gen pr = function
| Good v -> "GOOD " ^ pr v
- | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^str^"]"
+ | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^Richpp.raw_print str^"]"
| Fail (id,Some(i,j),str) ->
"FAIL "^Stateid.to_string id^
- " ("^string_of_int i^","^string_of_int j^")["^str^"]"
+ " ("^string_of_int i^","^string_of_int j^")["^Richpp.raw_print str^"]"
let pr_value v = pr_value_gen (fun _ -> "FIXME") v
-let pr_full_value call value = match call with
- | Add _ -> pr_value_gen (print add_rty_t ) (Obj.magic value)
- | Edit_at _ -> pr_value_gen (print edit_at_rty_t ) (Obj.magic value)
- | Query _ -> pr_value_gen (print query_rty_t ) (Obj.magic value)
- | Goal _ -> pr_value_gen (print goals_rty_t ) (Obj.magic value)
- | Evars _ -> pr_value_gen (print evars_rty_t ) (Obj.magic value)
- | Hints _ -> pr_value_gen (print hints_rty_t ) (Obj.magic value)
- | Status _ -> pr_value_gen (print status_rty_t ) (Obj.magic value)
- | Search _ -> pr_value_gen (print search_rty_t ) (Obj.magic value)
- | GetOptions _ -> pr_value_gen (print get_options_rty_t) (Obj.magic value)
- | SetOptions _ -> pr_value_gen (print set_options_rty_t) (Obj.magic value)
- | MkCases _ -> pr_value_gen (print mkcases_rty_t ) (Obj.magic value)
- | Quit _ -> pr_value_gen (print quit_rty_t ) (Obj.magic value)
- | About _ -> pr_value_gen (print about_rty_t ) (Obj.magic value)
- | Init _ -> pr_value_gen (print init_rty_t ) (Obj.magic value)
- | Interp _ -> pr_value_gen (print interp_rty_t ) (Obj.magic value)
- | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) (Obj.magic value)
- | PrintAst _ -> pr_value_gen (print print_ast_rty_t ) (Obj.magic value)
- | Annotate _ -> pr_value_gen (print annotate_rty_t ) (Obj.magic value)
-let pr_call call =
+let pr_full_value : type a. a call -> a value -> string = fun call value -> match call with
+ | Add _ -> pr_value_gen (print add_rty_t ) value
+ | Edit_at _ -> pr_value_gen (print edit_at_rty_t ) value
+ | Query _ -> pr_value_gen (print query_rty_t ) value
+ | Goal _ -> pr_value_gen (print goals_rty_t ) value
+ | Evars _ -> pr_value_gen (print evars_rty_t ) value
+ | Hints _ -> pr_value_gen (print hints_rty_t ) value
+ | Status _ -> pr_value_gen (print status_rty_t ) value
+ | Search _ -> pr_value_gen (print search_rty_t ) value
+ | GetOptions _ -> pr_value_gen (print get_options_rty_t) value
+ | SetOptions _ -> pr_value_gen (print set_options_rty_t) value
+ | MkCases _ -> pr_value_gen (print mkcases_rty_t ) value
+ | Quit _ -> pr_value_gen (print quit_rty_t ) value
+ | About _ -> pr_value_gen (print about_rty_t ) value
+ | Init _ -> pr_value_gen (print init_rty_t ) value
+ | Interp _ -> pr_value_gen (print interp_rty_t ) value
+ | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) value
+ | PrintAst _ -> pr_value_gen (print print_ast_rty_t ) value
+ | Annotate _ -> pr_value_gen (print annotate_rty_t ) value
+let pr_call : type a. a call -> string = fun call ->
let return what x = str_of_call call ^ " " ^ print what x in
match call with
| Add x -> return add_sty_t x
@@ -735,7 +747,7 @@ let document to_string_fmt =
(to_string_fmt (of_value (fun _ -> PCData "b") (Good ())));
Printf.printf "or:\n\n%s\n\nwhere the attributes loc_s and loc_c are optional.\n"
(to_string_fmt (of_value (fun _ -> PCData "b")
- (Fail (Stateid.initial,Some (15,34),"error message"))));
+ (Fail (Stateid.initial,Some (15,34),Richpp.richpp_of_string "error message"))));
document_type_encoding to_string_fmt
(* vim: set foldmethod=marker: *)
diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli
index 2c8ebc655..7806550d1 100644
--- a/ide/xmlprotocol.mli
+++ b/ide/xmlprotocol.mli
@@ -13,7 +13,7 @@ open Xml_datatype
type 'a call
-type unknown
+type unknown_call = Unknown : 'a call -> unknown_call
val add : add_sty -> add_rty call
val edit_at : edit_at_sty -> edit_at_rty call
@@ -43,7 +43,7 @@ val protocol_version : string
(** * XML data marshalling *)
val of_call : 'a call -> xml
-val to_call : xml -> unknown call
+val to_call : xml -> unknown_call
val of_answer : 'a call -> 'a value -> xml
val to_answer : 'a call -> xml -> 'a value
diff --git a/intf/extend.mli b/intf/extend.mli
index ad9706f3a..975f194b0 100644
--- a/intf/extend.mli
+++ b/intf/extend.mli
@@ -50,3 +50,37 @@ type constr_prod_entry_key =
type simple_constr_prod_entry_key =
(production_level,unit) constr_entry_key_gen
+
+(** {5 Type-safe grammar extension} *)
+
+type ('self, 'a) symbol =
+| Atoken : Tok.t -> ('self, string) symbol
+| Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol
+| Alist1sep : ('self, 'a) symbol * string -> ('self, 'a list) symbol
+| Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol
+| Alist0sep : ('self, 'a) symbol * string -> ('self, 'a list) symbol
+| Aopt : ('self, 'a) symbol -> ('self, 'a option) symbol
+| Amodifiers : ('self, 'a) symbol -> ('self, 'a list) symbol
+| Aself : ('self, 'self) symbol
+| Anext : ('self, 'self) symbol
+| Aentry : 'a Entry.t -> ('self, 'a) symbol
+| Aentryl : 'a Entry.t * int -> ('self, 'a) symbol
+
+type ('self, _, 'r) rule =
+| Stop : ('self, 'r, 'r) rule
+| Next : ('self, 'a, 'r) rule * ('self, 'b) symbol -> ('self, 'b -> 'a, 'r) rule
+
+type 'a production_rule =
+| Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule
+
+type 'a single_extend_statment =
+ string option *
+ (** Level *)
+ gram_assoc option *
+ (** Associativity *)
+ 'a production_rule list
+ (** Symbol list with the interpretation function *)
+
+type 'a extend_statment =
+ gram_position option *
+ 'a single_extend_statment list
diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli
index eb4e5ae7d..124d4c0fe 100644
--- a/intf/tacexpr.mli
+++ b/intf/tacexpr.mli
@@ -104,6 +104,11 @@ type ml_tactic_name = {
mltac_tactic : string;
}
+type ml_tactic_entry = {
+ mltac_name : ml_tactic_name;
+ mltac_index : int;
+}
+
(** Composite types *)
(** In globalize tactics, we need to keep the initial [constr_expr] to recompute
@@ -117,11 +122,12 @@ type open_glob_constr = unit * glob_constr_and_expr
type binding_bound_vars = Id.Set.t
type glob_constr_pattern_and_expr = glob_constr_and_expr * constr_pattern
-type delayed_open_constr_with_bindings =
- Environ.env -> Evd.evar_map -> Evd.evar_map * Term.constr with_bindings
+type 'a delayed_open =
+ { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma }
+
+type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open
-type delayed_open_constr =
- Environ.env -> Evd.evar_map -> Evd.evar_map * Term.constr
+type delayed_open_constr = Term.constr delayed_open
type intro_pattern = delayed_open_constr intro_pattern_expr located
type intro_patterns = delayed_open_constr intro_pattern_expr located list
@@ -291,7 +297,7 @@ and 'a gen_tactic_expr =
| TacFun of 'a gen_tactic_fun_ast
| TacArg of 'a gen_tactic_arg located
(* For ML extensions *)
- | TacML of Loc.t * ml_tactic_name * 'l generic_argument list
+ | TacML of Loc.t * ml_tactic_entry * 'l generic_argument list
(* For syntax extensions *)
| TacAlias of Loc.t * KerName.t * (Id.t * 'l generic_argument) list
@@ -387,8 +393,8 @@ type raw_tactic_arg =
type t_trm = Term.constr
type t_utrm = Glob_term.closed_glob_constr
-type t_pat = glob_constr_pattern_and_expr
-type t_cst = evaluable_global_reference and_short_name
+type t_pat = constr_pattern
+type t_cst = evaluable_global_reference
type t_ref = ltac_constant located
type t_nam = Id.t
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index ef0c9af4f..5ba93eda0 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -29,11 +29,19 @@ let patch_char4 buff pos c1 c2 c3 c4 =
String.unsafe_set buff (pos + 2) c3;
String.unsafe_set buff (pos + 3) c4
-let patch_int buff pos n =
+let patch buff (pos, n) =
patch_char4 buff pos
(Char.unsafe_chr n) (Char.unsafe_chr (n asr 8)) (Char.unsafe_chr (n asr 16))
(Char.unsafe_chr (n asr 24))
+let patch_int buff patches =
+ (* copy code *before* patching because of nested evaluations:
+ the code we are patching might be called (and thus "concurrently" patched)
+ and results in wrong results. Side-effects... *)
+ let buff = String.copy buff in
+ let () = List.iter (fun p -> patch buff p) patches in
+ buff
+
(* Buffering of bytecode *)
let out_buffer = ref(String.create 1024)
@@ -366,6 +374,8 @@ let to_memory (init_code, fun_code, fv) =
emit fun_code;
let code = String.create !out_position in
String.unsafe_blit !out_buffer 0 code 0 !out_position;
+ (** Later uses of this string are all purely functional *)
+ let code = CString.hcons code in
let reloc = List.rev !reloc_info in
Array.iter (fun lbl ->
(match lbl with
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
index 10f3a6087..c80edd596 100644
--- a/kernel/cemitcodes.mli
+++ b/kernel/cemitcodes.mli
@@ -13,11 +13,9 @@ val subst_patch : Mod_subst.substitution -> patch -> patch
type emitcodes
-val copy : emitcodes -> emitcodes
-
val length : emitcodes -> int
-val patch_int : emitcodes -> (*pos*)int -> int -> unit
+val patch_int : emitcodes -> ((*pos*)int * int) list -> emitcodes
type to_patch = emitcodes * (patch list) * fv
diff --git a/kernel/closure.ml b/kernel/closure.ml
index ea9b2755f..bc414d971 100644
--- a/kernel/closure.ml
+++ b/kernel/closure.ml
@@ -346,7 +346,6 @@ and fterm =
| FProj of projection * fconstr
| FFix of fixpoint * fconstr subs
| FCoFix of cofixpoint * fconstr subs
- | FCase of case_info * fconstr * fconstr * fconstr array
| FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *)
| FLambda of int * (Name.t * constr) list * constr * fconstr subs
| FProd of Name.t * fconstr * fconstr
@@ -376,7 +375,6 @@ let update v1 no t =
type stack_member =
| Zapp of fconstr array
- | Zcase of case_info * fconstr * fconstr array
| ZcaseT of case_info * constr * constr array * fconstr subs
| Zproj of int * int * constant
| Zfix of fconstr * stack
@@ -569,10 +567,6 @@ let rec to_constr constr_fun lfts v =
| FFlex (ConstKey op) -> mkConstU op
| FInd op -> mkIndU op
| FConstruct op -> mkConstructU op
- | FCase (ci,p,c,ve) ->
- mkCase (ci, constr_fun lfts p,
- constr_fun lfts c,
- CArray.Fun1.map constr_fun lfts ve)
| FCaseT (ci,p,c,ve,env) ->
mkCase (ci, constr_fun lfts (mk_clos env p),
constr_fun lfts c,
@@ -646,9 +640,6 @@ let rec zip m stk =
match stk with
| [] -> m
| Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s
- | Zcase(ci,p,br)::s ->
- let t = FCase(ci, p, m, br) in
- zip {norm=neutr m.norm; term=t} s
| ZcaseT(ci,p,br,e)::s ->
let t = FCaseT(ci, p, m, br, e) in
zip {norm=neutr m.norm; term=t} s
@@ -731,7 +722,7 @@ let rec get_args n tys f e stk =
(* Eta expansion: add a reference to implicit surrounding lambda at end of stack *)
let rec eta_expand_stack = function
- | (Zapp _ | Zfix _ | Zcase _ | ZcaseT _ | Zproj _
+ | (Zapp _ | Zfix _ | ZcaseT _ | Zproj _
| Zshift _ | Zupdate _ as e) :: s ->
e :: eta_expand_stack s
| [] ->
@@ -842,7 +833,6 @@ let rec knh info m stk =
| FCLOS(t,e) -> knht info e t (zupdate m stk)
| FLOCKED -> assert false
| FApp(a,b) -> knh info a (append_stack b (zupdate m stk))
- | FCase(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk)
| FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate m stk)
| FFix(((ri,n),(_,_,_)),_) ->
(match get_nth_arg m ri.(n) stk with
@@ -904,10 +894,6 @@ let rec knr info m stk =
| None -> (set_norm m; (m,stk)))
| FConstruct((ind,c),u) when red_set info.i_flags fIOTA ->
(match strip_update_shift_app m stk with
- (depth, args, Zcase(ci,_,br)::s) ->
- assert (ci.ci_npar>=0);
- let rargs = drop_parameters depth ci.ci_npar args in
- kni info br.(c-1) (rargs@s)
| (depth, args, ZcaseT(ci,_,br,e)::s) ->
assert (ci.ci_npar>=0);
let rargs = drop_parameters depth ci.ci_npar args in
@@ -924,7 +910,7 @@ let rec knr info m stk =
| (_,args,s) -> (m,args@s))
| FCoFix _ when red_set info.i_flags fIOTA ->
(match strip_update_shift_app m stk with
- (_, args, (((Zcase _|ZcaseT _|Zproj _)::_) as stk')) ->
+ (_, args, (((ZcaseT _|Zproj _)::_) as stk')) ->
let (fxe,fxbd) = contract_fix_vect m.term in
knit info fxe fxbd (args@stk')
| (_,args,s) -> (m,args@s))
@@ -953,9 +939,6 @@ let rec zip_term zfun m stk =
| [] -> m
| Zapp args :: s ->
zip_term zfun (mkApp(m, Array.map zfun args)) s
- | Zcase(ci,p,br)::s ->
- let t = mkCase(ci, zfun p, m, Array.map zfun br) in
- zip_term zfun t s
| ZcaseT(ci,p,br,e)::s ->
let t = mkCase(ci, zfun (mk_clos e p), m,
Array.map (fun b -> zfun (mk_clos e b)) br) in
diff --git a/kernel/closure.mli b/kernel/closure.mli
index a3b0e0f30..c6f212aa5 100644
--- a/kernel/closure.mli
+++ b/kernel/closure.mli
@@ -119,7 +119,6 @@ type fterm =
| FProj of projection * fconstr
| FFix of fixpoint * fconstr subs
| FCoFix of cofixpoint * fconstr subs
- | FCase of case_info * fconstr * fconstr * fconstr array
| FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *)
| FLambda of int * (Name.t * constr) list * constr * fconstr subs
| FProd of Name.t * fconstr * fconstr
@@ -136,7 +135,6 @@ type fterm =
type stack_member =
| Zapp of fconstr array
- | Zcase of case_info * fconstr * fconstr array
| ZcaseT of case_info * constr * constr array * fconstr subs
| Zproj of int * int * constant
| Zfix of fconstr * stack
diff --git a/kernel/constr.ml b/kernel/constr.ml
index e2b1d3fd9..753d18845 100644
--- a/kernel/constr.ml
+++ b/kernel/constr.ml
@@ -545,8 +545,8 @@ let equal m n = eq_constr m n (* to avoid tracing a recursive fun *)
let eq_constr_univs univs m n =
if m == n then true
else
- let eq_universes _ = Univ.Instance.check_eq univs in
- let eq_sorts s1 s2 = s1 == s2 || Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
+ let eq_universes _ = UGraph.check_eq_instances univs in
+ let eq_sorts s1 s2 = s1 == s2 || UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
let rec eq_constr' m n =
m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n
in compare_head_gen eq_universes eq_sorts eq_constr' m n
@@ -554,11 +554,11 @@ let eq_constr_univs univs m n =
let leq_constr_univs univs m n =
if m == n then true
else
- let eq_universes _ = Univ.Instance.check_eq univs in
+ let eq_universes _ = UGraph.check_eq_instances univs in
let eq_sorts s1 s2 = s1 == s2 ||
- Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
+ UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
let leq_sorts s1 s2 = s1 == s2 ||
- Univ.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
+ UGraph.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
let rec eq_constr' m n =
m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n
in
@@ -571,12 +571,12 @@ let eq_constr_univs_infer univs m n =
if m == n then true, Constraint.empty
else
let cstrs = ref Constraint.empty in
- let eq_universes strict = Univ.Instance.check_eq univs in
+ let eq_universes strict = UGraph.check_eq_instances univs in
let eq_sorts s1 s2 =
if Sorts.equal s1 s2 then true
else
let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
- if Univ.check_eq univs u1 u2 then true
+ if UGraph.check_eq univs u1 u2 then true
else
(cstrs := Univ.enforce_eq u1 u2 !cstrs;
true)
@@ -591,12 +591,12 @@ let leq_constr_univs_infer univs m n =
if m == n then true, Constraint.empty
else
let cstrs = ref Constraint.empty in
- let eq_universes strict l l' = Univ.Instance.check_eq univs l l' in
+ let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in
let eq_sorts s1 s2 =
if Sorts.equal s1 s2 then true
else
let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
- if Univ.check_eq univs u1 u2 then true
+ if UGraph.check_eq univs u1 u2 then true
else (cstrs := Univ.enforce_eq u1 u2 !cstrs;
true)
in
@@ -604,7 +604,7 @@ let leq_constr_univs_infer univs m n =
if Sorts.equal s1 s2 then true
else
let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
- if Univ.check_leq univs u1 u2 then true
+ if UGraph.check_leq univs u1 u2 then true
else
(cstrs := Univ.enforce_leq u1 u2 !cstrs;
true)
diff --git a/kernel/constr.mli b/kernel/constr.mli
index e6a3e71f8..5a370d31d 100644
--- a/kernel/constr.mli
+++ b/kernel/constr.mli
@@ -205,19 +205,19 @@ val equal : constr -> constr -> bool
(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts,
application grouping and the universe equalities in [u]. *)
-val eq_constr_univs : constr Univ.check_function
+val eq_constr_univs : constr UGraph.check_function
(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo
alpha, casts, application grouping and the universe inequalities in [u]. *)
-val leq_constr_univs : constr Univ.check_function
+val leq_constr_univs : constr UGraph.check_function
(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts,
application grouping and the universe equalities in [u]. *)
-val eq_constr_univs_infer : Univ.universes -> constr -> constr -> bool Univ.constrained
+val eq_constr_univs_infer : UGraph.t -> constr -> constr -> bool Univ.constrained
(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo
alpha, casts, application grouping and the universe inequalities in [u]. *)
-val leq_constr_univs_infer : Univ.universes -> constr -> constr -> bool Univ.constrained
+val leq_constr_univs_infer : UGraph.t -> constr -> constr -> bool Univ.constrained
(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts,
application grouping and ignoring universe instances. *)
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index 28f0fa4f2..aa9ef66fe 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -206,19 +206,13 @@ and slot_for_fv env fv =
assert false
and eval_to_patch env (buff,pl,fv) =
- (* copy code *before* patching because of nested evaluations:
- the code we are patching might be called (and thus "concurrently" patched)
- and results in wrong results. Side-effects... *)
- let buff = Cemitcodes.copy buff in
let patch = function
- | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a)
- | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc)
- | Reloc_getglobal kn, pos ->
-(* Pp.msgnl (str"patching global: "++str(debug_string_of_con kn));*)
- patch_int buff pos (slot_for_getglobal env kn);
-(* Pp.msgnl (str"patch done: "++str(debug_string_of_con kn))*)
+ | Reloc_annot a, pos -> (pos, slot_for_annot a)
+ | Reloc_const sc, pos -> (pos, slot_for_str_cst sc)
+ | Reloc_getglobal kn, pos -> (pos, slot_for_getglobal env kn)
in
- List.iter patch pl;
+ let patches = List.map_left patch pl in
+ let buff = patch_int buff patches in
let vm_env = Array.map (slot_for_fv env) fv in
let tc = tcode_of_code buff (length buff) in
eval_tcode tc vm_env
diff --git a/kernel/environ.ml b/kernel/environ.ml
index 429aba4f7..09fe64d77 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -188,10 +188,10 @@ let map_universes f env =
let add_constraints c env =
if Univ.Constraint.is_empty c then env
- else map_universes (Univ.merge_constraints c) env
+ else map_universes (UGraph.merge_constraints c) env
let check_constraints c env =
- Univ.check_constraints c env.env_stratification.env_universes
+ UGraph.check_constraints c env.env_stratification.env_universes
let push_constraints_to_env (_,univs) env =
add_constraints univs env
@@ -199,19 +199,19 @@ let push_constraints_to_env (_,univs) env =
let add_universes strict ctx g =
let g = Array.fold_left
(* Be lenient, module typing reintroduces universes and constraints due to includes *)
- (fun g v -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g)
+ (fun g v -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g)
g (Univ.Instance.to_array (Univ.UContext.instance ctx))
in
- Univ.merge_constraints (Univ.UContext.constraints ctx) g
+ UGraph.merge_constraints (Univ.UContext.constraints ctx) g
let push_context ?(strict=false) ctx env =
map_universes (add_universes strict ctx) env
let add_universes_set strict ctx g =
let g = Univ.LSet.fold
- (fun v g -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g)
+ (fun v g -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g)
(Univ.ContextSet.levels ctx) g
- in Univ.merge_constraints (Univ.ContextSet.constraints ctx) g
+ in UGraph.merge_constraints (Univ.ContextSet.constraints ctx) g
let push_context_set ?(strict=false) ctx env =
map_universes (add_universes_set strict ctx) env
@@ -602,7 +602,10 @@ let dispatch =
Array.init 31 (fun n -> mkConstruct
(digit_ind, nth_digit_plus_one i (30-n)))
in
- mkApp(mkConstruct(ind, 1), array_of_int tag)
+ (* We check that no bit above 31 is set to one. This assertion used to
+ fail in the VM, and led to conversion tests failing at Qed. *)
+ assert (Int.equal (tag lsr 31) 0);
+ mkApp(mkConstruct(ind, 1), array_of_int tag)
in
(* subfunction which dispatches the compiling information of an
diff --git a/kernel/environ.mli b/kernel/environ.mli
index dfe6cc85b..2eab32e72 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -41,7 +41,7 @@ val eq_named_context_val : named_context_val -> named_context_val -> bool
val empty_env : env
-val universes : env -> Univ.universes
+val universes : env -> UGraph.t
val rel_context : env -> rel_context
val named_context : env -> named_context
val named_context_val : env -> named_context_val
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 8b03df64c..23320daef 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -30,8 +30,13 @@ let indices_matter = ref false
let enforce_indices_matter () = indices_matter := true
let is_indices_matter () = !indices_matter
-(* Same as noccur_between but may perform reductions.
- Could be refined more... *)
+(* [weaker_noccur_between env n nvars t] (defined above), checks that
+ no de Bruijn indices between [n] and [n+nvars] occur in [t]. If
+ some such occurrences are found, then reduction is performed
+ (lazily for efficiency purposes) in order to determine whether
+ these occurrences are occurrences in the normal form. If the
+ occurrences are eliminated a witness reduct [Some t'] of [t] is
+ returned otherwise [None] is returned. *)
let weaker_noccur_between env x nvars t =
if noccur_between x nvars t then Some t
else
@@ -285,7 +290,7 @@ let typecheck_inductive env mie =
let full_polymorphic () =
let defu = Term.univ_of_sort def_level in
let is_natural =
- type_in_type env || (check_leq (universes env') infu defu)
+ type_in_type env || (UGraph.check_leq (universes env') infu defu)
in
let _ =
(** Impredicative sort, always allow *)
@@ -311,7 +316,7 @@ let typecheck_inductive env mie =
(* conclusions of the parameters *)
(* We enforce [u >= lev] in case [lev] has a strict upper *)
(* constraints over [u] *)
- let b = type_in_type env || check_leq (universes env') infu u in
+ let b = type_in_type env || UGraph.check_leq (universes env') infu u in
if not b then
anomaly ~label:"check_inductive"
(Pp.str"Incorrect universe " ++
@@ -450,17 +455,30 @@ let rec ienv_decompose_prod (env,_,_,_ as ienv) n c =
let array_min nmr a = if Int.equal nmr 0 then 0 else
Array.fold_left (fun k (nmri,_) -> min k nmri) nmr a
-(* The recursive function that checks positivity and builds the list
- of recursive arguments *)
+(** [check_positivity_one ienv hyps (mind,i) nargs lcnames indlc]
+ checks the positivity of the [i]-th member of the mutually
+ inductive definition [mind]. It returns an [Rtree.t] which
+ represents the position of the recursive calls of inductive in [i]
+ for use by the guard condition (terms at these positions are
+ considered sub-terms) as well as the number of of non-uniform
+ arguments (used to generate induction schemes, so a priori less
+ relevant to the kernel). *)
let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc =
let lparams = rel_context_length hyps in
let nmr = rel_context_nhyps hyps in
- (* Checking the (strict) positivity of a constructor argument type [c] *)
+ (** Positivity of one argument [c] of a constructor (i.e. the
+ constructor [cn] has a type of the shape [… -> c … -> P], where,
+ more generally, the arrows may be dependent). *)
let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c =
let x,largs = decompose_app (whd_betadeltaiota env c) in
match kind_of_term x with
| Prod (na,b,d) ->
let () = assert (List.is_empty largs) in
+ (** If one of the inductives of the mutually inductive
+ block occurs in the left-hand side of a product, then
+ such an occurrence is a non-strictly-positive
+ recursive call. Occurrences in the right-hand side of
+ the product must be strictly positive.*)
(match weaker_noccur_between env n ntypes b with
None -> failwith_non_pos_list n ntypes [b]
| Some b ->
@@ -473,21 +491,35 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
Mrec _ -> compute_rec_par ienv hyps nmr largs
| _ -> nmr)
in
+ (** The case where one of the inductives of the mutually
+ inductive block occurs as an argument of another is not
+ known to be safe. So Coq rejects it. *)
if not (List.for_all (noccur_between n ntypes) largs)
then failwith_non_pos_list n ntypes largs
else (nmr1,rarg)
with Failure _ | Invalid_argument _ -> (nmr,mk_norec))
| Ind ind_kn ->
- (* If the inductive type being defined appears in a
- parameter, then we have a nested indtype *)
+ (** If one of the inductives of the mutually inductive
+ block being defined appears in a parameter, then we
+ have a nested inductive type. The positivity is then
+ discharged to the [check_positive_nested] function. *)
if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec)
else check_positive_nested ienv nmr (ind_kn, largs)
| err ->
+ (** If an inductive of the mutually inductive block
+ appears in any other way, then the positivy check gives
+ up. *)
if noccur_between n ntypes x &&
List.for_all (noccur_between n ntypes) largs
then (nmr,mk_norec)
else failwith_non_pos_list n ntypes (x::largs)
+ (** [check_positive_nested] handles the case of nested inductive
+ calls, that is, when an inductive types from the mutually
+ inductive block is called as an argument of an inductive types
+ (for the moment, this inductive type must be a previously
+ defined types, not one of the types of the mutually inductive
+ block being defined). *)
(* accesses to the environment are not factorised, but is it worth? *)
and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr ((mi,u), largs) =
let (mib,mip) = lookup_mind_specif env mi in
@@ -496,12 +528,13 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
let (lpar,auxlargs) =
try List.chop auxnpar largs
with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in
- (* If the inductive appears in the args (non params) then the
- definition is not positive. *)
+ (** Inductives of the inductive block being defined are only
+ allowed to appear nested in the parameters of another inductive
+ type. Not in the proper indices. *)
if not (List.for_all (noccur_between n ntypes) auxlargs) then
failwith_non_pos_list n ntypes auxlargs;
- (* We do not deal with imbricated mutual inductive types *)
+ (* Nested mutual inductive types are not supported *)
let auxntyp = mib.mind_ntypes in
if not (Int.equal auxntyp 1) then raise (IllFormedInd (LocalNonPos n));
(* The nested inductive type with parameters removed *)
@@ -512,8 +545,11 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
(* Parameters expressed in env' *)
let lpar' = List.map (lift auxntyp) lpar in
let irecargs_nmr =
- (* fails if the inductive type occurs non positively *)
- (* with recursive parameters substituted *)
+ (** Checks that the "nesting" inductive type is covariant in
+ the relevant parameters. In other words, that the
+ (nested) parameters which are instantiated with
+ inductives of the mutually inductive block occur
+ positively in the types of the nested constructors. *)
Array.map
(function c ->
let c' = hnf_prod_applist env' c lpar' in
@@ -527,10 +563,14 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
in
(nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0))
- (* check the inductive types occur positively in the products of C, if
- check_head=true, also check the head corresponds to a constructor of
- the ith type *)
-
+ (** [check_constructors ienv check_head nmr c] checks the positivity
+ condition in the type [c] of a constructor (i.e. that recursive
+ calls to the inductives of the mutually inductive definition
+ appear strictly positively in each of the arguments of the
+ constructor, see also [check_pos]). If [check_head] is [true],
+ then the type of the fully applied constructor (the "head" of
+ the type [c]) is checked to be the right (properly applied)
+ inductive type. *)
and check_constructors ienv check_head nmr c =
let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c =
let x,largs = decompose_app (whd_betadeltaiota env c) in
@@ -570,6 +610,8 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
and nmr' = array_min nmr irecargs_nmr
in (nmr', mk_paths (Mrec ind) irecargs)
+(** [check_positivity kn env_ar params] checks that the mutually
+ inductive block [inds] is strictly positive. *)
let check_positivity kn env_ar params inds =
let ntypes = Array.length inds in
let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in
diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib
index 29fe887d7..f7220c94a 100644
--- a/kernel/kernel.mllib
+++ b/kernel/kernel.mllib
@@ -1,6 +1,7 @@
Names
Uint31
Univ
+UGraph
Esubst
Sorts
Evar
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index bd7ee7b33..3c58e788c 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -104,7 +104,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv =
let csti = Univ.enforce_eq_instances cus newus cst in
let csta = Univ.Constraint.union csti ccst in
let env' = Environ.push_context ~strict:false (Univ.UContext.make (inst, csta)) env in
- let () = if not (Univ.check_constraints cst (Environ.universes env')) then
+ let () = if not (UGraph.check_constraints cst (Environ.universes env')) then
error_incorrect_with_constraint lab
in
let cst = match cb.const_body with
diff --git a/kernel/names.ml b/kernel/names.ml
index ae2b3b638..9e4e8cd61 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -204,7 +204,7 @@ struct
DirPath.to_string p ^ "." ^ s
let debug_to_string (i, s, p) =
- "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
+ "<"^DirPath.to_string p ^"#" ^ s ^"#"^ string_of_int i^">"
let compare (x : t) (y : t) =
if x == y then 0
@@ -282,6 +282,11 @@ module ModPath = struct
| MPbound uid -> MBId.to_string uid
| MPdot (mp,l) -> to_string mp ^ "." ^ Label.to_string l
+ let rec debug_to_string = function
+ | MPfile sl -> DirPath.to_string sl
+ | MPbound uid -> MBId.debug_to_string uid
+ | MPdot (mp,l) -> debug_to_string mp ^ "." ^ Label.to_string l
+
(** we compare labels first if both are MPdots *)
let rec compare mp1 mp2 =
if mp1 == mp2 then 0
@@ -375,12 +380,16 @@ module KerName = struct
let modpath kn = kn.modpath
let label kn = kn.knlabel
- let to_string kn =
+ let to_string_gen mp_to_string kn =
let dp =
if DirPath.is_empty kn.dirpath then "."
else "#" ^ DirPath.to_string kn.dirpath ^ "#"
in
- ModPath.to_string kn.modpath ^ dp ^ Label.to_string kn.knlabel
+ mp_to_string kn.modpath ^ dp ^ Label.to_string kn.knlabel
+
+ let to_string kn = to_string_gen ModPath.to_string kn
+
+ let debug_to_string kn = to_string_gen ModPath.debug_to_string kn
let print kn = str (to_string kn)
@@ -500,9 +509,9 @@ module KerPair = struct
let print kp = str (to_string kp)
let debug_to_string = function
- | Same kn -> "(" ^ KerName.to_string kn ^ ")"
+ | Same kn -> "(" ^ KerName.debug_to_string kn ^ ")"
| Dual (knu,knc) ->
- "(" ^ KerName.to_string knu ^ "," ^ KerName.to_string knc ^ ")"
+ "(" ^ KerName.debug_to_string knu ^ "," ^ KerName.debug_to_string knc ^ ")"
let debug_print kp = str (debug_to_string kp)
diff --git a/kernel/names.mli b/kernel/names.mli
index 7cc444375..77139f1c3 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -217,6 +217,9 @@ sig
val to_string : t -> string
+ val debug_to_string : t -> string
+ (** Same as [to_string], but outputs information related to debug. *)
+
val initial : t
(** Name of the toplevel structure ([= MPfile initial_dir]) *)
@@ -244,6 +247,10 @@ sig
(** Display *)
val to_string : t -> string
+
+ val debug_to_string : t -> string
+ (** Same as [to_string], but outputs information related to debug. *)
+
val print : t -> Pp.std_ppcmds
(** Comparisons *)
diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml
index b2142b43c..331598d85 100644
--- a/kernel/nativelib.ml
+++ b/kernel/nativelib.ml
@@ -30,10 +30,6 @@ let output_dir = ".coq-native"
(* Extension of genereted ml files, stored for debugging purposes *)
let source_ext = ".native"
-(* Global settings and utilies for interface with OCaml *)
-let compiler_name =
- if Dynlink.is_native then ocamlopt () else ocamlc ()
-
let ( / ) = Filename.concat
(* We have to delay evaluation of include_dirs because coqlib cannot be guessed
@@ -70,14 +66,15 @@ let call_compiler ml_filename =
remove link_filename;
remove (f ^ ".cmi");
let args =
- (if Dynlink.is_native then "-shared" else "-c")
+ (if Dynlink.is_native then "opt" else "ocamlc")
+ ::(if Dynlink.is_native then "-shared" else "-c")
::"-o"::link_filename
::"-rectypes"
::"-w"::"a"
::include_dirs
@ ["-impl"; ml_filename] in
- if !Flags.debug then Pp.msg_debug (Pp.str (compiler_name ^ " " ^ (String.concat " " args)));
- try CUnix.sys_command compiler_name args = Unix.WEXITED 0, link_filename
+ if !Flags.debug then Pp.msg_debug (Pp.str (ocamlfind () ^ " " ^ (String.concat " " args)));
+ try CUnix.sys_command (ocamlfind ()) args = Unix.WEXITED 0, link_filename
with Unix.Unix_error (e,_,_) ->
Pp.(msg_warning (str (Unix.error_message e)));
false, link_filename
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index 5f3f559a2..615b9d49b 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -45,7 +45,7 @@ type globals = {
env_modtypes : module_type_body MPmap.t}
type stratification = {
- env_universes : universes;
+ env_universes : UGraph.t;
env_engagement : engagement
}
@@ -93,7 +93,7 @@ let empty_env = {
env_rel_val = [];
env_nb_rel = 0;
env_stratification = {
- env_universes = initial_universes;
+ env_universes = UGraph.initial_universes;
env_engagement = (PredicativeSet,StratifiedType) };
env_conv_oracle = Conv_oracle.empty;
retroknowledge = Retroknowledge.initial_retroknowledge;
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index 0ce0bed23..b499ac0c5 100644
--- a/kernel/pre_env.mli
+++ b/kernel/pre_env.mli
@@ -32,7 +32,7 @@ type globals = {
env_modtypes : module_type_body MPmap.t}
type stratification = {
- env_universes : universes;
+ env_universes : UGraph.t;
env_engagement : engagement
}
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 892557ac6..c5595bbc3 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -54,8 +54,7 @@ let compare_stack_shape stk1 stk2 =
| (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2
| (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) ->
Int.equal bal 0 && compare_rec 0 s1 s2
- | ((Zcase(c1,_,_)|ZcaseT(c1,_,_,_))::s1,
- (Zcase(c2,_,_)|ZcaseT(c2,_,_,_))::s2) ->
+ | (ZcaseT(c1,_,_,_)::s1, ZcaseT(c2,_,_,_)::s2) ->
Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2
| (Zfix(_,a1)::s1, Zfix(_,a2)::s2) ->
Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2
@@ -89,9 +88,8 @@ let pure_stack lfts stk =
let (lfx,pa) = pure_rec l a in
(l, Zlfix((lfx,fx),pa)::pstk)
| (ZcaseT(ci,p,br,e),(l,pstk)) ->
- (l,Zlcase(ci,l,mk_clos e p,Array.map (mk_clos e) br)::pstk)
- | (Zcase(ci,p,br),(l,pstk)) ->
- (l,Zlcase(ci,l,p,br)::pstk)) in
+ (l,Zlcase(ci,l,mk_clos e p,Array.map (mk_clos e) br)::pstk))
+ in
snd (pure_rec lfts stk)
(****************************************************************************)
@@ -147,7 +145,7 @@ let betazeta_appvect n c v =
(* Conversion utility functions *)
type 'a conversion_function = env -> 'a -> 'a -> unit
type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function
-type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit
+type 'a universe_conversion_function = env -> UGraph.t -> 'a -> 'a -> unit
type 'a trans_universe_conversion_function =
Names.transparent_state -> 'a universe_conversion_function
@@ -180,7 +178,7 @@ type 'a universe_state = 'a * 'a universe_compare
type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b
-type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints
+type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints
let sort_cmp_universes env pb s0 s1 (u, check) =
(check.compare env pb s0 s1 u, check)
@@ -235,7 +233,6 @@ let rec no_arg_available = function
| Zshift _ :: stk -> no_arg_available stk
| Zapp v :: stk -> Int.equal (Array.length v) 0 && no_arg_available stk
| Zproj _ :: _ -> true
- | Zcase _ :: _ -> true
| ZcaseT _ :: _ -> true
| Zfix _ :: _ -> true
@@ -248,7 +245,6 @@ let rec no_nth_arg_available n = function
if n >= k then no_nth_arg_available (n-k) stk
else false
| Zproj _ :: _ -> true
- | Zcase _ :: _ -> true
| ZcaseT _ :: _ -> true
| Zfix _ :: _ -> true
@@ -258,13 +254,12 @@ let rec no_case_available = function
| Zshift _ :: stk -> no_case_available stk
| Zapp _ :: stk -> no_case_available stk
| Zproj (_,_,p) :: _ -> false
- | Zcase _ :: _ -> false
| ZcaseT _ :: _ -> false
| Zfix _ :: _ -> true
let in_whnf (t,stk) =
match fterm_of t with
- | (FLetIn _ | FCase _ | FCaseT _ | FApp _
+ | (FLetIn _ | FCaseT _ | FApp _
| FCLOS _ | FLIFT _ | FCast _) -> false
| FLambda _ -> no_arg_available stk
| FConstruct _ -> no_case_available stk
@@ -530,8 +525,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
else raise NotConvertible
(* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *)
- | ( (FLetIn _, _) | (FCase _,_) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
- | (_, FLetIn _) | (_,FCase _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _)
+ | ( (FLetIn _, _) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
+ | (_, FLetIn _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _)
| (FLOCKED,_) | (_,FLOCKED) ) -> assert false
(* In all other cases, terms are not convertible *)
@@ -563,10 +558,10 @@ let clos_fconv trans cv_pb l2r evars env univs t1 t2 =
let check_eq univs u u' =
- if not (check_eq univs u u') then raise NotConvertible
+ if not (UGraph.check_eq univs u u') then raise NotConvertible
let check_leq univs u u' =
- if not (check_leq univs u u') then raise NotConvertible
+ if not (UGraph.check_leq univs u u') then raise NotConvertible
let check_sort_cmp_universes env pb s0 s1 univs =
match (s0,s1) with
@@ -593,7 +588,7 @@ let checked_sort_cmp_universes env pb s0 s1 univs =
check_sort_cmp_universes env pb s0 s1 univs; univs
let check_convert_instances ~flex u u' univs =
- if Univ.Instance.check_eq univs u u' then univs
+ if UGraph.check_eq_instances univs u u' then univs
else raise NotConvertible
let checked_universes =
@@ -601,12 +596,12 @@ let checked_universes =
compare_instances = check_convert_instances }
let infer_eq (univs, cstrs as cuniv) u u' =
- if Univ.check_eq univs u u' then cuniv
+ if UGraph.check_eq univs u u' then cuniv
else
univs, (Univ.enforce_eq u u' cstrs)
let infer_leq (univs, cstrs as cuniv) u u' =
- if Univ.check_leq univs u u' then cuniv
+ if UGraph.check_leq univs u u' then cuniv
else
let cstrs' = Univ.enforce_leq u u' cstrs in
univs, cstrs'
@@ -635,7 +630,7 @@ let infer_cmp_universes env pb s0 s1 univs =
let infer_convert_instances ~flex u u' (univs,cstrs) =
(univs, Univ.enforce_eq_instances u u' cstrs)
-let inferred_universes : (Univ.universes * Univ.Constraint.t) universe_compare =
+let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare =
{ compare = infer_cmp_universes;
compare_instances = infer_convert_instances }
@@ -721,9 +716,8 @@ let vm_conv cv_pb env t1 t2 =
try
!vm_conv cv_pb env t1 t2
with Not_found | Invalid_argument _ ->
- (Pp.msg_warning
- (Pp.str "Bytecode compilation failed, falling back to default conversion");
- fconv cv_pb false (fun _->None) env t1 t2)
+ Pp.msg_warning (Pp.str "Bytecode compilation failed, falling back to standard conversion");
+ fconv cv_pb false (fun _->None) env t1 t2
let default_conv cv_pb ?(l2r=false) env t1 t2 =
fconv cv_pb false (fun _ -> None) env t1 t2
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index 0df26d627..ef764f34f 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -28,7 +28,7 @@ exception NotConvertibleVect of int
type 'a conversion_function = env -> 'a -> 'a -> unit
type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function
-type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit
+type 'a universe_conversion_function = env -> UGraph.t -> 'a -> 'a -> unit
type 'a trans_universe_conversion_function =
Names.transparent_state -> 'a universe_conversion_function
@@ -45,7 +45,7 @@ type 'a universe_state = 'a * 'a universe_compare
type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b
-type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints
+type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints
val sort_cmp_universes : env -> conv_pb -> sorts -> sorts ->
'a * 'a universe_compare -> 'a * 'a universe_compare
@@ -55,8 +55,8 @@ constructors. *)
val convert_instances : flex:bool -> Univ.Instance.t -> Univ.Instance.t ->
'a * 'a universe_compare -> 'a * 'a universe_compare
-val checked_universes : Univ.universes universe_compare
-val inferred_universes : (Univ.universes * Univ.Constraint.t) universe_compare
+val checked_universes : UGraph.t universe_compare
+val inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare
val trans_conv_cmp : ?l2r:bool -> conv_pb -> constr trans_conversion_function
val trans_conv :
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index 58f3bcdf0..a00a462e1 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -317,7 +317,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
(* Check that the given definition does not add any constraint over
the expected ones, so that it can be used in place of
the original. *)
- if Univ.check_constraints ctx1 (Environ.universes env) then
+ if UGraph.check_constraints ctx1 (Environ.universes env) then
cstrs, env, inst2
else error (IncompatibleConstraints ctx1)
with Univ.UniverseInconsistency incon ->
diff --git a/kernel/term.mli b/kernel/term.mli
index d60716410..2bb811060 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -436,11 +436,11 @@ val eq_constr : constr -> constr -> bool
(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts,
application grouping and the universe constraints in [u]. *)
-val eq_constr_univs : constr Univ.check_function
+val eq_constr_univs : constr UGraph.check_function
(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo
alpha, casts, application grouping and the universe constraints in [u]. *)
-val leq_constr_univs : constr Univ.check_function
+val leq_constr_univs : constr UGraph.check_function
(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts,
application grouping and ignoring universe instances. *)
diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml
new file mode 100644
index 000000000..356cf4da6
--- /dev/null
+++ b/kernel/uGraph.ml
@@ -0,0 +1,868 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Pp
+open Errors
+open Util
+open Univ
+
+(* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *)
+(* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *)
+(* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *)
+(* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *)
+(* Support for universe polymorphism by MS [2014] *)
+
+(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu Sozeau,
+ Pierre-Marie Pédrot *)
+
+let error_inconsistency o u v (p:explanation option) =
+ raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p))
+
+type status = Unset | SetLe | SetLt
+
+(* Comparison on this type is pointer equality *)
+type canonical_arc =
+ { univ: Level.t;
+ lt: Level.t list;
+ le: Level.t list;
+ rank : int;
+ mutable status : status;
+ (** Guaranteed to be unset out of the [compare_neq] functions. It is used
+ to do an imperative traversal of the graph, ensuring a O(1) check that
+ a node has already been visited. Quite performance critical indeed. *)
+ }
+
+let arc_is_le arc = match arc.status with
+| Unset -> false
+| SetLe | SetLt -> true
+
+let arc_is_lt arc = match arc.status with
+| Unset | SetLe -> false
+| SetLt -> true
+
+let terminal u = {univ=u; lt=[]; le=[]; rank=0; status = Unset}
+
+module UMap :
+sig
+ type key = Level.t
+ type +'a t
+ val empty : 'a t
+ val add : key -> 'a -> 'a t -> 'a t
+ val find : key -> 'a t -> 'a
+ val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val iter : (key -> 'a -> unit) -> 'a t -> unit
+ val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+end = HMap.Make(Level)
+
+(* A Level.t is either an alias for another one, or a canonical one,
+ for which we know the universes that are above *)
+
+type univ_entry =
+ Canonical of canonical_arc
+ | Equiv of Level.t
+
+type universes = univ_entry UMap.t
+
+type t = universes
+
+(** Used to cleanup universes if a traversal function is interrupted before it
+ has the opportunity to do it itself. *)
+let unsafe_cleanup_universes g =
+ let iter _ arc = match arc with
+ | Equiv _ -> ()
+ | Canonical arc -> arc.status <- Unset
+ in
+ UMap.iter iter g
+
+let rec cleanup_universes g =
+ try unsafe_cleanup_universes g
+ with e ->
+ (** The only way unsafe_cleanup_universes may raise an exception is when
+ a serious error (stack overflow, out of memory) occurs, or a signal is
+ sent. In this unlikely event, we relaunch the cleanup until we finally
+ succeed. *)
+ cleanup_universes g; raise e
+
+let enter_equiv_arc u v g =
+ UMap.add u (Equiv v) g
+
+let enter_arc ca g =
+ UMap.add ca.univ (Canonical ca) g
+
+(* Every Level.t has a unique canonical arc representative *)
+
+(** The graph always contains nodes for Prop and Set. *)
+
+let terminal_lt u v =
+ {(terminal u) with lt=[v]}
+
+let empty_universes =
+ let g = enter_arc (terminal Level.set) UMap.empty in
+ let g = enter_arc (terminal_lt Level.prop Level.set) g in
+ g
+
+(* repr : universes -> Level.t -> canonical_arc *)
+(* canonical representative : we follow the Equiv links *)
+
+let rec repr g u =
+ let a =
+ try UMap.find u g
+ with Not_found -> anomaly ~label:"Univ.repr"
+ (str"Universe " ++ Level.pr u ++ str" undefined")
+ in
+ match a with
+ | Equiv v -> repr g v
+ | Canonical arc -> arc
+
+let get_prop_arc g = repr g Level.prop
+let get_set_arc g = repr g Level.set
+let is_set_arc u = Level.is_set u.univ
+let is_prop_arc u = Level.is_prop u.univ
+
+exception AlreadyDeclared
+
+let add_universe vlev strict g =
+ try
+ let _arcv = UMap.find vlev g in
+ raise AlreadyDeclared
+ with Not_found ->
+ let v = terminal vlev in
+ let arc =
+ let arc = get_set_arc g in
+ if strict then
+ { arc with lt=vlev::arc.lt}
+ else
+ { arc with le=vlev::arc.le}
+ in
+ let g = enter_arc arc g in
+ enter_arc v g
+
+(* reprleq : canonical_arc -> canonical_arc list *)
+(* All canonical arcv such that arcu<=arcv with arcv#arcu *)
+let reprleq g arcu =
+ let rec searchrec w = function
+ | [] -> w
+ | v :: vl ->
+ let arcv = repr g v in
+ if List.memq arcv w || arcu==arcv then
+ searchrec w vl
+ else
+ searchrec (arcv :: w) vl
+ in
+ searchrec [] arcu.le
+
+
+(* between : Level.t -> canonical_arc -> canonical_arc list *)
+(* between u v = { w | u<=w<=v, w canonical } *)
+(* between is the most costly operation *)
+
+let between g arcu arcv =
+ (* good are all w | u <= w <= v *)
+ (* bad are all w | u <= w ~<= v *)
+ (* find good and bad nodes in {w | u <= w} *)
+ (* explore b u = (b or "u is good") *)
+ let rec explore ((good, bad, b) as input) arcu =
+ if List.memq arcu good then
+ (good, bad, true) (* b or true *)
+ else if List.memq arcu bad then
+ input (* (good, bad, b or false) *)
+ else
+ let leq = reprleq g arcu in
+ (* is some universe >= u good ? *)
+ let good, bad, b_leq =
+ List.fold_left explore (good, bad, false) leq
+ in
+ if b_leq then
+ arcu::good, bad, true (* b or true *)
+ else
+ good, arcu::bad, b (* b or false *)
+ in
+ let good,_,_ = explore ([arcv],[],false) arcu in
+ good
+(* We assume compare(u,v) = LE with v canonical (see compare below).
+ In this case List.hd(between g u v) = repr u
+ Otherwise, between g u v = []
+ *)
+
+(** [fast_compare_neq] : is [arcv] in the transitive upward closure of [arcu] ?
+
+ In [strict] mode, we fully distinguish between LE and LT, while in
+ non-strict mode, we simply answer LE for both situations.
+
+ If [arcv] is encountered in a LT part, we could directly answer
+ without visiting unneeded parts of this transitive closure.
+ In [strict] mode, if [arcv] is encountered in a LE part, we could only
+ change the default answer (1st arg [c]) from NLE to LE, since a strict
+ constraint may appear later. During the recursive traversal,
+ [lt_done] and [le_done] are universes we have already visited,
+ they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)],
+ two lists of universes not yet considered, known to be above [arcu],
+ strictly or not.
+
+ We use depth-first search, but the presence of [arcv] in [new_lt]
+ is checked as soon as possible : this seems to be slightly faster
+ on a test.
+
+ We do the traversal imperatively, setting the [status] flag on visited nodes.
+ This ensures O(1) check, but it also requires unsetting the flag when leaving
+ the function. Some special care has to be taken in order to ensure we do not
+ recover a messed up graph at the end. This occurs in particular when the
+ traversal raises an exception. Even though the code below is exception-free,
+ OCaml may still raise random exceptions, essentially fatal exceptions or
+ signal handlers. Therefore we ensure the cleanup by a catch-all clause. Note
+ also that the use of an imperative solution does make this function
+ thread-unsafe. For now we do not check universes in different threads, but if
+ ever this is to be done, we would need some lock somewhere.
+
+*)
+
+let get_explanation strict g arcu arcv =
+ (* [c] characterizes whether (and how) arcv has already been related
+ to arcu among the lt_done,le_done universe *)
+ let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with
+ | [],[] -> (to_revert, c)
+ | (arc,p)::lt_todo, le_todo ->
+ if arc_is_lt arc then
+ cmp c to_revert lt_todo le_todo
+ else
+ let rec find lt_todo lt le = match le with
+ | [] ->
+ begin match lt with
+ | [] ->
+ let () = arc.status <- SetLt in
+ cmp c (arc :: to_revert) lt_todo le_todo
+ | u :: lt ->
+ let arc = repr g u in
+ let p = (Lt, Universe.make u) :: p in
+ if arc == arcv then
+ if strict then (to_revert, p) else (to_revert, p)
+ else find ((arc, p) :: lt_todo) lt le
+ end
+ | u :: le ->
+ let arc = repr g u in
+ let p = (Le, Universe.make u) :: p in
+ if arc == arcv then
+ if strict then (to_revert, p) else (to_revert, p)
+ else find ((arc, p) :: lt_todo) lt le
+ in
+ find lt_todo arc.lt arc.le
+ | [], (arc,p)::le_todo ->
+ if arc == arcv then
+ (* No need to continue inspecting universes above arc:
+ if arcv is strictly above arc, then we would have a cycle.
+ But we cannot answer LE yet, a stronger constraint may
+ come later from [le_todo]. *)
+ if strict then cmp p to_revert [] le_todo else (to_revert, p)
+ else
+ if arc_is_le arc then
+ cmp c to_revert [] le_todo
+ else
+ let rec find lt_todo lt = match lt with
+ | [] ->
+ let fold accu u =
+ let p = (Le, Universe.make u) :: p in
+ let node = (repr g u, p) in
+ node :: accu
+ in
+ let le_new = List.fold_left fold le_todo arc.le in
+ let () = arc.status <- SetLe in
+ cmp c (arc :: to_revert) lt_todo le_new
+ | u :: lt ->
+ let arc = repr g u in
+ let p = (Lt, Universe.make u) :: p in
+ if arc == arcv then
+ if strict then (to_revert, p) else (to_revert, p)
+ else find ((arc, p) :: lt_todo) lt
+ in
+ find [] arc.lt
+ in
+ let start = (* if is_prop_arc arcu then [Le, make arcv.univ] else *) [] in
+ try
+ let (to_revert, c) = cmp start [] [] [(arcu, [])] in
+ (** Reset all the touched arcs. *)
+ let () = List.iter (fun arc -> arc.status <- Unset) to_revert in
+ List.rev c
+ with e ->
+ (** Unlikely event: fatal error or signal *)
+ let () = cleanup_universes g in
+ raise e
+
+let get_explanation strict g arcu arcv =
+ if !Flags.univ_print then Some (get_explanation strict g arcu arcv)
+ else None
+
+type fast_order = FastEQ | FastLT | FastLE | FastNLE
+
+let fast_compare_neq strict g arcu arcv =
+ (* [c] characterizes whether arcv has already been related
+ to arcu among the lt_done,le_done universe *)
+ let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with
+ | [],[] -> (to_revert, c)
+ | arc::lt_todo, le_todo ->
+ if arc_is_lt arc then
+ cmp c to_revert lt_todo le_todo
+ else
+ let () = arc.status <- SetLt in
+ process_lt c (arc :: to_revert) lt_todo le_todo arc.lt arc.le
+ | [], arc::le_todo ->
+ if arc == arcv then
+ (* No need to continue inspecting universes above arc:
+ if arcv is strictly above arc, then we would have a cycle.
+ But we cannot answer LE yet, a stronger constraint may
+ come later from [le_todo]. *)
+ if strict then cmp FastLE to_revert [] le_todo else (to_revert, FastLE)
+ else
+ if arc_is_le arc then
+ cmp c to_revert [] le_todo
+ else
+ let () = arc.status <- SetLe in
+ process_le c (arc :: to_revert) [] le_todo arc.lt arc.le
+
+ and process_lt c to_revert lt_todo le_todo lt le = match le with
+ | [] ->
+ begin match lt with
+ | [] -> cmp c to_revert lt_todo le_todo
+ | u :: lt ->
+ let arc = repr g u in
+ if arc == arcv then
+ if strict then (to_revert, FastLT) else (to_revert, FastLE)
+ else process_lt c to_revert (arc :: lt_todo) le_todo lt le
+ end
+ | u :: le ->
+ let arc = repr g u in
+ if arc == arcv then
+ if strict then (to_revert, FastLT) else (to_revert, FastLE)
+ else process_lt c to_revert (arc :: lt_todo) le_todo lt le
+
+ and process_le c to_revert lt_todo le_todo lt le = match lt with
+ | [] ->
+ let fold accu u =
+ let node = repr g u in
+ node :: accu
+ in
+ let le_new = List.fold_left fold le_todo le in
+ cmp c to_revert lt_todo le_new
+ | u :: lt ->
+ let arc = repr g u in
+ if arc == arcv then
+ if strict then (to_revert, FastLT) else (to_revert, FastLE)
+ else process_le c to_revert (arc :: lt_todo) le_todo lt le
+
+ in
+ try
+ let (to_revert, c) = cmp FastNLE [] [] [arcu] in
+ (** Reset all the touched arcs. *)
+ let () = List.iter (fun arc -> arc.status <- Unset) to_revert in
+ c
+ with e ->
+ (** Unlikely event: fatal error or signal *)
+ let () = cleanup_universes g in
+ raise e
+
+let get_explanation_strict g arcu arcv = get_explanation true g arcu arcv
+
+let fast_compare g arcu arcv =
+ if arcu == arcv then FastEQ else fast_compare_neq true g arcu arcv
+
+let is_leq g arcu arcv =
+ arcu == arcv ||
+ (match fast_compare_neq false g arcu arcv with
+ | FastNLE -> false
+ | (FastEQ|FastLE|FastLT) -> true)
+
+let is_lt g arcu arcv =
+ if arcu == arcv then false
+ else
+ match fast_compare_neq true g arcu arcv with
+ | FastLT -> true
+ | (FastEQ|FastLE|FastNLE) -> false
+
+(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
+ compare(u,v) = LT or LE => compare(v,u) = NLE
+ compare(u,v) = NLE => compare(v,u) = NLE or LE or LT
+
+ Adding u>=v is consistent iff compare(v,u) # LT
+ and then it is redundant iff compare(u,v) # NLE
+ Adding u>v is consistent iff compare(v,u) = NLE
+ and then it is redundant iff compare(u,v) = LT *)
+
+(** * Universe checks [check_eq] and [check_leq], used in coqchk *)
+
+(** First, checks on universe levels *)
+
+let check_equal g u v =
+ let arcu = repr g u and arcv = repr g v in
+ arcu == arcv
+
+let check_eq_level g u v = u == v || check_equal g u v
+
+let check_smaller g strict u v =
+ let arcu = repr g u and arcv = repr g v in
+ if strict then
+ is_lt g arcu arcv
+ else
+ is_prop_arc arcu
+ || (is_set_arc arcu && not (is_prop_arc arcv))
+ || is_leq g arcu arcv
+
+(** Then, checks on universes *)
+
+type 'a check_function = universes -> 'a -> 'a -> bool
+
+let check_equal_expr g x y =
+ x == y || (let (u, n) = x and (v, m) = y in
+ Int.equal n m && check_equal g u v)
+
+let check_eq_univs g l1 l2 =
+ let f x1 x2 = check_equal_expr g x1 x2 in
+ let exists x1 l = Universe.exists (fun x2 -> f x1 x2) l in
+ Universe.for_all (fun x1 -> exists x1 l2) l1
+ && Universe.for_all (fun x2 -> exists x2 l1) l2
+
+let check_eq g u v =
+ Universe.equal u v || check_eq_univs g u v
+
+let check_smaller_expr g (u,n) (v,m) =
+ let diff = n - m in
+ match diff with
+ | 0 -> check_smaller g false u v
+ | 1 -> check_smaller g true u v
+ | x when x < 0 -> check_smaller g false u v
+ | _ -> false
+
+let exists_bigger g ul l =
+ Universe.exists (fun ul' ->
+ check_smaller_expr g ul ul') l
+
+let real_check_leq g u v =
+ Universe.for_all (fun ul -> exists_bigger g ul v) u
+
+let check_leq g u v =
+ Universe.equal u v ||
+ is_type0m_univ u ||
+ check_eq_univs g u v || real_check_leq g u v
+
+(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *)
+
+(* setlt : Level.t -> Level.t -> reason -> unit *)
+(* forces u > v *)
+(* this is normally an update of u in g rather than a creation. *)
+let setlt g arcu arcv =
+ let arcu' = {arcu with lt=arcv.univ::arcu.lt} in
+ enter_arc arcu' g, arcu'
+
+(* checks that non-redundant *)
+let setlt_if (g,arcu) v =
+ let arcv = repr g v in
+ if is_lt g arcu arcv then g, arcu
+ else setlt g arcu arcv
+
+(* setleq : Level.t -> Level.t -> unit *)
+(* forces u >= v *)
+(* this is normally an update of u in g rather than a creation. *)
+let setleq g arcu arcv =
+ let arcu' = {arcu with le=arcv.univ::arcu.le} in
+ enter_arc arcu' g, arcu'
+
+(* checks that non-redundant *)
+let setleq_if (g,arcu) v =
+ let arcv = repr g v in
+ if is_leq g arcu arcv then g, arcu
+ else setleq g arcu arcv
+
+(* merge : Level.t -> Level.t -> unit *)
+(* we assume compare(u,v) = LE *)
+(* merge u v forces u ~ v with repr u as canonical repr *)
+let merge g arcu arcv =
+ (* we find the arc with the biggest rank, and we redirect all others to it *)
+ let arcu, g, v =
+ let best_ranked (max_rank, old_max_rank, best_arc, rest) arc =
+ if Level.is_small arc.univ ||
+ (arc.rank >= max_rank && not (Level.is_small best_arc.univ))
+ then (arc.rank, max_rank, arc, best_arc::rest)
+ else (max_rank, old_max_rank, best_arc, arc::rest)
+ in
+ match between g arcu arcv with
+ | [] -> anomaly (str "Univ.between")
+ | arc::rest ->
+ let (max_rank, old_max_rank, best_arc, rest) =
+ List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in
+ if max_rank > old_max_rank then best_arc, g, rest
+ else begin
+ (* one redirected node also has max_rank *)
+ let arcu = {best_arc with rank = max_rank + 1} in
+ arcu, enter_arc arcu g, rest
+ end
+ in
+ let redirect (g,w,w') arcv =
+ let g' = enter_equiv_arc arcv.univ arcu.univ g in
+ (g',List.unionq arcv.lt w,arcv.le@w')
+ in
+ let (g',w,w') = List.fold_left redirect (g,[],[]) v in
+ let g_arcu = (g',arcu) in
+ let g_arcu = List.fold_left setlt_if g_arcu w in
+ let g_arcu = List.fold_left setleq_if g_arcu w' in
+ fst g_arcu
+
+(* merge_disc : Level.t -> Level.t -> unit *)
+(* we assume compare(u,v) = compare(v,u) = NLE *)
+(* merge_disc u v forces u ~ v with repr u as canonical repr *)
+let merge_disc g arc1 arc2 =
+ let arcu, arcv = if Level.is_small arc2.univ || arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in
+ let arcu, g =
+ if not (Int.equal arc1.rank arc2.rank) then arcu, g
+ else
+ let arcu = {arcu with rank = succ arcu.rank} in
+ arcu, enter_arc arcu g
+ in
+ let g' = enter_equiv_arc arcv.univ arcu.univ g in
+ let g_arcu = (g',arcu) in
+ let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in
+ let g_arcu = List.fold_left setleq_if g_arcu arcv.le in
+ fst g_arcu
+
+(* enforce_univ_eq : Level.t -> Level.t -> unit *)
+(* enforce_univ_eq u v will force u=v if possible, will fail otherwise *)
+
+let enforce_univ_eq u v g =
+ let arcu = repr g u and arcv = repr g v in
+ match fast_compare g arcu arcv with
+ | FastEQ -> g
+ | FastLT ->
+ let p = get_explanation_strict g arcu arcv in
+ error_inconsistency Eq v u p
+ | FastLE -> merge g arcu arcv
+ | FastNLE ->
+ (match fast_compare g arcv arcu with
+ | FastLT ->
+ let p = get_explanation_strict g arcv arcu in
+ error_inconsistency Eq u v p
+ | FastLE -> merge g arcv arcu
+ | FastNLE -> merge_disc g arcu arcv
+ | FastEQ -> anomaly (Pp.str "Univ.compare"))
+
+(* enforce_univ_leq : Level.t -> Level.t -> unit *)
+(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *)
+let enforce_univ_leq u v g =
+ let arcu = repr g u and arcv = repr g v in
+ if is_leq g arcu arcv then g
+ else
+ match fast_compare g arcv arcu with
+ | FastLT ->
+ let p = get_explanation_strict g arcv arcu in
+ error_inconsistency Le u v p
+ | FastLE -> merge g arcv arcu
+ | FastNLE -> fst (setleq g arcu arcv)
+ | FastEQ -> anomaly (Pp.str "Univ.compare")
+
+(* enforce_univ_lt u v will force u<v if possible, will fail otherwise *)
+let enforce_univ_lt u v g =
+ let arcu = repr g u and arcv = repr g v in
+ match fast_compare g arcu arcv with
+ | FastLT -> g
+ | FastLE -> fst (setlt g arcu arcv)
+ | FastEQ -> error_inconsistency Lt u v (Some [(Eq,Universe.make v)])
+ | FastNLE ->
+ match fast_compare_neq false g arcv arcu with
+ FastNLE -> fst (setlt g arcu arcv)
+ | FastEQ -> anomaly (Pp.str "Univ.compare")
+ | (FastLE|FastLT) ->
+ let p = get_explanation false g arcv arcu in
+ error_inconsistency Lt u v p
+
+(* Prop = Set is forbidden here. *)
+let initial_universes = empty_universes
+
+let is_initial_universes g = UMap.equal (==) g initial_universes
+
+let enforce_constraint cst g =
+ match cst with
+ | (u,Lt,v) -> enforce_univ_lt u v g
+ | (u,Le,v) -> enforce_univ_leq u v g
+ | (u,Eq,v) -> enforce_univ_eq u v g
+
+let merge_constraints c g =
+ Constraint.fold enforce_constraint c g
+
+let check_constraint g (l,d,r) =
+ match d with
+ | Eq -> check_equal g l r
+ | Le -> check_smaller g false l r
+ | Lt -> check_smaller g true l r
+
+let check_constraints c g =
+ Constraint.for_all (check_constraint g) c
+
+(* Normalization *)
+
+let lookup_level u g =
+ try Some (UMap.find u g) with Not_found -> None
+
+(** [normalize_universes g] returns a graph where all edges point
+ directly to the canonical representent of their target. The output
+ graph should be equivalent to the input graph from a logical point
+ of view, but optimized. We maintain the invariant that the key of
+ a [Canonical] element is its own name, by keeping [Equiv] edges
+ (see the assertion)... I (Stéphane Glondu) am not sure if this
+ plays a role in the rest of the module. *)
+let normalize_universes g =
+ let rec visit u arc cache = match lookup_level u cache with
+ | Some x -> x, cache
+ | None -> match Lazy.force arc with
+ | None ->
+ u, UMap.add u u cache
+ | Some (Canonical {univ=v; lt=_; le=_}) ->
+ v, UMap.add u v cache
+ | Some (Equiv v) ->
+ let v, cache = visit v (lazy (lookup_level v g)) cache in
+ v, UMap.add u v cache
+ in
+ let cache = UMap.fold
+ (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache))
+ g UMap.empty
+ in
+ let repr x = UMap.find x cache in
+ let lrepr us = List.fold_left
+ (fun e x -> LSet.add (repr x) e) LSet.empty us
+ in
+ let canonicalize u = function
+ | Equiv _ -> Equiv (repr u)
+ | Canonical {univ=v; lt=lt; le=le; rank=rank} ->
+ assert (u == v);
+ (* avoid duplicates and self-loops *)
+ let lt = lrepr lt and le = lrepr le in
+ let le = LSet.filter
+ (fun x -> x != u && not (LSet.mem x lt)) le
+ in
+ LSet.iter (fun x -> assert (x != u)) lt;
+ Canonical {
+ univ = v;
+ lt = LSet.elements lt;
+ le = LSet.elements le;
+ rank = rank;
+ status = Unset;
+ }
+ in
+ UMap.mapi canonicalize g
+
+let constraints_of_universes g =
+ let constraints_of u v acc =
+ match v with
+ | Canonical {univ=u; lt=lt; le=le} ->
+ let acc = List.fold_left (fun acc v -> Constraint.add (u,Lt,v) acc) acc lt in
+ let acc = List.fold_left (fun acc v -> Constraint.add (u,Le,v) acc) acc le in
+ acc
+ | Equiv v -> Constraint.add (u,Eq,v) acc
+ in
+ UMap.fold constraints_of g Constraint.empty
+
+let constraints_of_universes g =
+ constraints_of_universes (normalize_universes g)
+
+(** Longest path algorithm. This is used to compute the minimal number of
+ universes required if the only strict edge would be the Lt one. This
+ algorithm assumes that the given universes constraints are a almost DAG, in
+ the sense that there may be {Eq, Le}-cycles. This is OK for consistent
+ universes, which is the only case where we use this algorithm. *)
+
+(** Adjacency graph *)
+type graph = constraint_type LMap.t LMap.t
+
+exception Connected
+
+(** Check connectedness *)
+let connected x y (g : graph) =
+ let rec connected x target seen g =
+ if Level.equal x target then raise Connected
+ else if not (LSet.mem x seen) then
+ let seen = LSet.add x seen in
+ let fold z _ seen = connected z target seen g in
+ let neighbours = try LMap.find x g with Not_found -> LMap.empty in
+ LMap.fold fold neighbours seen
+ else seen
+ in
+ try ignore(connected x y LSet.empty g); false with Connected -> true
+
+let add_edge x y v (g : graph) =
+ try
+ let neighbours = LMap.find x g in
+ let neighbours = LMap.add y v neighbours in
+ LMap.add x neighbours g
+ with Not_found ->
+ LMap.add x (LMap.singleton y v) g
+
+(** We want to keep the graph DAG. If adding an edge would cause a cycle, that
+ would necessarily be an {Eq, Le}-cycle, otherwise there would have been a
+ universe inconsistency. Therefore we may omit adding such a cycling edge
+ without changing the compacted graph. *)
+let add_eq_edge x y v g = if connected y x g then g else add_edge x y v g
+
+(** Construct the DAG and its inverse at the same time. *)
+let make_graph g : (graph * graph) =
+ let fold u arc accu = match arc with
+ | Equiv v ->
+ let (dir, rev) = accu in
+ (add_eq_edge u v Eq dir, add_eq_edge v u Eq rev)
+ | Canonical { univ; lt; le; } ->
+ let () = assert (u == univ) in
+ let fold_lt (dir, rev) v = (add_edge u v Lt dir, add_edge v u Lt rev) in
+ let fold_le (dir, rev) v = (add_eq_edge u v Le dir, add_eq_edge v u Le rev) in
+ (** Order is important : lt after le, because of the possible redundancy
+ between [le] and [lt] in a canonical arc. This way, the [lt] constraint
+ is the last one set, which is correct because it implies [le]. *)
+ let accu = List.fold_left fold_le accu le in
+ let accu = List.fold_left fold_lt accu lt in
+ accu
+ in
+ UMap.fold fold g (LMap.empty, LMap.empty)
+
+(** Construct a topological order out of a DAG. *)
+let rec topological_fold u g rem seen accu =
+ let is_seen =
+ try
+ let status = LMap.find u seen in
+ assert status; (** If false, not a DAG! *)
+ true
+ with Not_found -> false
+ in
+ if not is_seen then
+ let rem = LMap.remove u rem in
+ let seen = LMap.add u false seen in
+ let neighbours = try LMap.find u g with Not_found -> LMap.empty in
+ let fold v _ (rem, seen, accu) = topological_fold v g rem seen accu in
+ let (rem, seen, accu) = LMap.fold fold neighbours (rem, seen, accu) in
+ (rem, LMap.add u true seen, u :: accu)
+ else (rem, seen, accu)
+
+let rec topological g rem seen accu =
+ let node = try Some (LMap.choose rem) with Not_found -> None in
+ match node with
+ | None -> accu
+ | Some (u, _) ->
+ let rem, seen, accu = topological_fold u g rem seen accu in
+ topological g rem seen accu
+
+(** Compute the longest path from any vertex. *)
+let constraint_cost = function
+| Eq | Le -> 0
+| Lt -> 1
+
+(** This algorithm browses the graph in topological order, computing for each
+ encountered node the length of the longest path leading to it. Should be
+ O(|V|) or so (modulo map representation). *)
+let rec flatten_graph rem (rev : graph) map mx = match rem with
+| [] -> map, mx
+| u :: rem ->
+ let prev = try LMap.find u rev with Not_found -> LMap.empty in
+ let fold v cstr accu =
+ let v_cost = LMap.find v map in
+ max (v_cost + constraint_cost cstr) accu
+ in
+ let u_cost = LMap.fold fold prev 0 in
+ let map = LMap.add u u_cost map in
+ flatten_graph rem rev map (max mx u_cost)
+
+(** [sort_universes g] builds a map from universes in [g] to natural
+ numbers. It outputs a graph containing equivalence edges from each
+ level appearing in [g] to [Type.n], and [lt] edges between the
+ [Type.n]s. The output graph should imply the input graph (and the
+ [Type.n]s. The output graph should imply the input graph (and the
+ implication will be strict most of the time), but is not
+ necessarily minimal. Note: the result is unspecified if the input
+ graph already contains [Type.n] nodes (calling a module Type is
+ probably a bad idea anyway). *)
+let sort_universes orig =
+ let (dir, rev) = make_graph orig in
+ let order = topological dir dir LMap.empty [] in
+ let compact, max = flatten_graph order rev LMap.empty 0 in
+ let mp = Names.DirPath.make [Names.Id.of_string "Type"] in
+ let types = Array.init (max + 1) (fun n -> Level.make mp n) in
+ (** Old universes are made equal to [Type.n] *)
+ let fold u level accu = UMap.add u (Equiv types.(level)) accu in
+ let sorted = LMap.fold fold compact UMap.empty in
+ (** Add all [Type.n] nodes *)
+ let fold i accu u =
+ if i < max then
+ let pred = types.(i + 1) in
+ let arc = {univ = u; lt = [pred]; le = []; rank = 0; status = Unset; } in
+ UMap.add u (Canonical arc) accu
+ else accu
+ in
+ Array.fold_left_i fold sorted types
+
+(** Instances *)
+
+let check_eq_instances g t1 t2 =
+ let t1 = Instance.to_array t1 in
+ let t2 = Instance.to_array t2 in
+ t1 == t2 ||
+ (Int.equal (Array.length t1) (Array.length t2) &&
+ let rec aux i =
+ (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1))
+ in aux 0)
+
+let pr_arc prl = function
+ | _, Canonical {univ=u; lt=[]; le=[]} ->
+ mt ()
+ | _, Canonical {univ=u; lt=lt; le=le} ->
+ let opt_sep = match lt, le with
+ | [], _ | _, [] -> mt ()
+ | _ -> spc ()
+ in
+ prl u ++ str " " ++
+ v 0
+ (pr_sequence (fun v -> str "< " ++ prl v) lt ++
+ opt_sep ++
+ pr_sequence (fun v -> str "<= " ++ prl v) le) ++
+ fnl ()
+ | u, Equiv v ->
+ prl u ++ str " = " ++ prl v ++ fnl ()
+
+let pr_universes prl g =
+ let graph = UMap.fold (fun u a l -> (u,a)::l) g [] in
+ prlist (pr_arc prl) graph
+
+(* Dumping constraints to a file *)
+
+let dump_universes output g =
+ let dump_arc u = function
+ | Canonical {univ=u; lt=lt; le=le} ->
+ let u_str = Level.to_string u in
+ List.iter (fun v -> output Lt (Level.to_string v) u_str) lt;
+ List.iter (fun v -> output Le (Level.to_string v) u_str) le
+ | Equiv v ->
+ output Eq (Level.to_string u) (Level.to_string v)
+ in
+ UMap.iter dump_arc g
+
+(** Profiling *)
+
+let merge_constraints =
+ if Flags.profile then
+ let key = Profile.declare_profile "merge_constraints" in
+ Profile.profile2 key merge_constraints
+ else merge_constraints
+
+let check_constraints =
+ if Flags.profile then
+ let key = Profile.declare_profile "check_constraints" in
+ Profile.profile2 key check_constraints
+ else check_constraints
+
+let check_eq =
+ if Flags.profile then
+ let check_eq_key = Profile.declare_profile "check_eq" in
+ Profile.profile3 check_eq_key check_eq
+ else check_eq
+
+let check_leq =
+ if Flags.profile then
+ let check_leq_key = Profile.declare_profile "check_leq" in
+ Profile.profile3 check_leq_key check_leq
+ else check_leq
diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli
new file mode 100644
index 000000000..e95cf4d1c
--- /dev/null
+++ b/kernel/uGraph.mli
@@ -0,0 +1,63 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Univ
+
+(** {6 Graphs of universes. } *)
+
+type t
+
+type universes = t
+
+type 'a check_function = universes -> 'a -> 'a -> bool
+val check_leq : universe check_function
+val check_eq : universe check_function
+
+(** The empty graph of universes *)
+val empty_universes : universes
+
+(** The initial graph of universes: Prop < Set *)
+val initial_universes : universes
+
+val is_initial_universes : universes -> bool
+
+val sort_universes : universes -> universes
+
+(** Adds a universe to the graph, ensuring it is >= or > Set.
+ @raises AlreadyDeclared if the level is already declared in the graph. *)
+
+exception AlreadyDeclared
+
+val add_universe : universe_level -> bool -> universes -> universes
+
+(** {6 ... } *)
+(** Merge of constraints in a universes graph.
+ The function [merge_constraints] merges a set of constraints in a given
+ universes graph. It raises the exception [UniverseInconsistency] if the
+ constraints are not satisfiable. *)
+
+val enforce_constraint : univ_constraint -> universes -> universes
+val merge_constraints : constraints -> universes -> universes
+
+val constraints_of_universes : universes -> constraints
+
+val check_constraint : universes -> univ_constraint -> bool
+val check_constraints : constraints -> universes -> bool
+
+val check_eq_instances : Instance.t check_function
+(** Check equality of instances w.r.t. a universe graph *)
+
+(** {6 Pretty-printing of universes. } *)
+
+val pr_universes : (Level.t -> Pp.std_ppcmds) -> universes -> Pp.std_ppcmds
+
+(** {6 Dumping to a file } *)
+
+val dump_universes :
+ (constraint_type -> string -> string -> unit) ->
+ universes -> unit
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 064dde3a6..b303a1a5a 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -653,170 +653,6 @@ open Universe
let universe_level = Universe.level
-type status = Unset | SetLe | SetLt
-
-(* Comparison on this type is pointer equality *)
-type canonical_arc =
- { univ: Level.t;
- lt: Level.t list;
- le: Level.t list;
- rank : int;
- mutable status : status;
- (** Guaranteed to be unset out of the [compare_neq] functions. It is used
- to do an imperative traversal of the graph, ensuring a O(1) check that
- a node has already been visited. Quite performance critical indeed. *)
- }
-
-let arc_is_le arc = match arc.status with
-| Unset -> false
-| SetLe | SetLt -> true
-
-let arc_is_lt arc = match arc.status with
-| Unset | SetLe -> false
-| SetLt -> true
-
-let terminal u = {univ=u; lt=[]; le=[]; rank=0; status = Unset}
-
-module UMap :
-sig
- type key = Level.t
- type +'a t
- val empty : 'a t
- val add : key -> 'a -> 'a t -> 'a t
- val find : key -> 'a t -> 'a
- val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
- val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
- val iter : (key -> 'a -> unit) -> 'a t -> unit
- val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
-end = HMap.Make(Level)
-
-(* A Level.t is either an alias for another one, or a canonical one,
- for which we know the universes that are above *)
-
-type univ_entry =
- Canonical of canonical_arc
- | Equiv of Level.t
-
-type universes = univ_entry UMap.t
-
-(** Used to cleanup universes if a traversal function is interrupted before it
- has the opportunity to do it itself. *)
-let unsafe_cleanup_universes g =
- let iter _ arc = match arc with
- | Equiv _ -> ()
- | Canonical arc -> arc.status <- Unset
- in
- UMap.iter iter g
-
-let rec cleanup_universes g =
- try unsafe_cleanup_universes g
- with e ->
- (** The only way unsafe_cleanup_universes may raise an exception is when
- a serious error (stack overflow, out of memory) occurs, or a signal is
- sent. In this unlikely event, we relaunch the cleanup until we finally
- succeed. *)
- cleanup_universes g; raise e
-
-let enter_equiv_arc u v g =
- UMap.add u (Equiv v) g
-
-let enter_arc ca g =
- UMap.add ca.univ (Canonical ca) g
-
-(* Every Level.t has a unique canonical arc representative *)
-
-(** The graph always contains nodes for Prop and Set. *)
-
-let terminal_lt u v =
- {(terminal u) with lt=[v]}
-
-let empty_universes =
- let g = enter_arc (terminal Level.set) UMap.empty in
- let g = enter_arc (terminal_lt Level.prop Level.set) g in
- g
-
-(* repr : universes -> Level.t -> canonical_arc *)
-(* canonical representative : we follow the Equiv links *)
-
-let rec repr g u =
- let a =
- try UMap.find u g
- with Not_found -> anomaly ~label:"Univ.repr"
- (str"Universe " ++ Level.pr u ++ str" undefined")
- in
- match a with
- | Equiv v -> repr g v
- | Canonical arc -> arc
-
-let get_prop_arc g = repr g Level.prop
-let get_set_arc g = repr g Level.set
-let is_set_arc u = Level.is_set u.univ
-let is_prop_arc u = Level.is_prop u.univ
-
-exception AlreadyDeclared
-
-let add_universe vlev strict g =
- try
- let _arcv = UMap.find vlev g in
- raise AlreadyDeclared
- with Not_found ->
- let v = terminal vlev in
- let arc =
- let arc = get_set_arc g in
- if strict then
- { arc with lt=vlev::arc.lt}
- else
- { arc with le=vlev::arc.le}
- in
- let g = enter_arc arc g in
- enter_arc v g
-
-(* reprleq : canonical_arc -> canonical_arc list *)
-(* All canonical arcv such that arcu<=arcv with arcv#arcu *)
-let reprleq g arcu =
- let rec searchrec w = function
- | [] -> w
- | v :: vl ->
- let arcv = repr g v in
- if List.memq arcv w || arcu==arcv then
- searchrec w vl
- else
- searchrec (arcv :: w) vl
- in
- searchrec [] arcu.le
-
-
-(* between : Level.t -> canonical_arc -> canonical_arc list *)
-(* between u v = { w | u<=w<=v, w canonical } *)
-(* between is the most costly operation *)
-
-let between g arcu arcv =
- (* good are all w | u <= w <= v *)
- (* bad are all w | u <= w ~<= v *)
- (* find good and bad nodes in {w | u <= w} *)
- (* explore b u = (b or "u is good") *)
- let rec explore ((good, bad, b) as input) arcu =
- if List.memq arcu good then
- (good, bad, true) (* b or true *)
- else if List.memq arcu bad then
- input (* (good, bad, b or false) *)
- else
- let leq = reprleq g arcu in
- (* is some universe >= u good ? *)
- let good, bad, b_leq =
- List.fold_left explore (good, bad, false) leq
- in
- if b_leq then
- arcu::good, bad, true (* b or true *)
- else
- good, arcu::bad, b (* b or false *)
- in
- let good,_,_ = explore ([arcv],[],false) arcu in
- good
-(* We assume compare(u,v) = LE with v canonical (see compare below).
- In this case List.hd(between g u v) = repr u
- Otherwise, between g u v = []
- *)
type constraint_type = Lt | Le | Eq
@@ -831,343 +667,6 @@ let constraint_type_ord c1 c2 = match c1, c2 with
| Eq, Eq -> 0
| Eq, _ -> 1
-(** [fast_compare_neq] : is [arcv] in the transitive upward closure of [arcu] ?
-
- In [strict] mode, we fully distinguish between LE and LT, while in
- non-strict mode, we simply answer LE for both situations.
-
- If [arcv] is encountered in a LT part, we could directly answer
- without visiting unneeded parts of this transitive closure.
- In [strict] mode, if [arcv] is encountered in a LE part, we could only
- change the default answer (1st arg [c]) from NLE to LE, since a strict
- constraint may appear later. During the recursive traversal,
- [lt_done] and [le_done] are universes we have already visited,
- they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)],
- two lists of universes not yet considered, known to be above [arcu],
- strictly or not.
-
- We use depth-first search, but the presence of [arcv] in [new_lt]
- is checked as soon as possible : this seems to be slightly faster
- on a test.
-
- We do the traversal imperatively, setting the [status] flag on visited nodes.
- This ensures O(1) check, but it also requires unsetting the flag when leaving
- the function. Some special care has to be taken in order to ensure we do not
- recover a messed up graph at the end. This occurs in particular when the
- traversal raises an exception. Even though the code below is exception-free,
- OCaml may still raise random exceptions, essentially fatal exceptions or
- signal handlers. Therefore we ensure the cleanup by a catch-all clause. Note
- also that the use of an imperative solution does make this function
- thread-unsafe. For now we do not check universes in different threads, but if
- ever this is to be done, we would need some lock somewhere.
-
-*)
-
-let get_explanation strict g arcu arcv =
- (* [c] characterizes whether (and how) arcv has already been related
- to arcu among the lt_done,le_done universe *)
- let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with
- | [],[] -> (to_revert, c)
- | (arc,p)::lt_todo, le_todo ->
- if arc_is_lt arc then
- cmp c to_revert lt_todo le_todo
- else
- let rec find lt_todo lt le = match le with
- | [] ->
- begin match lt with
- | [] ->
- let () = arc.status <- SetLt in
- cmp c (arc :: to_revert) lt_todo le_todo
- | u :: lt ->
- let arc = repr g u in
- let p = (Lt, make u) :: p in
- if arc == arcv then
- if strict then (to_revert, p) else (to_revert, p)
- else find ((arc, p) :: lt_todo) lt le
- end
- | u :: le ->
- let arc = repr g u in
- let p = (Le, make u) :: p in
- if arc == arcv then
- if strict then (to_revert, p) else (to_revert, p)
- else find ((arc, p) :: lt_todo) lt le
- in
- find lt_todo arc.lt arc.le
- | [], (arc,p)::le_todo ->
- if arc == arcv then
- (* No need to continue inspecting universes above arc:
- if arcv is strictly above arc, then we would have a cycle.
- But we cannot answer LE yet, a stronger constraint may
- come later from [le_todo]. *)
- if strict then cmp p to_revert [] le_todo else (to_revert, p)
- else
- if arc_is_le arc then
- cmp c to_revert [] le_todo
- else
- let rec find lt_todo lt = match lt with
- | [] ->
- let fold accu u =
- let p = (Le, make u) :: p in
- let node = (repr g u, p) in
- node :: accu
- in
- let le_new = List.fold_left fold le_todo arc.le in
- let () = arc.status <- SetLe in
- cmp c (arc :: to_revert) lt_todo le_new
- | u :: lt ->
- let arc = repr g u in
- let p = (Lt, make u) :: p in
- if arc == arcv then
- if strict then (to_revert, p) else (to_revert, p)
- else find ((arc, p) :: lt_todo) lt
- in
- find [] arc.lt
- in
- let start = (* if is_prop_arc arcu then [Le, make arcv.univ] else *) [] in
- try
- let (to_revert, c) = cmp start [] [] [(arcu, [])] in
- (** Reset all the touched arcs. *)
- let () = List.iter (fun arc -> arc.status <- Unset) to_revert in
- List.rev c
- with e ->
- (** Unlikely event: fatal error or signal *)
- let () = cleanup_universes g in
- raise e
-
-let get_explanation strict g arcu arcv =
- if !Flags.univ_print then Some (get_explanation strict g arcu arcv)
- else None
-
-type fast_order = FastEQ | FastLT | FastLE | FastNLE
-
-let fast_compare_neq strict g arcu arcv =
- (* [c] characterizes whether arcv has already been related
- to arcu among the lt_done,le_done universe *)
- let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with
- | [],[] -> (to_revert, c)
- | arc::lt_todo, le_todo ->
- if arc_is_lt arc then
- cmp c to_revert lt_todo le_todo
- else
- let () = arc.status <- SetLt in
- process_lt c (arc :: to_revert) lt_todo le_todo arc.lt arc.le
- | [], arc::le_todo ->
- if arc == arcv then
- (* No need to continue inspecting universes above arc:
- if arcv is strictly above arc, then we would have a cycle.
- But we cannot answer LE yet, a stronger constraint may
- come later from [le_todo]. *)
- if strict then cmp FastLE to_revert [] le_todo else (to_revert, FastLE)
- else
- if arc_is_le arc then
- cmp c to_revert [] le_todo
- else
- let () = arc.status <- SetLe in
- process_le c (arc :: to_revert) [] le_todo arc.lt arc.le
-
- and process_lt c to_revert lt_todo le_todo lt le = match le with
- | [] ->
- begin match lt with
- | [] -> cmp c to_revert lt_todo le_todo
- | u :: lt ->
- let arc = repr g u in
- if arc == arcv then
- if strict then (to_revert, FastLT) else (to_revert, FastLE)
- else process_lt c to_revert (arc :: lt_todo) le_todo lt le
- end
- | u :: le ->
- let arc = repr g u in
- if arc == arcv then
- if strict then (to_revert, FastLT) else (to_revert, FastLE)
- else process_lt c to_revert (arc :: lt_todo) le_todo lt le
-
- and process_le c to_revert lt_todo le_todo lt le = match lt with
- | [] ->
- let fold accu u =
- let node = repr g u in
- node :: accu
- in
- let le_new = List.fold_left fold le_todo le in
- cmp c to_revert lt_todo le_new
- | u :: lt ->
- let arc = repr g u in
- if arc == arcv then
- if strict then (to_revert, FastLT) else (to_revert, FastLE)
- else process_le c to_revert (arc :: lt_todo) le_todo lt le
-
- in
- try
- let (to_revert, c) = cmp FastNLE [] [] [arcu] in
- (** Reset all the touched arcs. *)
- let () = List.iter (fun arc -> arc.status <- Unset) to_revert in
- c
- with e ->
- (** Unlikely event: fatal error or signal *)
- let () = cleanup_universes g in
- raise e
-
-let get_explanation_strict g arcu arcv = get_explanation true g arcu arcv
-
-let fast_compare g arcu arcv =
- if arcu == arcv then FastEQ else fast_compare_neq true g arcu arcv
-
-let is_leq g arcu arcv =
- arcu == arcv ||
- (match fast_compare_neq false g arcu arcv with
- | FastNLE -> false
- | (FastEQ|FastLE|FastLT) -> true)
-
-let is_lt g arcu arcv =
- if arcu == arcv then false
- else
- match fast_compare_neq true g arcu arcv with
- | FastLT -> true
- | (FastEQ|FastLE|FastNLE) -> false
-
-(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
- compare(u,v) = LT or LE => compare(v,u) = NLE
- compare(u,v) = NLE => compare(v,u) = NLE or LE or LT
-
- Adding u>=v is consistent iff compare(v,u) # LT
- and then it is redundant iff compare(u,v) # NLE
- Adding u>v is consistent iff compare(v,u) = NLE
- and then it is redundant iff compare(u,v) = LT *)
-
-(** * Universe checks [check_eq] and [check_leq], used in coqchk *)
-
-(** First, checks on universe levels *)
-
-let check_equal g u v =
- let arcu = repr g u and arcv = repr g v in
- arcu == arcv
-
-let check_eq_level g u v = u == v || check_equal g u v
-
-let check_smaller g strict u v =
- let arcu = repr g u and arcv = repr g v in
- if strict then
- is_lt g arcu arcv
- else
- is_prop_arc arcu
- || (is_set_arc arcu && not (is_prop_arc arcv))
- || is_leq g arcu arcv
-
-(** Then, checks on universes *)
-
-type 'a check_function = universes -> 'a -> 'a -> bool
-
-let check_equal_expr g x y =
- x == y || (let (u, n) = x and (v, m) = y in
- Int.equal n m && check_equal g u v)
-
-let check_eq_univs g l1 l2 =
- let f x1 x2 = check_equal_expr g x1 x2 in
- let exists x1 l = Huniv.exists (fun x2 -> f x1 x2) l in
- Huniv.for_all (fun x1 -> exists x1 l2) l1
- && Huniv.for_all (fun x2 -> exists x2 l1) l2
-
-let check_eq g u v =
- Universe.equal u v || check_eq_univs g u v
-
-let check_smaller_expr g (u,n) (v,m) =
- let diff = n - m in
- match diff with
- | 0 -> check_smaller g false u v
- | 1 -> check_smaller g true u v
- | x when x < 0 -> check_smaller g false u v
- | _ -> false
-
-let exists_bigger g ul l =
- Huniv.exists (fun ul' ->
- check_smaller_expr g ul ul') l
-
-let real_check_leq g u v =
- Huniv.for_all (fun ul -> exists_bigger g ul v) u
-
-let check_leq g u v =
- Universe.equal u v ||
- Universe.is_type0m u ||
- check_eq_univs g u v || real_check_leq g u v
-
-(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *)
-
-(* setlt : Level.t -> Level.t -> reason -> unit *)
-(* forces u > v *)
-(* this is normally an update of u in g rather than a creation. *)
-let setlt g arcu arcv =
- let arcu' = {arcu with lt=arcv.univ::arcu.lt} in
- enter_arc arcu' g, arcu'
-
-(* checks that non-redundant *)
-let setlt_if (g,arcu) v =
- let arcv = repr g v in
- if is_lt g arcu arcv then g, arcu
- else setlt g arcu arcv
-
-(* setleq : Level.t -> Level.t -> unit *)
-(* forces u >= v *)
-(* this is normally an update of u in g rather than a creation. *)
-let setleq g arcu arcv =
- let arcu' = {arcu with le=arcv.univ::arcu.le} in
- enter_arc arcu' g, arcu'
-
-(* checks that non-redundant *)
-let setleq_if (g,arcu) v =
- let arcv = repr g v in
- if is_leq g arcu arcv then g, arcu
- else setleq g arcu arcv
-
-(* merge : Level.t -> Level.t -> unit *)
-(* we assume compare(u,v) = LE *)
-(* merge u v forces u ~ v with repr u as canonical repr *)
-let merge g arcu arcv =
- (* we find the arc with the biggest rank, and we redirect all others to it *)
- let arcu, g, v =
- let best_ranked (max_rank, old_max_rank, best_arc, rest) arc =
- if Level.is_small arc.univ ||
- (arc.rank >= max_rank && not (Level.is_small best_arc.univ))
- then (arc.rank, max_rank, arc, best_arc::rest)
- else (max_rank, old_max_rank, best_arc, arc::rest)
- in
- match between g arcu arcv with
- | [] -> anomaly (str "Univ.between")
- | arc::rest ->
- let (max_rank, old_max_rank, best_arc, rest) =
- List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in
- if max_rank > old_max_rank then best_arc, g, rest
- else begin
- (* one redirected node also has max_rank *)
- let arcu = {best_arc with rank = max_rank + 1} in
- arcu, enter_arc arcu g, rest
- end
- in
- let redirect (g,w,w') arcv =
- let g' = enter_equiv_arc arcv.univ arcu.univ g in
- (g',List.unionq arcv.lt w,arcv.le@w')
- in
- let (g',w,w') = List.fold_left redirect (g,[],[]) v in
- let g_arcu = (g',arcu) in
- let g_arcu = List.fold_left setlt_if g_arcu w in
- let g_arcu = List.fold_left setleq_if g_arcu w' in
- fst g_arcu
-
-(* merge_disc : Level.t -> Level.t -> unit *)
-(* we assume compare(u,v) = compare(v,u) = NLE *)
-(* merge_disc u v forces u ~ v with repr u as canonical repr *)
-let merge_disc g arc1 arc2 =
- let arcu, arcv = if Level.is_small arc2.univ || arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in
- let arcu, g =
- if not (Int.equal arc1.rank arc2.rank) then arcu, g
- else
- let arcu = {arcu with rank = succ arcu.rank} in
- arcu, enter_arc arcu g
- in
- let g' = enter_equiv_arc arcv.univ arcu.univ g in
- let g_arcu = (g',arcu) in
- let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in
- let g_arcu = List.fold_left setleq_if g_arcu arcv.le in
- fst g_arcu
-
(* Universe inconsistency: error raised when trying to enforce a relation
that would create a cycle in the graph of universes. *)
@@ -1178,70 +677,10 @@ exception UniverseInconsistency of univ_inconsistency
let error_inconsistency o u v (p:explanation option) =
raise (UniverseInconsistency (o,make u,make v,p))
-(* enforce_univ_eq : Level.t -> Level.t -> unit *)
-(* enforce_univ_eq u v will force u=v if possible, will fail otherwise *)
-
-let enforce_univ_eq u v g =
- let arcu = repr g u and arcv = repr g v in
- match fast_compare g arcu arcv with
- | FastEQ -> g
- | FastLT ->
- let p = get_explanation_strict g arcu arcv in
- error_inconsistency Eq v u p
- | FastLE -> merge g arcu arcv
- | FastNLE ->
- (match fast_compare g arcv arcu with
- | FastLT ->
- let p = get_explanation_strict g arcv arcu in
- error_inconsistency Eq u v p
- | FastLE -> merge g arcv arcu
- | FastNLE -> merge_disc g arcu arcv
- | FastEQ -> anomaly (Pp.str "Univ.compare"))
-
-(* enforce_univ_leq : Level.t -> Level.t -> unit *)
-(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *)
-let enforce_univ_leq u v g =
- let arcu = repr g u and arcv = repr g v in
- if is_leq g arcu arcv then g
- else
- match fast_compare g arcv arcu with
- | FastLT ->
- let p = get_explanation_strict g arcv arcu in
- error_inconsistency Le u v p
- | FastLE -> merge g arcv arcu
- | FastNLE -> fst (setleq g arcu arcv)
- | FastEQ -> anomaly (Pp.str "Univ.compare")
-
-(* enforce_univ_lt u v will force u<v if possible, will fail otherwise *)
-let enforce_univ_lt u v g =
- let arcu = repr g u and arcv = repr g v in
- match fast_compare g arcu arcv with
- | FastLT -> g
- | FastLE -> fst (setlt g arcu arcv)
- | FastEQ -> error_inconsistency Lt u v (Some [(Eq,make v)])
- | FastNLE ->
- match fast_compare_neq false g arcv arcu with
- FastNLE -> fst (setlt g arcu arcv)
- | FastEQ -> anomaly (Pp.str "Univ.compare")
- | (FastLE|FastLT) ->
- let p = get_explanation false g arcv arcu in
- error_inconsistency Lt u v p
-
-(* Prop = Set is forbidden here. *)
-let initial_universes = empty_universes
-
-let is_initial_universes g = UMap.equal (==) g initial_universes
-
(* Constraints and sets of constraints. *)
type univ_constraint = Level.t * constraint_type * Level.t
-let enforce_constraint cst g =
- match cst with
- | (u,Lt,v) -> enforce_univ_lt u v g
- | (u,Le,v) -> enforce_univ_leq u v g
- | (u,Eq,v) -> enforce_univ_eq u v g
-
let pr_constraint_type op =
let op_str = match op with
| Lt -> " < "
@@ -1276,8 +715,6 @@ end
let empty_constraint = Constraint.empty
let union_constraint = Constraint.union
let eq_constraint = Constraint.equal
-let merge_constraints c g =
- Constraint.fold enforce_constraint c g
type constraints = Constraint.t
@@ -1378,218 +815,12 @@ let enforce_leq u v c =
let enforce_leq_level u v c =
if Level.equal u v then c else Constraint.add (u,Le,v) c
-let check_constraint g (l,d,r) =
- match d with
- | Eq -> check_equal g l r
- | Le -> check_smaller g false l r
- | Lt -> check_smaller g true l r
-
-let check_constraints c g =
- Constraint.for_all (check_constraint g) c
-
let enforce_univ_constraint (u,d,v) =
match d with
| Eq -> enforce_eq u v
| Le -> enforce_leq u v
| Lt -> enforce_leq (super u) v
-(* Normalization *)
-
-let lookup_level u g =
- try Some (UMap.find u g) with Not_found -> None
-
-(** [normalize_universes g] returns a graph where all edges point
- directly to the canonical representent of their target. The output
- graph should be equivalent to the input graph from a logical point
- of view, but optimized. We maintain the invariant that the key of
- a [Canonical] element is its own name, by keeping [Equiv] edges
- (see the assertion)... I (Stéphane Glondu) am not sure if this
- plays a role in the rest of the module. *)
-let normalize_universes g =
- let rec visit u arc cache = match lookup_level u cache with
- | Some x -> x, cache
- | None -> match Lazy.force arc with
- | None ->
- u, UMap.add u u cache
- | Some (Canonical {univ=v; lt=_; le=_}) ->
- v, UMap.add u v cache
- | Some (Equiv v) ->
- let v, cache = visit v (lazy (lookup_level v g)) cache in
- v, UMap.add u v cache
- in
- let cache = UMap.fold
- (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache))
- g UMap.empty
- in
- let repr x = UMap.find x cache in
- let lrepr us = List.fold_left
- (fun e x -> LSet.add (repr x) e) LSet.empty us
- in
- let canonicalize u = function
- | Equiv _ -> Equiv (repr u)
- | Canonical {univ=v; lt=lt; le=le; rank=rank} ->
- assert (u == v);
- (* avoid duplicates and self-loops *)
- let lt = lrepr lt and le = lrepr le in
- let le = LSet.filter
- (fun x -> x != u && not (LSet.mem x lt)) le
- in
- LSet.iter (fun x -> assert (x != u)) lt;
- Canonical {
- univ = v;
- lt = LSet.elements lt;
- le = LSet.elements le;
- rank = rank;
- status = Unset;
- }
- in
- UMap.mapi canonicalize g
-
-let constraints_of_universes g =
- let constraints_of u v acc =
- match v with
- | Canonical {univ=u; lt=lt; le=le} ->
- let acc = List.fold_left (fun acc v -> Constraint.add (u,Lt,v) acc) acc lt in
- let acc = List.fold_left (fun acc v -> Constraint.add (u,Le,v) acc) acc le in
- acc
- | Equiv v -> Constraint.add (u,Eq,v) acc
- in
- UMap.fold constraints_of g Constraint.empty
-
-let constraints_of_universes g =
- constraints_of_universes (normalize_universes g)
-
-(** Longest path algorithm. This is used to compute the minimal number of
- universes required if the only strict edge would be the Lt one. This
- algorithm assumes that the given universes constraints are a almost DAG, in
- the sense that there may be {Eq, Le}-cycles. This is OK for consistent
- universes, which is the only case where we use this algorithm. *)
-
-(** Adjacency graph *)
-type graph = constraint_type LMap.t LMap.t
-
-exception Connected
-
-(** Check connectedness *)
-let connected x y (g : graph) =
- let rec connected x target seen g =
- if Level.equal x target then raise Connected
- else if not (LSet.mem x seen) then
- let seen = LSet.add x seen in
- let fold z _ seen = connected z target seen g in
- let neighbours = try LMap.find x g with Not_found -> LMap.empty in
- LMap.fold fold neighbours seen
- else seen
- in
- try ignore(connected x y LSet.empty g); false with Connected -> true
-
-let add_edge x y v (g : graph) =
- try
- let neighbours = LMap.find x g in
- let neighbours = LMap.add y v neighbours in
- LMap.add x neighbours g
- with Not_found ->
- LMap.add x (LMap.singleton y v) g
-
-(** We want to keep the graph DAG. If adding an edge would cause a cycle, that
- would necessarily be an {Eq, Le}-cycle, otherwise there would have been a
- universe inconsistency. Therefore we may omit adding such a cycling edge
- without changing the compacted graph. *)
-let add_eq_edge x y v g = if connected y x g then g else add_edge x y v g
-
-(** Construct the DAG and its inverse at the same time. *)
-let make_graph g : (graph * graph) =
- let fold u arc accu = match arc with
- | Equiv v ->
- let (dir, rev) = accu in
- (add_eq_edge u v Eq dir, add_eq_edge v u Eq rev)
- | Canonical { univ; lt; le; } ->
- let () = assert (u == univ) in
- let fold_lt (dir, rev) v = (add_edge u v Lt dir, add_edge v u Lt rev) in
- let fold_le (dir, rev) v = (add_eq_edge u v Le dir, add_eq_edge v u Le rev) in
- (** Order is important : lt after le, because of the possible redundancy
- between [le] and [lt] in a canonical arc. This way, the [lt] constraint
- is the last one set, which is correct because it implies [le]. *)
- let accu = List.fold_left fold_le accu le in
- let accu = List.fold_left fold_lt accu lt in
- accu
- in
- UMap.fold fold g (LMap.empty, LMap.empty)
-
-(** Construct a topological order out of a DAG. *)
-let rec topological_fold u g rem seen accu =
- let is_seen =
- try
- let status = LMap.find u seen in
- assert status; (** If false, not a DAG! *)
- true
- with Not_found -> false
- in
- if not is_seen then
- let rem = LMap.remove u rem in
- let seen = LMap.add u false seen in
- let neighbours = try LMap.find u g with Not_found -> LMap.empty in
- let fold v _ (rem, seen, accu) = topological_fold v g rem seen accu in
- let (rem, seen, accu) = LMap.fold fold neighbours (rem, seen, accu) in
- (rem, LMap.add u true seen, u :: accu)
- else (rem, seen, accu)
-
-let rec topological g rem seen accu =
- let node = try Some (LMap.choose rem) with Not_found -> None in
- match node with
- | None -> accu
- | Some (u, _) ->
- let rem, seen, accu = topological_fold u g rem seen accu in
- topological g rem seen accu
-
-(** Compute the longest path from any vertex. *)
-let constraint_cost = function
-| Eq | Le -> 0
-| Lt -> 1
-
-(** This algorithm browses the graph in topological order, computing for each
- encountered node the length of the longest path leading to it. Should be
- O(|V|) or so (modulo map representation). *)
-let rec flatten_graph rem (rev : graph) map mx = match rem with
-| [] -> map, mx
-| u :: rem ->
- let prev = try LMap.find u rev with Not_found -> LMap.empty in
- let fold v cstr accu =
- let v_cost = LMap.find v map in
- max (v_cost + constraint_cost cstr) accu
- in
- let u_cost = LMap.fold fold prev 0 in
- let map = LMap.add u u_cost map in
- flatten_graph rem rev map (max mx u_cost)
-
-(** [sort_universes g] builds a map from universes in [g] to natural
- numbers. It outputs a graph containing equivalence edges from each
- level appearing in [g] to [Type.n], and [lt] edges between the
- [Type.n]s. The output graph should imply the input graph (and the
- [Type.n]s. The output graph should imply the input graph (and the
- implication will be strict most of the time), but is not
- necessarily minimal. Note: the result is unspecified if the input
- graph already contains [Type.n] nodes (calling a module Type is
- probably a bad idea anyway). *)
-let sort_universes orig =
- let (dir, rev) = make_graph orig in
- let order = topological dir dir LMap.empty [] in
- let compact, max = flatten_graph order rev LMap.empty 0 in
- let mp = Names.DirPath.make [Names.Id.of_string "Type"] in
- let types = Array.init (max + 1) (fun n -> Level.make mp n) in
- (** Old universes are made equal to [Type.n] *)
- let fold u level accu = UMap.add u (Equiv types.(level)) accu in
- let sorted = LMap.fold fold compact UMap.empty in
- (** Add all [Type.n] nodes *)
- let fold i accu u =
- if i < max then
- let pred = types.(i + 1) in
- let arc = {univ = u; lt = [pred]; le = []; rank = 0; status = Unset; } in
- UMap.add u (Canonical arc) accu
- else accu
- in
- Array.fold_left_i fold sorted types
-
(* Miscellaneous functions to remove or test local univ assumed to
occur in a universe *)
@@ -1645,7 +876,6 @@ module Instance : sig
val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds
val levels : t -> LSet.t
- val check_eq : t check_function
end =
struct
type t = Level.t array
@@ -1729,13 +959,6 @@ struct
(* Necessary as universe instances might come from different modules and
unmarshalling doesn't preserve sharing *))
- let check_eq g t1 t2 =
- t1 == t2 ||
- (Int.equal (Array.length t1) (Array.length t2) &&
- let rec aux i =
- (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1))
- in aux 0)
-
end
let enforce_eq_instances x y =
@@ -1991,27 +1214,6 @@ let abstract_universes poly ctx =
(** Pretty-printing *)
-let pr_arc prl = function
- | _, Canonical {univ=u; lt=[]; le=[]} ->
- mt ()
- | _, Canonical {univ=u; lt=lt; le=le} ->
- let opt_sep = match lt, le with
- | [], _ | _, [] -> mt ()
- | _ -> spc ()
- in
- prl u ++ str " " ++
- v 0
- (pr_sequence (fun v -> str "< " ++ prl v) lt ++
- opt_sep ++
- pr_sequence (fun v -> str "<= " ++ prl v) le) ++
- fnl ()
- | u, Equiv v ->
- prl u ++ str " = " ++ prl v ++ fnl ()
-
-let pr_universes prl g =
- let graph = UMap.fold (fun u a l -> (u,a)::l) g [] in
- prlist (pr_arc prl) graph
-
let pr_constraints prl = Constraint.pr prl
let pr_universe_context = UContext.pr
@@ -2024,19 +1226,6 @@ let pr_universe_subst =
let pr_universe_level_subst =
LMap.pr (fun u -> str" := " ++ Level.pr u ++ spc ())
-(* Dumping constraints to a file *)
-
-let dump_universes output g =
- let dump_arc u = function
- | Canonical {univ=u; lt=lt; le=le} ->
- let u_str = Level.to_string u in
- List.iter (fun v -> output Lt (Level.to_string v) u_str) lt;
- List.iter (fun v -> output Le (Level.to_string v) u_str) le
- | Equiv v ->
- output Eq (Level.to_string u) (Level.to_string v)
- in
- UMap.iter dump_arc g
-
module Huniverse_set =
Hashcons.Make(
struct
@@ -2084,26 +1273,3 @@ let subst_instance_constraints =
let key = Profile.declare_profile "subst_instance_constraints" in
Profile.profile2 key subst_instance_constraints
else subst_instance_constraints
-
-let merge_constraints =
- if Flags.profile then
- let key = Profile.declare_profile "merge_constraints" in
- Profile.profile2 key merge_constraints
- else merge_constraints
-let check_constraints =
- if Flags.profile then
- let key = Profile.declare_profile "check_constraints" in
- Profile.profile2 key check_constraints
- else check_constraints
-
-let check_eq =
- if Flags.profile then
- let check_eq_key = Profile.declare_profile "check_eq" in
- Profile.profile3 check_eq_key check_eq
- else check_eq
-
-let check_leq =
- if Flags.profile then
- let check_leq_key = Profile.declare_profile "check_leq" in
- Profile.profile3 check_leq_key check_leq
- else check_leq
diff --git a/kernel/univ.mli b/kernel/univ.mli
index c926c57bd..5682940a0 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -40,6 +40,9 @@ sig
val pr : t -> Pp.std_ppcmds
(** Pretty-printing *)
+ val to_string : t -> string
+ (** Debug printing *)
+
val var : int -> t
val var_index : t -> int option
@@ -115,6 +118,9 @@ sig
val type1 : t
(** the universe of the type of Prop/Set *)
+
+ val exists : (Level.t * int -> bool) -> t -> bool
+ val for_all : (Level.t * int -> bool) -> t -> bool
end
type universe = Universe.t
@@ -148,31 +154,6 @@ val univ_level_mem : universe_level -> universe -> bool
val univ_level_rem : universe_level -> universe -> universe -> universe
-(** {6 Graphs of universes. } *)
-
-type universes
-
-type 'a check_function = universes -> 'a -> 'a -> bool
-val check_leq : universe check_function
-val check_eq : universe check_function
-
-(** The empty graph of universes *)
-val empty_universes : universes
-
-(** The initial graph of universes: Prop < Set *)
-val initial_universes : universes
-
-val is_initial_universes : universes -> bool
-
-val sort_universes : universes -> universes
-
-(** Adds a universe to the graph, ensuring it is >= or > Set.
- @raises AlreadyDeclared if the level is already declared in the graph. *)
-
-exception AlreadyDeclared
-
-val add_universe : universe_level -> bool -> universes -> universes
-
(** {6 Constraints. } *)
type constraint_type = Lt | Le | Eq
@@ -203,12 +184,6 @@ val enforce_leq : universe constraint_function
val enforce_eq_level : universe_level constraint_function
val enforce_leq_level : universe_level constraint_function
-(** {6 ... } *)
-(** Merge of constraints in a universes graph.
- The function [merge_constraints] merges a set of constraints in a given
- universes graph. It raises the exception [UniverseInconsistency] if the
- constraints are not satisfiable. *)
-
(** Type explanation is used to decorate error messages to provide
useful explanation why a given constraint is rejected. It is composed
of a path of universes and relation kinds [(r1,u1);..;(rn,un)] means
@@ -226,14 +201,6 @@ type univ_inconsistency = constraint_type * universe * universe * explanation op
exception UniverseInconsistency of univ_inconsistency
-val enforce_constraint : univ_constraint -> universes -> universes
-val merge_constraints : constraints -> universes -> universes
-
-val constraints_of_universes : universes -> constraints
-
-val check_constraint : universes -> univ_constraint -> bool
-val check_constraints : constraints -> universes -> bool
-
(** {6 Support for universe polymorphism } *)
(** Polymorphic maps from universe levels to 'a *)
@@ -309,8 +276,6 @@ sig
val levels : t -> LSet.t
(** The set of levels in the instance *)
- val check_eq : t check_function
- (** Check equality of instances w.r.t. a universe graph *)
end
type universe_instance = Instance.t
@@ -428,7 +393,6 @@ val instantiate_univ_constraints : universe_instance -> universe_context -> cons
(** {6 Pretty-printing of universes. } *)
-val pr_universes : (Level.t -> Pp.std_ppcmds) -> universes -> Pp.std_ppcmds
val pr_constraint_type : constraint_type -> Pp.std_ppcmds
val pr_constraints : (Level.t -> Pp.std_ppcmds) -> constraints -> Pp.std_ppcmds
val pr_universe_context : (Level.t -> Pp.std_ppcmds) -> universe_context -> Pp.std_ppcmds
@@ -439,12 +403,6 @@ val explain_universe_inconsistency : (Level.t -> Pp.std_ppcmds) ->
val pr_universe_level_subst : universe_level_subst -> Pp.std_ppcmds
val pr_universe_subst : universe_subst -> Pp.std_ppcmds
-(** {6 Dumping to a file } *)
-
-val dump_universes :
- (constraint_type -> string -> string -> unit) ->
- universes -> unit
-
(** {6 Hash-consing } *)
val hcons_univ : universe -> universe
diff --git a/lib/cMap.ml b/lib/cMap.ml
index cf590d96c..876f84736 100644
--- a/lib/cMap.ml
+++ b/lib/cMap.ml
@@ -12,6 +12,13 @@ sig
val compare : t -> t -> int
end
+module type MonadS =
+sig
+ type +'a t
+ val return : 'a -> 'a t
+ val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
module type S = Map.S
module type ExtS =
@@ -30,6 +37,12 @@ sig
sig
val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t
end
+ module Monad(M : MonadS) :
+ sig
+ val fold : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+ val fold_left : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+ val fold_right : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+ end
end
module MapExt (M : Map.OrderedType) :
@@ -47,6 +60,12 @@ sig
sig
val map : (M.t -> 'a -> M.t * 'b) -> 'a map -> 'b map
end
+ module Monad(MS : MonadS) :
+ sig
+ val fold : (M.t -> 'a -> 'b -> 'b MS.t) -> 'a map -> 'b -> 'b MS.t
+ val fold_left : (M.t -> 'a -> 'b -> 'b MS.t) -> 'a map -> 'b -> 'b MS.t
+ val fold_right : (M.t -> 'a -> 'b -> 'b MS.t) -> 'a map -> 'b -> 'b MS.t
+ end
end =
struct
(** This unsafe module is a way to access to the actual implementations of
@@ -159,6 +178,29 @@ struct
end
+ module Monad(M : MonadS) =
+ struct
+
+ open M
+
+ let rec fold_left f s accu = match map_prj s with
+ | MEmpty -> return accu
+ | MNode (l, k, v, r, h) ->
+ fold_left f l accu >>= fun accu ->
+ f k v accu >>= fun accu ->
+ fold_left f r accu
+
+ let rec fold_right f s accu = match map_prj s with
+ | MEmpty -> return accu
+ | MNode (l, k, v, r, h) ->
+ fold_right f r accu >>= fun accu ->
+ f k v accu >>= fun accu ->
+ fold_right f l accu
+
+ let fold = fold_left
+
+ end
+
end
module Make(M : Map.OrderedType) =
diff --git a/lib/cMap.mli b/lib/cMap.mli
index 23d3801e0..cd3d2f5b1 100644
--- a/lib/cMap.mli
+++ b/lib/cMap.mli
@@ -14,6 +14,13 @@ sig
val compare : t -> t -> int
end
+module type MonadS =
+sig
+ type +'a t
+ val return : 'a -> 'a t
+ val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
module type S = Map.S
module type ExtS =
@@ -59,6 +66,14 @@ sig
i.e.: for all (k : key) (x : 'a), compare (fst (f k x)) k = 0. *)
end
+ module Monad(M : MonadS) :
+ sig
+ val fold : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+ val fold_left : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+ val fold_right : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t
+ end
+ (** Fold operators parameterized by any monad. *)
+
end
module Make(M : Map.OrderedType) : ExtS with
diff --git a/lib/envars.ml b/lib/envars.ml
index b0eed8386..bafe2401b 100644
--- a/lib/envars.ml
+++ b/lib/envars.ml
@@ -143,23 +143,12 @@ let coqpath =
let exe s = s ^ Coq_config.exec_extension
-let guess_camlbin () = which (user_path ()) (exe "ocamlc")
+let guess_ocamlfind () = which (user_path ()) (exe "ocamlfind")
-let camlbin () =
- if !Flags.camlbin_spec then !Flags.camlbin else
- if !Flags.boot then Coq_config.camlbin else
- try guess_camlbin () with Not_found -> Coq_config.camlbin
-
-let ocamlc () = camlbin () / Coq_config.ocamlc
-
-let ocamlopt () = camlbin () / Coq_config.ocamlopt
-
-let camllib () =
- if !Flags.boot then
- Coq_config.camllib
- else
- let _, res = CUnix.run_command (ocamlc () ^ " -where") in
- String.strip res
+let ocamlfind () =
+ if !Flags.ocamlfind_spec then !Flags.ocamlfind else
+ if !Flags.boot then Coq_config.ocamlfind else
+ try guess_ocamlfind () / "ocamlfind" with Not_found -> Coq_config.ocamlfind
(** {2 Camlp4 paths} *)
@@ -170,9 +159,7 @@ let camlp4bin () =
if !Flags.boot then Coq_config.camlp4bin else
try guess_camlp4bin ()
with Not_found ->
- let cb = camlbin () in
- if Sys.file_exists (cb / exe Coq_config.camlp4) then cb
- else Coq_config.camlp4bin
+ Coq_config.camlp4bin
let camlp4 () = camlp4bin () / exe Coq_config.camlp4
@@ -180,7 +167,7 @@ let camlp4lib () =
if !Flags.boot then
Coq_config.camlp4lib
else
- let ex, res = CUnix.run_command (camlp4 () ^ " -where") in
+ let ex, res = CUnix.run_command (ocamlfind () ^ " query " ^ Coq_config.camlp4) in
match ex with
| Unix.WEXITED 0 -> String.strip res
| _ -> "/dev/null"
diff --git a/lib/envars.mli b/lib/envars.mli
index b62b9f28a..7c20c035a 100644
--- a/lib/envars.mli
+++ b/lib/envars.mli
@@ -47,17 +47,8 @@ val coqroot : string
the order it gets added to the search path. *)
val coqpath : string list
-(** [camlbin ()] is the path to the ocaml binaries. *)
-val camlbin : unit -> string
-
-(** [camllib ()] is the path to the ocaml standard library. *)
-val camllib : unit -> string
-
-(** [ocamlc ()] is the ocaml bytecode compiler that compiled this Coq. *)
-val ocamlc : unit -> string
-
-(** [ocamlc ()] is the ocaml native compiler that compiled this Coq. *)
-val ocamlopt : unit -> string
+(** [camlbin ()] is the path to the ocamlfind binary. *)
+val ocamlfind : unit -> string
(** [camlp4bin ()] is the path to the camlp4 binary. *)
val camlp4bin : unit -> string
diff --git a/lib/feedback.ml b/lib/feedback.ml
index a5e16ea04..1726da2fd 100644
--- a/lib/feedback.ml
+++ b/lib/feedback.ml
@@ -18,7 +18,7 @@ type message_level =
type message = {
message_level : message_level;
- message_content : string;
+ message_content : xml;
}
let of_message_level = function
@@ -39,12 +39,12 @@ let to_message_level =
let of_message msg =
let lvl = of_message_level msg.message_level in
- let content = Serialize.of_string msg.message_content in
+ let content = Serialize.of_xml msg.message_content in
Xml_datatype.Element ("message", [], [lvl; content])
let to_message xml = match xml with
| Xml_datatype.Element ("message", [], [lvl; content]) -> {
message_level = to_message_level lvl;
- message_content = Serialize.to_string content }
+ message_content = Serialize.to_xml content }
| _ -> raise Serialize.Marshal_error
let is_message = function
diff --git a/lib/feedback.mli b/lib/feedback.mli
index 52a0e9fe6..38c867f5b 100644
--- a/lib/feedback.mli
+++ b/lib/feedback.mli
@@ -18,7 +18,7 @@ type message_level =
type message = {
message_level : message_level;
- message_content : string;
+ message_content : xml;
}
val of_message : message -> xml
diff --git a/lib/flags.ml b/lib/flags.ml
index ab4ac03f8..9a0d4b5ec 100644
--- a/lib/flags.ml
+++ b/lib/flags.ml
@@ -193,9 +193,9 @@ let is_standard_doc_url url =
let coqlib_spec = ref false
let coqlib = ref "(not initialized yet)"
-(* Options for changing camlbin (used by coqmktop) *)
-let camlbin_spec = ref false
-let camlbin = ref Coq_config.camlbin
+(* Options for changing ocamlfind (used by coqmktop) *)
+let ocamlfind_spec = ref false
+let ocamlfind = ref Coq_config.camlbin
(* Options for changing camlp4bin (used by coqmktop) *)
let camlp4bin_spec = ref false
diff --git a/lib/flags.mli b/lib/flags.mli
index 8e3713656..29a0bbef0 100644
--- a/lib/flags.mli
+++ b/lib/flags.mli
@@ -120,8 +120,8 @@ val coqlib_spec : bool ref
val coqlib : string ref
(** Options for specifying where OCaml binaries reside *)
-val camlbin_spec : bool ref
-val camlbin : string ref
+val ocamlfind_spec : bool ref
+val ocamlfind : string ref
val camlp4bin_spec : bool ref
val camlp4bin : string ref
diff --git a/lib/hMap.ml b/lib/hMap.ml
index f902eded0..8e900cd58 100644
--- a/lib/hMap.ml
+++ b/lib/hMap.ml
@@ -329,4 +329,18 @@ struct
Int.Map.map fs s
end
+ module Monad(M : CMap.MonadS) =
+ struct
+ module IntM = Int.Map.Monad(M)
+ module ExtM = Map.Monad(M)
+ open M
+
+ let fold f s accu =
+ let ff _ m accu = ExtM.fold f m accu in
+ IntM.fold ff s accu
+
+ let fold_left _ _ _ = assert false
+ let fold_right _ _ _ = assert false
+ end
+
end
diff --git a/lib/pp.ml b/lib/pp.ml
index 4ed4b1779..146d3562d 100644
--- a/lib/pp.ml
+++ b/lib/pp.ml
@@ -412,7 +412,7 @@ type message_level = Feedback.message_level =
type message = Feedback.message = {
message_level : message_level;
- message_content : string;
+ message_content : Xml_datatype.xml;
}
let of_message = Feedback.of_message
@@ -511,11 +511,11 @@ let string_of_ppcmds c =
msg_with Format.str_formatter c;
Format.flush_str_formatter ()
-let log_via_feedback () = logger := (fun ~id lvl msg ->
+let log_via_feedback printer = logger := (fun ~id lvl msg ->
!feeder {
Feedback.contents = Feedback.Message {
message_level = lvl;
- message_content = string_of_ppcmds msg };
+ message_content = printer msg };
Feedback.route = !feedback_route;
Feedback.id = id })
diff --git a/lib/pp.mli b/lib/pp.mli
index 3b1123a9d..d034e6761 100644
--- a/lib/pp.mli
+++ b/lib/pp.mli
@@ -116,7 +116,7 @@ type message_level = Feedback.message_level =
type message = Feedback.message = {
message_level : message_level;
- message_content : string;
+ message_content : Xml_datatype.xml;
}
type logger = message_level -> std_ppcmds -> unit
@@ -154,7 +154,7 @@ val std_logger : logger
val set_logger : logger -> unit
-val log_via_feedback : unit -> unit
+val log_via_feedback : (std_ppcmds -> Xml_datatype.xml) -> unit
val of_message : message -> Xml_datatype.xml
val to_message : Xml_datatype.xml -> message
diff --git a/lib/richpp.ml b/lib/richpp.ml
index c4a9c39d5..fff989ce0 100644
--- a/lib/richpp.ml
+++ b/lib/richpp.ml
@@ -163,4 +163,38 @@ let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml =
in
node xml
+type richpp = xml
+let repr xml = xml
+let richpp_of_xml xml = xml
+let richpp_of_string s = PCData s
+
+let richpp_of_pp pp =
+ let annotate t = match Pp.Tag.prj t Ppstyle.tag with
+ | None -> None
+ | Some key -> Some (Ppstyle.repr key)
+ in
+ let rec drop = function
+ | PCData s -> [PCData s]
+ | Element (_, annotation, cs) ->
+ let cs = List.concat (List.map drop cs) in
+ match annotation.annotation with
+ | None -> cs
+ | Some s -> [Element (String.concat "." s, [], cs)]
+ in
+ let xml = rich_pp annotate pp in
+ Element ("_", [], drop xml)
+
+let raw_print xml =
+ let buf = Buffer.create 1024 in
+ let rec print = function
+ | PCData s -> Buffer.add_string buf s
+ | Element (_, _, cs) -> List.iter print cs
+ in
+ let () = print xml in
+ Buffer.contents buf
+
+let of_richpp x = Element ("richpp", [], [x])
+let to_richpp xml = match xml with
+| Element ("richpp", [], [x]) -> x
+| _ -> raise Serialize.Marshal_error
diff --git a/lib/richpp.mli b/lib/richpp.mli
index a0d3c374b..7e4b58c9a 100644
--- a/lib/richpp.mli
+++ b/lib/richpp.mli
@@ -39,3 +39,29 @@ val xml_of_rich_pp :
('annotation -> (string * string) list) ->
'annotation located Xml_datatype.gxml ->
Xml_datatype.xml
+
+(** {5 Enriched text} *)
+
+type richpp
+(** Type of text with style annotations *)
+
+val richpp_of_pp : Pp.std_ppcmds -> richpp
+(** Extract style information from formatted text *)
+
+val richpp_of_xml : Xml_datatype.xml -> richpp
+(** Do not use outside of dedicated areas *)
+
+val richpp_of_string : string -> richpp
+(** Make a styled text out of a normal string *)
+
+val repr : richpp -> Xml_datatype.xml
+(** Observe the styled text as XML *)
+
+(** {5 Serialization} *)
+
+val of_richpp : richpp -> Xml_datatype.xml
+val to_richpp : Xml_datatype.xml -> richpp
+
+(** Represent the semi-structured document as a string, dropping any additional
+ information. *)
+val raw_print : richpp -> string
diff --git a/lib/serialize.ml b/lib/serialize.ml
index aa2e3f02a..b14bfb283 100644
--- a/lib/serialize.ml
+++ b/lib/serialize.ml
@@ -114,3 +114,7 @@ let to_loc xml =
with Not_found | Invalid_argument _ -> raise Marshal_error)
| _ -> raise Marshal_error
+let of_xml x = Element ("xml", [], [x])
+let to_xml xml = match xml with
+| Element ("xml", [], [x]) -> x
+| _ -> raise Marshal_error
diff --git a/lib/serialize.mli b/lib/serialize.mli
index 34d3e054c..f4eac5a6b 100644
--- a/lib/serialize.mli
+++ b/lib/serialize.mli
@@ -35,3 +35,5 @@ val of_edit_id: int -> xml
val to_edit_id: xml -> int
val of_loc : Loc.t -> xml
val to_loc : xml -> Loc.t
+val of_xml : xml -> xml
+val to_xml : xml -> xml
diff --git a/lib/system.ml b/lib/system.ml
index ddc56956c..7a62d5603 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -13,44 +13,85 @@ open Errors
open Util
open Unix
-(* All subdirectories, recursively *)
+(** Dealing with directories *)
-let exists_dir dir =
- try let _ = closedir (opendir dir) in true with Unix_error _ -> false
+type unix_path = string (* path in unix-style, with '/' separator *)
+
+type file_kind =
+ | FileDir of unix_path * (* basename of path: *) string
+ | FileRegular of string (* basename of file *)
+
+(* Copy of Filename.concat but assuming paths to always be POSIX *)
+
+let (//) dirname filename =
+ let l = String.length dirname in
+ if l = 0 || dirname.[l-1] = '/'
+ then dirname ^ filename
+ else dirname ^ "/" ^ filename
+
+(* Excluding directories; We avoid directories starting with . as well
+ as CVS and _darcs and any subdirs given via -exclude-dir *)
let skipped_dirnames = ref ["CVS"; "_darcs"]
-let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames
+let exclude_directory f = skipped_dirnames := f :: !skipped_dirnames
let ok_dirname f =
- not (String.is_empty f) && f.[0] != '.' &&
- not (String.List.mem f !skipped_dirnames) &&
- (match Unicode.ident_refutation f with None -> true | _ -> false)
+ not (f = "") && f.[0] != '.' &&
+ not (List.mem f !skipped_dirnames) (*&&
+ (match Unicode.ident_refutation f with None -> true | _ -> false)*)
+
+(* Check directory can be opened *)
+
+let exists_dir dir =
+ try let _ = closedir (opendir dir) in true with Unix_error _ -> false
+
+let check_unix_dir warn dir =
+ if (Sys.os_type = "Win32" || Sys.os_type = "Cygwin") &&
+ (String.length dir > 2 && dir.[1] = ':' ||
+ String.contains dir '\\' ||
+ String.contains dir ';')
+ then warn ("assuming " ^ dir ^
+ " to be a Unix path even if looking like a Win32 path.")
+
+let apply_subdir f path name =
+ (* we avoid all files and subdirs starting by '.' (e.g. .svn) *)
+ (* as well as skipped files like CVS, ... *)
+ if name.[0] <> '.' && ok_dirname name then
+ let path = if path = "." then name else path//name in
+ match try (stat path).st_kind with Unix_error _ -> S_BLK with
+ | S_DIR -> f (FileDir (path,name))
+ | S_REG -> f (FileRegular name)
+ | _ -> ()
+
+let process_directory f path =
+ let dirh = opendir path in
+ try while true do apply_subdir f path (readdir dirh) done
+ with End_of_file -> closedir dirh
+
+let process_subdirectories f path =
+ let f = function FileDir (path,base) -> f path base | FileRegular _ -> () in
+ process_directory f path
+
+(** Returns the list of all recursive subdirectories of [root] in
+ depth-first search, with sons ordered as on the file system;
+ warns if [root] does not exist *)
let all_subdirs ~unix_path:root =
let l = ref [] in
let add f rel = l := (f, rel) :: !l in
- let rec traverse dir rel =
- let dirh = opendir dir in
- try
- while true do
- let f = readdir dirh in
- if ok_dirname f then
- let file = Filename.concat dir f in
- try
- begin match (stat file).st_kind with
- | S_DIR ->
- let newrel = rel @ [f] in
- add file newrel;
- traverse file newrel
- | _ -> ()
- end
- with Unix_error (e,s1,s2) -> ()
- done
- with End_of_file ->
- closedir dirh
+ let rec traverse path rel =
+ let f = function
+ | FileDir (path,f) ->
+ let newrel = rel @ [f] in
+ add path newrel;
+ traverse path newrel
+ | _ -> ()
+ in process_directory f path
in
- if exists_dir root then traverse root [];
+ check_unix_dir (fun s -> msg_warning (str s)) root;
+ if exists_dir root then traverse root []
+ else msg_warning (str ("Cannot open " ^ root));
List.rev !l
let rec search paths test =
diff --git a/lib/system.mli b/lib/system.mli
index 247d528b9..2e773fe96 100644
--- a/lib/system.mli
+++ b/lib/system.mli
@@ -8,14 +8,46 @@
(** {5 Coqtop specific system utilities} *)
+(** {6 Directories} *)
+
+type unix_path = string (* path in unix-style, with '/' separator *)
+
+type file_kind =
+ | FileDir of unix_path * (* basename of path: *) string
+ | FileRegular of string (* basename of file *)
+
+val (//) : unix_path -> string -> unix_path
+
+val exists_dir : unix_path -> bool
+
+(** [check_unix_dir warn path] calls [warn] with an appropriate
+ message if [path] looks does not look like a Unix path on Windows *)
+
+val check_unix_dir : (string -> unit) -> unix_path -> unit
+
+(** [exclude_search_in_dirname path] excludes [path] when processing
+ directories *)
+
+val exclude_directory : unix_path -> unit
+
+(** [process_directory f path] applies [f] on contents of directory
+ [path]; fails with Unix_error if the latter does not exists; skips
+ all files or dirs starting with "." *)
+
+val process_directory : (file_kind -> unit) -> unix_path -> unit
+
+(** [process_subdirectories f path] applies [f path/file file] on each
+ [file] of the directory [path]; fails with Unix_error if the
+ latter does not exists; kips all files or dirs starting with "." *)
+
+val process_subdirectories : (unix_path -> string -> unit) -> unix_path -> unit
+
(** {6 Files and load paths} *)
(** Load path entries remember the original root
given by the user. For efficiency, we keep the full path (field
[directory]), the root path and the path relative to the root. *)
-val exclude_search_in_dirname : string -> unit
-
val all_subdirs : unix_path:string -> (CUnix.physical_path * string list) list
val is_in_path : CUnix.load_path -> string -> bool
val is_in_system_path : string -> bool
@@ -24,8 +56,6 @@ val where_in_path :
val where_in_path_rex :
CUnix.load_path -> Str.regexp -> (CUnix.physical_path * string) list
-val exists_dir : string -> bool
-
val find_file_in_path :
?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string
diff --git a/library/global.mli b/library/global.mli
index 03469bea4..09ed4eb0a 100644
--- a/library/global.mli
+++ b/library/global.mli
@@ -19,7 +19,7 @@ val env : unit -> Environ.env
val env_is_initial : unit -> bool
-val universes : unit -> Univ.universes
+val universes : unit -> UGraph.t
val named_context_val : unit -> Environ.named_context_val
val named_context : unit -> Context.named_context
diff --git a/library/universes.ml b/library/universes.ml
index 6cccb10ef..504a682fc 100644
--- a/library/universes.ml
+++ b/library/universes.ml
@@ -135,7 +135,7 @@ let to_constraints g s =
| _, ULe, Some l' -> enforce_leq x y acc
| _, ULub, _ -> acc
| _, d, _ ->
- let f = if d == ULe then check_leq else check_eq in
+ let f = if d == ULe then UGraph.check_leq else UGraph.check_eq in
if f g x y then acc else
raise (Invalid_argument
"to_constraints: non-trivial algebraic constraint between universes")
@@ -145,12 +145,12 @@ let eq_constr_univs_infer univs m n =
if m == n then true, Constraints.empty
else
let cstrs = ref Constraints.empty in
- let eq_universes strict = Univ.Instance.check_eq univs in
+ let eq_universes strict = UGraph.check_eq_instances univs in
let eq_sorts s1 s2 =
if Sorts.equal s1 s2 then true
else
let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
- if Univ.check_eq univs u1 u2 then true
+ if UGraph.check_eq univs u1 u2 then true
else
(cstrs := Constraints.add (u1, UEq, u2) !cstrs;
true)
@@ -171,12 +171,12 @@ let eq_constr_univs_infer_with kind1 kind2 univs m n =
[kind1,kind2], because [kind1] and [kind2] may be different,
typically evaluating [m] and [n] in different evar maps. *)
let cstrs = ref Constraints.empty in
- let eq_universes strict = Univ.Instance.check_eq univs in
+ let eq_universes strict = UGraph.check_eq_instances univs in
let eq_sorts s1 s2 =
if Sorts.equal s1 s2 then true
else
let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
- if Univ.check_eq univs u1 u2 then true
+ if UGraph.check_eq univs u1 u2 then true
else
(cstrs := Constraints.add (u1, UEq, u2) !cstrs;
true)
@@ -191,12 +191,12 @@ let leq_constr_univs_infer univs m n =
if m == n then true, Constraints.empty
else
let cstrs = ref Constraints.empty in
- let eq_universes strict l l' = Univ.Instance.check_eq univs l l' in
+ let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in
let eq_sorts s1 s2 =
if Sorts.equal s1 s2 then true
else
let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
- if Univ.check_eq univs u1 u2 then true
+ if UGraph.check_eq univs u1 u2 then true
else (cstrs := Constraints.add (u1, UEq, u2) !cstrs;
true)
in
@@ -204,7 +204,7 @@ let leq_constr_univs_infer univs m n =
if Sorts.equal s1 s2 then true
else
let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
- if Univ.check_leq univs u1 u2 then
+ if UGraph.check_leq univs u1 u2 then
((if Univ.is_small_univ u1 then
cstrs := Constraints.add (u1, ULe, u2) !cstrs);
true)
@@ -869,27 +869,27 @@ let normalize_context_set ctx us algs =
let csts =
(* We first put constraints in a normal-form: all self-loops are collapsed
to equalities. *)
- let g = Univ.LSet.fold (fun v g -> Univ.add_universe v false g)
- ctx Univ.empty_universes
+ let g = Univ.LSet.fold (fun v g -> UGraph.add_universe v false g)
+ ctx UGraph.empty_universes
in
let g =
Univ.Constraint.fold
(fun (l, d, r) g ->
let g =
if not (Level.is_small l || LSet.mem l ctx) then
- try Univ.add_universe l false g
- with Univ.AlreadyDeclared -> g
+ try UGraph.add_universe l false g
+ with UGraph.AlreadyDeclared -> g
else g
in
let g =
if not (Level.is_small r || LSet.mem r ctx) then
- try Univ.add_universe r false g
- with Univ.AlreadyDeclared -> g
+ try UGraph.add_universe r false g
+ with UGraph.AlreadyDeclared -> g
else g
in g) csts g
in
- let g = Univ.Constraint.fold Univ.enforce_constraint csts g in
- Univ.constraints_of_universes g
+ let g = Univ.Constraint.fold UGraph.enforce_constraint csts g in
+ UGraph.constraints_of_universes g
in
let noneqs =
Constraint.fold (fun (l,d,r as cstr) noneqs ->
@@ -1021,7 +1021,7 @@ let refresh_constraints univs (ctx, cstrs) =
Univ.Constraint.fold (fun c (cstrs', univs as acc) ->
let c = translate_cstr c in
if is_trivial_leq c then acc
- else (Univ.Constraint.add c cstrs', Univ.enforce_constraint c univs))
+ else (Univ.Constraint.add c cstrs', UGraph.enforce_constraint c univs))
cstrs (Univ.Constraint.empty, univs)
in ((ctx, cstrs'), univs')
diff --git a/library/universes.mli b/library/universes.mli
index 45672ef46..285580be2 100644
--- a/library/universes.mli
+++ b/library/universes.mli
@@ -71,11 +71,11 @@ val subst_univs_universe_constraints : universe_subst_fn ->
val enforce_eq_instances_univs : bool -> universe_instance universe_constraint_function
-val to_constraints : universes -> universe_constraints -> constraints
+val to_constraints : UGraph.t -> universe_constraints -> constraints
(** [eq_constr_univs_infer u a b] is [true, c] if [a] equals [b] modulo alpha, casts,
application grouping, the universe constraints in [u] and additional constraints [c]. *)
-val eq_constr_univs_infer : Univ.universes -> constr -> constr -> bool universe_constrained
+val eq_constr_univs_infer : UGraph.t -> constr -> constr -> bool universe_constrained
(** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of
{!eq_constr_univs_infer} taking kind-of-term functions, to expose
@@ -83,12 +83,12 @@ val eq_constr_univs_infer : Univ.universes -> constr -> constr -> bool universe_
val eq_constr_univs_infer_with :
(constr -> (constr,types) kind_of_term) ->
(constr -> (constr,types) kind_of_term) ->
- Univ.universes -> constr -> constr -> bool universe_constrained
+ UGraph.t -> constr -> constr -> bool universe_constrained
(** [leq_constr_univs u a b] is [true, c] if [a] is convertible to [b]
modulo alpha, casts, application grouping, the universe constraints
in [u] and additional constraints [c]. *)
-val leq_constr_univs_infer : Univ.universes -> constr -> constr -> bool universe_constrained
+val leq_constr_univs_infer : UGraph.t -> constr -> constr -> bool universe_constrained
(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts,
application grouping and the universe constraints in [c]. *)
@@ -223,7 +223,7 @@ val restrict_universe_context : universe_context_set -> universe_set -> universe
val simplify_universe_context : universe_context_set ->
universe_context_set * universe_level_subst
-val refresh_constraints : universes -> universe_context_set -> universe_context_set * universes
+val refresh_constraints : UGraph.t -> universe_context_set -> universe_context_set * UGraph.t
(** Pretty-printing *)
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
index 097a10425..73ef7e1ed 100644
--- a/myocamlbuild.ml
+++ b/myocamlbuild.ml
@@ -104,7 +104,7 @@ let _build = Options.build_dir
let core_libs =
["lib/clib"; "lib/lib"; "kernel/kernel"; "library/library";
- "pretyping/pretyping"; "interp/interp"; "proofs/proofs";
+ "engine/engine"; "pretyping/pretyping"; "interp/interp"; "proofs/proofs";
"parsing/parsing"; "printing/printing"; "tactics/tactics";
"stm/stm"; "toplevel/toplevel"; "parsing/highparsing";
"tactics/hightactics"]
diff --git a/parsing/compat.ml4 b/parsing/compat.ml4
index eba1d2b8f..4208fd364 100644
--- a/parsing/compat.ml4
+++ b/parsing/compat.ml4
@@ -238,6 +238,69 @@ end
END
+(** Some definitions are grammar-specific in Camlp4, so we use a functor to
+ depend on it while taking a dummy argument in Camlp5. *)
+
+module GramextMake (G : GrammarSig) :
+sig
+ val stoken : Tok.t -> G.symbol
+ val sself : G.symbol
+ val snext : G.symbol
+ val slist0 : G.symbol -> G.symbol
+ val slist0sep : G.symbol * G.symbol -> G.symbol
+ val slist1 : G.symbol -> G.symbol
+ val slist1sep : G.symbol * G.symbol -> G.symbol
+ val sopt : G.symbol -> G.symbol
+ val snterml : G.internal_entry * string -> G.symbol
+ val snterm : G.internal_entry -> G.symbol
+ val snterml_level : G.symbol -> string
+end =
+struct
+
+IFDEF CAMLP5 THEN
+ let stoken tok =
+ let pattern = match tok with
+ | Tok.KEYWORD s -> "", s
+ | Tok.IDENT s -> "IDENT", s
+ | Tok.METAIDENT s -> "METAIDENT", s
+ | Tok.PATTERNIDENT s -> "PATTERNIDENT", s
+ | Tok.FIELD s -> "FIELD", s
+ | Tok.INT s -> "INT", s
+ | Tok.STRING s -> "STRING", s
+ | Tok.LEFTQMARK -> "LEFTQMARK", ""
+ | Tok.BULLET s -> "BULLET", s
+ | Tok.EOI -> "EOI", ""
+ in
+ Gramext.Stoken pattern
+ELSE
+ module Gramext = G
+ let stoken tok = match tok with
+ | Tok.KEYWORD s -> Gramext.Skeyword s
+ | tok -> Gramext.Stoken ((=) tok, G.Token.to_string tok)
+END
+
+IFDEF CAMLP5_6_00 THEN
+ let slist0sep (x, y) = Gramext.Slist0sep (x, y, false)
+ let slist1sep (x, y) = Gramext.Slist1sep (x, y, false)
+ELSE
+ let slist0sep (x, y) = Gramext.Slist0sep (x, y)
+ let slist1sep (x, y) = Gramext.Slist1sep (x, y)
+END
+
+ let snterml (x, y) = Gramext.Snterml (x, y)
+ let snterm x = Gramext.Snterm x
+ let sself = Gramext.Sself
+ let snext = Gramext.Snext
+ let slist0 x = Gramext.Slist0 x
+ let slist1 x = Gramext.Slist1 x
+ let sopt x = Gramext.Sopt x
+
+ let snterml_level = function
+ | Gramext.Snterml (_, l) -> l
+ | _ -> failwith "snterml_level"
+
+end
+
(** Misc functional adjustments *)
@@ -323,3 +386,11 @@ let qualified_name loc path name =
let path = List.fold_right fold path (Ast.IdLid (loc, name)) in
Ast.ExId (loc, path)
END
+
+IFDEF CAMLP5 THEN
+let warning_verbose = Gramext.warning_verbose
+ELSE
+(* TODO: this is a workaround, since there isn't such
+ [warning_verbose] in new camlp4. *)
+let warning_verbose = ref true
+END
diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml
index 01194c60d..84736f8ab 100644
--- a/parsing/egramcoq.ml
+++ b/parsing/egramcoq.ml
@@ -167,10 +167,9 @@ let rec make_constr_prod_item assoc from forpat = function
[]
let prepare_empty_levels forpat (pos,p4assoc,name,reinit) =
- let entry =
- if forpat then weaken_entry Constr.pattern
- else weaken_entry Constr.operconstr in
- grammar_extend entry reinit (pos,[(name, p4assoc, [])])
+ let empty = (pos, [(name, p4assoc, [])]) in
+ if forpat then grammar_extend Constr.pattern reinit empty
+ else grammar_extend Constr.operconstr reinit empty
let pure_sublevels level symbs =
let filter s =
@@ -189,13 +188,10 @@ let extend_constr (entry,level) (n,assoc) mkact forpat rules =
let symbs = make_constr_prod_item assoc n forpat pt in
let pure_sublevels = pure_sublevels level symbs in
let needed_levels = register_empty_levels forpat pure_sublevels in
- let map_level (pos, ass1, name, ass2) =
- (Option.map of_coq_position pos, Option.map of_coq_assoc ass1, name, ass2) in
- let needed_levels = List.map map_level needed_levels in
let pos,p4assoc,name,reinit = find_position forpat assoc level in
let nb_decls = List.length needed_levels + 1 in
List.iter (prepare_empty_levels forpat) needed_levels;
- grammar_extend entry reinit (Option.map of_coq_position pos,
+ unsafe_grammar_extend entry reinit (Option.map of_coq_position pos,
[(name, Option.map of_coq_assoc p4assoc, [symbs, mkact pt])]);
nb_decls) 0 rules
@@ -233,11 +229,11 @@ let extend_constr_notation ng =
let get_tactic_entry n =
if Int.equal n 0 then
- weaken_entry Tactic.simple_tactic, None
+ Tactic.simple_tactic, None
else if Int.equal n 5 then
- weaken_entry Tactic.binder_tactic, None
+ Tactic.binder_tactic, None
else if 1<=n && n<5 then
- weaken_entry Tactic.tactic_expr, Some (Extend.Level (string_of_int n))
+ Tactic.tactic_expr, Some (Extend.Level (string_of_int n))
else
error ("Invalid Tactic Notation level: "^(string_of_int n)^".")
@@ -246,22 +242,26 @@ let get_tactic_entry n =
type tactic_grammar = {
tacgram_level : int;
- tacgram_prods : grammar_prod_item list;
+ tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list;
}
type all_grammar_command =
| Notation of Notation.level * notation_grammar
| TacticGrammar of KerName.t * tactic_grammar
- | MLTacticGrammar of ml_tactic_name * grammar_prod_item list list
+ | MLTacticGrammar of ml_tactic_name * Tacexpr.raw_tactic_expr grammar_prod_item list list
(** ML Tactic grammar extensions *)
let add_ml_tactic_entry name prods =
- let entry = weaken_entry Tactic.simple_tactic in
- let mkact loc l : raw_tactic_expr = Tacexpr.TacML (loc, name, List.map snd l) in
- let rules = List.map (make_rule mkact) prods in
+ let entry = Tactic.simple_tactic in
+ let mkact i loc l : raw_tactic_expr =
+ let open Tacexpr in
+ let entry = { mltac_name = name; mltac_index = i } in
+ TacML (loc, entry, List.map snd l)
+ in
+ let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in
synchronize_level_positions ();
- grammar_extend entry None (None ,[(None, None, List.rev rules)]);
+ grammar_extend entry None (None, [(None, None, List.rev rules)]);
1
(* Declaration of the tactic grammar rule *)
@@ -281,7 +281,7 @@ let add_tactic_entry kn tg =
in
let rules = make_rule mkact tg.tacgram_prods in
synchronize_level_positions ();
- grammar_extend entry None (Option.map of_coq_position pos,[(None, None, List.rev [rules])]);
+ grammar_extend entry None (pos, [(None, None, List.rev [rules])]);
1
let (grammar_state : (int * all_grammar_command) list ref) = ref []
@@ -374,7 +374,7 @@ let create_ltac_quotation name cast wit e =
let rule = [
gram_token_of_string name;
gram_token_of_string ":";
- symbol_of_prod_entry_key (Agram (Gram.Entry.name e));
+ symbol_of_prod_entry_key (Aentry (name_of_entry e));
] in
let action v _ _ loc =
let loc = !@loc in
diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli
index 2b0f7da8c..cdd5fbd0f 100644
--- a/parsing/egramcoq.mli
+++ b/parsing/egramcoq.mli
@@ -38,7 +38,7 @@ type notation_grammar = {
type tactic_grammar = {
tacgram_level : int;
- tacgram_prods : grammar_prod_item list;
+ tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list;
}
(** {5 Adding notations} *)
@@ -50,7 +50,7 @@ val extend_tactic_grammar : KerName.t -> tactic_grammar -> unit
(** Add a tactic notation rule to the parsing system. This produces a TacAlias
tactic with the provided kernel name. *)
-val extend_ml_tactic_grammar : Tacexpr.ml_tactic_name -> grammar_prod_item list list -> unit
+val extend_ml_tactic_grammar : Tacexpr.ml_tactic_name -> Tacexpr.raw_tactic_expr grammar_prod_item list list -> unit
(** Add a ML tactic notation rule to the parsing system. This produces a
TacML tactic with the provided string as name. *)
diff --git a/parsing/egramml.ml b/parsing/egramml.ml
index 8fe03b363..984027b81 100644
--- a/parsing/egramml.ml
+++ b/parsing/egramml.ml
@@ -13,35 +13,58 @@ open Pcoq
open Genarg
open Vernacexpr
-(** Making generic actions in type generic_argument *)
-
-let make_generic_action
- (f:Loc.t -> ('b * raw_generic_argument) list -> 'a) pil =
- let rec make env = function
- | [] ->
- Gram.action (fun loc -> f (to_coqloc loc) env)
- | None :: tl -> (* parse a non-binding item *)
- Gram.action (fun _ -> make env tl)
- | Some (p, t) :: tl -> (* non-terminal *)
- Gram.action (fun v -> make ((p, Unsafe.inj t v) :: env) tl) in
- make [] (List.rev pil)
-
(** Grammar extensions declared at ML level *)
-type grammar_prod_item =
+type 's grammar_prod_item =
| GramTerminal of string
- | GramNonTerminal of
- Loc.t * argument_type * prod_entry_key * Id.t option
+ | GramNonTerminal :
+ Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item
+
+type 'a ty_arg = Id.t * ('a -> raw_generic_argument)
+
+type ('self, _, 'r) ty_rule =
+| TyStop : ('self, 'r, 'r) ty_rule
+| TyNext : ('self, 'a, 'r) ty_rule * ('self, 'b) Extend.symbol * 'b ty_arg option ->
+ ('self, 'b -> 'a, 'r) ty_rule
+
+type ('self, 'r) any_ty_rule =
+| AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule
+
+let rec ty_rule_of_gram = function
+| [] -> AnyTyRule TyStop
+| GramTerminal s :: rem ->
+ let AnyTyRule rem = ty_rule_of_gram rem in
+ let tok = Atoken (Lexer.terminal s) in
+ let r = TyNext (rem, tok, None) in
+ AnyTyRule r
+| GramNonTerminal (_, t, tok, idopt) :: rem ->
+ let AnyTyRule rem = ty_rule_of_gram rem in
+ let inj = match idopt with
+ | None -> None
+ | Some id -> Some (id, fun obj -> Genarg.in_gen t obj)
+ in
+ let r = TyNext (rem, tok, inj) in
+ AnyTyRule r
+
+let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function
+| TyStop -> Extend.Stop
+| TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok)
+
+type 'r gen_eval = Loc.t -> (Id.t * raw_generic_argument) list -> 'r
-let make_prod_item = function
- | GramTerminal s -> (gram_token_of_string s, None)
- | GramNonTerminal (_,t,e,po) ->
- (symbol_of_prod_entry_key e, Option.map (fun p -> (p,t)) po)
+let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function
+| TyStop -> fun f loc -> f loc []
+| TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f
+| TyNext (rem, tok, Some (id, inj)) -> fun f x ->
+ let f loc args = f loc ((id, inj x) :: args) in
+ ty_eval rem f
-let make_rule mkact pt =
- let (symbs,ntl) = List.split (List.map make_prod_item pt) in
- let act = make_generic_action mkact ntl in
- (symbs, act)
+let make_rule f prod =
+ let AnyTyRule ty_rule = ty_rule_of_gram (List.rev prod) in
+ let symb = ty_erase ty_rule in
+ let f loc l = f loc (List.rev l) in
+ let act = ty_eval ty_rule f in
+ Extend.Rule (symb, act)
(** Vernac grammar extensions *)
@@ -60,4 +83,4 @@ let extend_vernac_command_grammar s nt gl =
vernac_exts := (s,gl) :: !vernac_exts;
let mkact loc l = VernacExtend (s,List.map snd l) in
let rules = [make_rule mkact gl] in
- maybe_uncurry (Gram.extend nt) (None,[(None, None, List.rev rules)])
+ grammar_extend nt None (None, [None, None, rules])
diff --git a/parsing/egramml.mli b/parsing/egramml.mli
index 9ebb5b83b..e3ae4e011 100644
--- a/parsing/egramml.mli
+++ b/parsing/egramml.mli
@@ -6,24 +6,26 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+open Vernacexpr
+
(** Mapping of grammar productions to camlp4 actions. *)
(** This is the part specific to vernac extensions.
For the Coq-level Notation and Tactic Notation, see Egramcoq. *)
-type grammar_prod_item =
+type 's grammar_prod_item =
| GramTerminal of string
- | GramNonTerminal of Loc.t * Genarg.argument_type *
- Pcoq.prod_entry_key * Names.Id.t option
+ | GramNonTerminal : Loc.t * 'a Genarg.raw_abstract_argument_type *
+ ('s, 'a) Pcoq.entry_key * Names.Id.t option -> 's grammar_prod_item
val extend_vernac_command_grammar :
- Vernacexpr.extend_name -> Vernacexpr.vernac_expr Pcoq.Gram.entry option ->
- grammar_prod_item list -> unit
+ Vernacexpr.extend_name -> vernac_expr Pcoq.Gram.entry option ->
+ vernac_expr grammar_prod_item list -> unit
-val get_extend_vernac_rule : Vernacexpr.extend_name -> grammar_prod_item list
+val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_item list
(** Utility function reused in Egramcoq : *)
val make_rule :
- (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'b) ->
- grammar_prod_item list -> Pcoq.Gram.symbol list * Pcoq.Gram.action
+ (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'a) ->
+ 'a grammar_prod_item list -> 'a Extend.production_rule
diff --git a/parsing/entry.ml b/parsing/entry.ml
new file mode 100644
index 000000000..97d601320
--- /dev/null
+++ b/parsing/entry.ml
@@ -0,0 +1,63 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Errors
+open Util
+
+type 'a t = string * string
+
+type repr =
+| Static of string * string
+| Dynamic of string
+
+type universe = string
+
+(* The univ_tab is not part of the state. It contains all the grammars that
+ exist or have existed before in the session. *)
+
+let univ_tab = (Hashtbl.create 7 : (string, unit) Hashtbl.t)
+
+let create_univ s =
+ Hashtbl.add univ_tab s (); s
+
+let univ_name s = s
+
+let uprim = create_univ "prim"
+let uconstr = create_univ "constr"
+let utactic = create_univ "tactic"
+let uvernac = create_univ "vernac"
+
+let get_univ s =
+ try
+ Hashtbl.find univ_tab s; s
+ with Not_found ->
+ anomaly (Pp.str ("Unknown grammar universe: "^s))
+
+(** Entries are registered with a unique name *)
+
+let entries = ref String.Set.empty
+
+let create u name =
+ let uname = u ^ ":" ^ name in
+ let () =
+ if String.Set.mem uname !entries then
+ anomaly (Pp.str ("Entry " ^ uname ^ " already defined"))
+ in
+ let () = entries := String.Set.add uname !entries in
+ (u, name)
+
+let dynamic name = ("", name)
+
+let unsafe_of_name (u, s) =
+ let uname = u ^ ":" ^ s in
+ assert (String.Set.mem uname !entries);
+ (u, s)
+
+let repr = function
+| ("", u) -> Dynamic u
+| (u, s) -> Static (u, s)
diff --git a/parsing/entry.mli b/parsing/entry.mli
new file mode 100644
index 000000000..6854a5cb4
--- /dev/null
+++ b/parsing/entry.mli
@@ -0,0 +1,50 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Typed grammar entries *)
+
+type 'a t
+(** Typed grammar entries. We need to defined them here so that they are
+ marshallable and defined before the Pcoq.Gram module. They are basically
+ unique names made of a universe and an entry name. They should be kept
+ synchronized with the {!Pcoq} entries though. *)
+
+type repr =
+| Static of string * string
+| Dynamic of string
+(** Representation of entries. *)
+
+(** Table of Coq statically defined grammar entries *)
+
+type universe
+
+(** There are four predefined universes: "prim", "constr", "tactic", "vernac" *)
+
+val get_univ : string -> universe
+val univ_name : universe -> string
+
+val uprim : universe
+val uconstr : universe
+val utactic : universe
+val uvernac : universe
+
+(** {5 Uniquely defined entries} *)
+
+val create : universe -> string -> 'a t
+(** Create an entry. They should be synchronized with the entries defined in
+ {!Pcoq}. *)
+
+(** {5 Meta-programming} *)
+
+val dynamic : string -> 'a t
+(** Dynamic entries. They refer to entries defined in the code source and may
+ only be used in meta-programming definitions from the grammar directory. *)
+
+val repr : 'a t -> repr
+
+val unsafe_of_name : (string * string) -> 'a t
diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4
index c6d5f3b92..23bd74da9 100644
--- a/parsing/lexer.ml4
+++ b/parsing/lexer.ml4
@@ -8,7 +8,6 @@
open Pp
open Util
-open Compat
open Tok
(* Dictionaries: trees annotated with string options, each node being a map
@@ -565,7 +564,7 @@ let loct_add loct i loc = Hashtbl.add loct i loc
let current_location_table = ref (loct_create ())
-type location_table = (int, CompatLoc.t) Hashtbl.t
+type location_table = (int, Compat.CompatLoc.t) Hashtbl.t
let location_table () = !current_location_table
let restore_location_table t = current_location_table := t
@@ -602,7 +601,7 @@ let func cs =
Stream.from
(fun i ->
let (tok, loc) = next_token cs in
- loct_add loct i (make_loc loc); Some tok)
+ loct_add loct i (Compat.make_loc loc); Some tok)
in
current_location_table := loct;
(ts, loct_func loct)
@@ -622,10 +621,10 @@ ELSE (* official camlp4 for ocaml >= 3.10 *)
module M_ = Camlp4.ErrorHandler.Register (Error)
-module Loc = CompatLoc
+module Loc = Compat.CompatLoc
module Token = struct
include Tok (* Cf. tok.ml *)
- module Loc = CompatLoc
+ module Loc = Compat.CompatLoc
module Error = Camlp4.Struct.EmptyError
module Filter = struct
type token_filter = (Tok.t * Loc.t) Stream.t -> (Tok.t * Loc.t) Stream.t
@@ -643,7 +642,7 @@ let mk () _init_loc(*FIXME*) cs =
let rec self =
parser i
[< (tok, loc) = next_token; s >] ->
- let loc = make_loc loc in
+ let loc = Compat.make_loc loc in
loct_add loct i loc;
[< '(tok, loc); self s >]
| [< >] -> [< >]
diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib
index a0cb83193..024d8607f 100644
--- a/parsing/parsing.mllib
+++ b/parsing/parsing.mllib
@@ -1,6 +1,7 @@
Tok
Compat
Lexer
+Entry
Pcoq
Egramml
Egramcoq
diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml
index 2e47e07a3..4565b87a0 100644
--- a/parsing/pcoq.ml4
+++ b/parsing/pcoq.ml
@@ -20,37 +20,11 @@ open Tok (* necessary for camlp4 *)
module G = GrammarMake (Lexer)
-(* TODO: this is a workaround, since there isn't such
- [warning_verbose] in new camlp4. In camlp5, this ref
- gets hidden by [Gramext.warning_verbose] *)
-let warning_verbose = ref true
-
-IFDEF CAMLP5 THEN
-open Gramext
-ELSE
-open PcamlSig.Grammar
-open G
-END
-
-(** Compatibility with Camlp5 6.x *)
-
-IFDEF CAMLP5_6_00 THEN
-let slist0sep x y = Slist0sep (x, y, false)
-let slist1sep x y = Slist1sep (x, y, false)
-ELSE
-let slist0sep x y = Slist0sep (x, y)
-let slist1sep x y = Slist1sep (x, y)
-END
-
-let gram_token_of_token tok =
-IFDEF CAMLP5 THEN
- Stoken (Tok.to_pattern tok)
-ELSE
- match tok with
- | KEYWORD s -> Skeyword s
- | tok -> Stoken ((=) tok, to_string tok)
-END
+let warning_verbose = Compat.warning_verbose
+module Symbols = GramextMake(G)
+
+let gram_token_of_token = Symbols.stoken
let gram_token_of_string s = gram_token_of_token (Lexer.terminal s)
let camlp4_verbosity silent f x =
@@ -62,26 +36,6 @@ let camlp4_verbosity silent f x =
let camlp4_verbose f x = camlp4_verbosity (Flags.is_verbose ()) f x
-(** General entry keys *)
-
-(** This intermediate abstract representation of entries can
- both be reified into mlexpr for the ML extensions and
- dynamically interpreted as entries for the Coq level extensions
-*)
-
-type prod_entry_key =
- | Alist1 of prod_entry_key
- | Alist1sep of prod_entry_key * string
- | Alist0 of prod_entry_key
- | Alist0sep of prod_entry_key * string
- | Aopt of prod_entry_key
- | Amodifiers of prod_entry_key
- | Aself
- | Anext
- | Atactic of int
- | Agram of string
- | Aentry of string * string
-
(** [grammar_object] is the superclass of all grammar entries *)
module type Gramobj =
@@ -98,7 +52,6 @@ end
(** Grammar entries with associated types *)
-type entry_type = argument_type
type grammar_object = Gramobj.grammar_object
type typed_entry = argument_type * grammar_object G.entry
let in_typed_entry t e = (t,Gramobj.weaken_entry e)
@@ -106,6 +59,29 @@ let type_of_typed_entry (t,e) = t
let object_of_typed_entry (t,e) = e
let weaken_entry x = Gramobj.weaken_entry x
+(** General entry keys *)
+
+(** This intermediate abstract representation of entries can
+ both be reified into mlexpr for the ML extensions and
+ dynamically interpreted as entries for the Coq level extensions
+*)
+
+type ('self, 'a) entry_key = ('self, 'a) Extend.symbol =
+| Atoken : Tok.t -> ('self, string) entry_key
+| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key
+| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key
+| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key
+| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key
+| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key
+| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key
+| Aself : ('self, 'self) entry_key
+| Anext : ('self, 'self) entry_key
+| Aentry : 'a Entry.t -> ('self, 'a) entry_key
+| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key
+
+type 's entry_name = EntryName :
+ 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name
+
module type Gramtypes =
sig
val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry
@@ -158,7 +134,10 @@ let grammar_delete e reinit (pos,rls) =
(List.rev rls);
match reinit with
| Some (a,ext) ->
- let lev = match pos with Some (Level n) -> n | _ -> assert false in
+ let lev = match Option.map Compat.to_coq_position pos with
+ | Some (Level n) -> n
+ | _ -> assert false
+ in
maybe_uncurry (G.extend e) (Some ext, [Some lev,Some a,[]])
| None -> ()
@@ -190,7 +169,7 @@ module Gram =
(** This extension command is used by the Grammar constr *)
-let grammar_extend e reinit ext =
+let unsafe_grammar_extend e reinit ext =
camlp4_state := ByGrammar (weaken_entry e,reinit,ext) :: !camlp4_state;
camlp4_verbose (maybe_uncurry (G.extend e)) ext
@@ -215,22 +194,22 @@ let rec remove_grammars n =
redo();
camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state)
+let make_rule r = [None, None, r]
+
(** An entry that checks we reached the end of the input. *)
let eoi_entry en =
let e = Gram.entry_create ((Gram.Entry.name en) ^ "_eoi") in
- GEXTEND Gram
- e: [ [ x = en; EOI -> x ] ]
- ;
- END;
+ let symbs = [Symbols.snterm (Gram.Entry.obj en); Symbols.stoken Tok.EOI] in
+ let act = Gram.action (fun _ x loc -> x) in
+ maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]);
e
let map_entry f en =
let e = Gram.entry_create ((Gram.Entry.name en) ^ "_map") in
- GEXTEND Gram
- e: [ [ x = en -> f x ] ]
- ;
- END;
+ let symbs = [Symbols.snterm (Gram.Entry.obj en)] in
+ let act = Gram.action (fun x loc -> f x) in
+ maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]);
e
(* Parse a string, does NOT check if the entire string was read
@@ -239,45 +218,58 @@ let map_entry f en =
let parse_string f x =
let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm)
-type gram_universe = string * (string, typed_entry) Hashtbl.t
+type gram_universe = Entry.universe
let trace = ref false
-(* The univ_tab is not part of the state. It contains all the grammars that
- exist or have existed before in the session. *)
-
-let univ_tab = (Hashtbl.create 7 : (string, gram_universe) Hashtbl.t)
-
-let create_univ s =
- let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u
+let uprim = Entry.uprim
+let uconstr = Entry.uconstr
+let utactic = Entry.utactic
+let uvernac = Entry.uvernac
+let get_univ = Entry.get_univ
-let uprim = create_univ "prim"
-let uconstr = create_univ "constr"
-let utactic = create_univ "tactic"
-let uvernac = create_univ "vernac"
+let utables : (string, (string, typed_entry) Hashtbl.t) Hashtbl.t =
+ Hashtbl.create 97
-let get_univ s =
- try
- Hashtbl.find univ_tab s
+let get_utable u =
+ let u = Entry.univ_name u in
+ try Hashtbl.find utables u
with Not_found ->
- anomaly (Pp.str ("Unknown grammar universe: "^s))
-
-let get_entry (u, utab) s = Hashtbl.find utab s
-
-let new_entry etyp (u, utab) s =
- if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr);
- let ename = u ^ ":" ^ s in
+ let table = Hashtbl.create 97 in
+ Hashtbl.add utables u table;
+ table
+
+let get_entry u s =
+ let utab = get_utable u in
+ Hashtbl.find utab s
+
+let get_typed_entry e =
+ let (u, s) = match Entry.repr e with
+ | Entry.Dynamic _ -> assert false
+ | Entry.Static (u, s) -> (u, s)
+ in
+ let u = Entry.get_univ u in
+ get_entry u s
+
+let new_entry etyp u s =
+ let utab = get_utable u in
+ let uname = Entry.univ_name u in
+ if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" uname s; flush stderr);
+ let _ = Entry.create u s in
+ let ename = uname ^ ":" ^ s in
let e = in_typed_entry etyp (Gram.entry_create ename) in
Hashtbl.add utab s e; e
-let create_entry (u, utab) s etyp =
+let create_entry u s etyp =
+ let utab = get_utable u in
try
let e = Hashtbl.find utab s in
+ let u = Entry.univ_name u in
if not (argument_type_eq (type_of_typed_entry e) etyp) then
failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type");
e
with Not_found ->
- new_entry etyp (u, utab) s
+ new_entry etyp u s
let create_constr_entry s =
outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType)
@@ -288,8 +280,11 @@ let create_generic_entry s wit =
(* [make_gen_entry] builds entries extensible by giving its name (a string) *)
(* For entries extensible only via the ML name, Gram.entry_create is enough *)
-let make_gen_entry (u,univ) rawwit s =
- let e = Gram.entry_create (u ^ ":" ^ s) in
+let make_gen_entry u rawwit s =
+ let univ = get_utable u in
+ let uname = Entry.univ_name u in
+ let e = Gram.entry_create (uname ^ ":" ^ s) in
+ let _ = Entry.create u s in
Hashtbl.add univ s (inGramObj rawwit e); e
(* Initial grammar entries *)
@@ -377,7 +372,7 @@ module Tactic =
make_gen_entry utactic (rawwit wit_bindings) "bindings"
let hypident = Gram.entry_create "hypident"
let constr_may_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval"
- let constr_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval"
+ let constr_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_eval"
let uconstr =
make_gen_entry utactic (rawwit wit_uconstr) "uconstr"
let quantified_hypothesis =
@@ -392,8 +387,8 @@ module Tactic =
(* Main entries for ltac *)
let tactic_arg = Gram.entry_create "tactic:tactic_arg"
- let tactic_expr = Gram.entry_create "tactic:tactic_expr"
- let binder_tactic = Gram.entry_create "tactic:binder_tactic"
+ let tactic_expr = make_gen_entry utactic (rawwit wit_tactic) "tactic_expr"
+ let binder_tactic = make_gen_entry utactic (rawwit wit_tactic) "binder_tactic"
let tactic = make_gen_entry utactic (rawwit wit_tactic) "tactic"
@@ -420,11 +415,14 @@ module Vernac_ =
(* Main vernac entry *)
let main_entry = Gram.entry_create "vernac"
- GEXTEND Gram
- main_entry:
- [ [ a = vernac -> Some (!@loc, a) | EOI -> None ] ]
- ;
- END
+ let () =
+ let act_vernac = Gram.action (fun v loc -> Some (!@loc, v)) in
+ let act_eoi = Gram.action (fun _ loc -> None) in
+ let rule = [
+ ([ Symbols.stoken Tok.EOI ], act_eoi);
+ ([ Symbols.snterm (Gram.Entry.obj vernac) ], act_vernac );
+ ] in
+ maybe_uncurry (Gram.extend main_entry) (None, make_rule rule)
end
@@ -679,77 +677,85 @@ let make_sep_rules tkl =
let rec symbol_of_constr_prod_entry_key assoc from forpat typ =
if is_binder_level from typ then
if forpat then
- Snterml (Gram.Entry.obj Constr.pattern,"200")
+ Symbols.snterml (Gram.Entry.obj Constr.pattern,"200")
else
- Snterml (Gram.Entry.obj Constr.operconstr,"200")
+ Symbols.snterml (Gram.Entry.obj Constr.operconstr,"200")
else if is_self from typ then
- Sself
+ Symbols.sself
else
match typ with
| ETConstrList (typ',[]) ->
- Slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'))
+ Symbols.slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'))
| ETConstrList (typ',tkl) ->
- slist1sep
- (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'))
- (make_sep_rules tkl)
+ Symbols.slist1sep
+ (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'),
+ make_sep_rules tkl)
| ETBinderList (false,[]) ->
- Slist1
+ Symbols.slist1
(symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false))
| ETBinderList (false,tkl) ->
- slist1sep
- (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false))
- (make_sep_rules tkl)
+ Symbols.slist1sep
+ (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false),
+ make_sep_rules tkl)
| _ ->
match interp_constr_prod_entry_key assoc from forpat typ with
- | (eobj,None,_) -> Snterm (Gram.Entry.obj eobj)
- | (eobj,Some None,_) -> Snext
+ | (eobj,None,_) -> Symbols.snterm (Gram.Entry.obj eobj)
+ | (eobj,Some None,_) -> Symbols.snext
| (eobj,Some (Some (lev,cur)),_) ->
- Snterml (Gram.Entry.obj eobj,constr_level lev)
+ Symbols.snterml (Gram.Entry.obj eobj,constr_level lev)
(** Binding general entry keys to symbol *)
-let rec symbol_of_prod_entry_key = function
- | Alist1 s -> Slist1 (symbol_of_prod_entry_key s)
+let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function
+ | Atoken t -> Symbols.stoken t
+ | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s)
| Alist1sep (s,sep) ->
- slist1sep (symbol_of_prod_entry_key s) (gram_token_of_string sep)
- | Alist0 s -> Slist0 (symbol_of_prod_entry_key s)
+ Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string sep)
+ | Alist0 s -> Symbols.slist0 (symbol_of_prod_entry_key s)
| Alist0sep (s,sep) ->
- slist0sep (symbol_of_prod_entry_key s) (gram_token_of_string sep)
- | Aopt s -> Sopt (symbol_of_prod_entry_key s)
+ Symbols.slist0sep (symbol_of_prod_entry_key s, gram_token_of_string sep)
+ | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s)
| Amodifiers s ->
Gram.srules'
[([], Gram.action (fun _loc -> []));
([gram_token_of_string "(";
- slist1sep (symbol_of_prod_entry_key s) (gram_token_of_string ",");
+ Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string ",");
gram_token_of_string ")"],
Gram.action (fun _ l _ _loc -> l))]
- | Aself -> Sself
- | Anext -> Snext
- | Atactic 5 -> Snterm (Gram.Entry.obj Tactic.binder_tactic)
- | Atactic n ->
- Snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n)
- | Agram s ->
- let e =
- try
- (** ppedrot: we should always generate Agram entries which have already
- been registered, so this should not fail. *)
- let (u, s) = match String.split ':' s with
- | u :: s :: [] -> (u, s)
- | _ -> raise Not_found
- in
- get_entry (get_univ u) s
- with Not_found ->
- Errors.anomaly (str "Unregistered grammar entry: " ++ str s)
- in
- Snterm (Gram.Entry.obj (object_of_typed_entry e))
- | Aentry (u,s) ->
- let e = get_entry (get_univ u) s in
- Snterm (Gram.Entry.obj (object_of_typed_entry e))
+ | Aself -> Symbols.sself
+ | Anext -> Symbols.snext
+ | Aentry e ->
+ let e = get_typed_entry e in
+ Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e))
+ | Aentryl (e, n) ->
+ let e = get_typed_entry e in
+ Symbols.snterml (Gram.Entry.obj (object_of_typed_entry e), string_of_int n)
+
+let level_of_snterml e = int_of_string (Symbols.snterml_level e)
-let level_of_snterml = function
- | Snterml (_,l) -> int_of_string l
- | _ -> failwith "level_of_snterml"
+let rec of_coq_rule : type self a r. (self, a, r) Extend.rule -> _ = function
+| Stop -> fun accu -> accu
+| Next (r, tok) -> fun accu ->
+ let symb = symbol_of_prod_entry_key tok in
+ of_coq_rule r (symb :: accu)
+
+let rec of_coq_action : type a r. (r, a, Loc.t -> r) Extend.rule -> a -> Gram.action = function
+| Stop -> fun f -> Gram.action (fun loc -> f (to_coqloc loc))
+| Next (r, _) -> fun f -> Gram.action (fun x -> of_coq_action r (f x))
+
+let of_coq_production_rule : type a. a Extend.production_rule -> _ = function
+| Rule (toks, act) -> (of_coq_rule toks [], of_coq_action toks act)
+
+let of_coq_single_extend_statement (lvl, assoc, rule) =
+ (lvl, Option.map of_coq_assoc assoc, List.map of_coq_production_rule rule)
+
+let of_coq_extend_statement (pos, st) =
+ (Option.map of_coq_position pos, List.map of_coq_single_extend_statement st)
+
+let grammar_extend e reinit ext =
+ let ext = of_coq_extend_statement ext in
+ unsafe_grammar_extend e reinit ext
(**********************************************************************)
(* Interpret entry names of the form "ne_constr_list" as entry keys *)
@@ -775,62 +781,83 @@ let tactic_level s =
let type_of_entry u s =
type_of_typed_entry (get_entry u s)
+let name_of_entry e = match String.split ':' (Gram.Entry.name e) with
+| u :: s :: [] -> Entry.unsafe_of_name (u, s)
+| _ -> assert false
+
+let atactic n =
+ if n = 5 then Aentry (name_of_entry Tactic.binder_tactic)
+ else Aentryl (name_of_entry Tactic.tactic_expr, n)
+
+let unsafe_of_genarg : argument_type -> 'a raw_abstract_argument_type =
+ (** FIXME *)
+ Obj.magic
+
+let try_get_entry u s =
+ (** Order the effects: type_of_entry can raise Not_found *)
+ let typ = type_of_entry u s in
+ let typ = unsafe_of_genarg typ in
+ EntryName (typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s)))
+
+let wit_list : 'a raw_abstract_argument_type -> 'a list raw_abstract_argument_type =
+ fun t -> unsafe_of_genarg (ListArgType (unquote t))
+
+let wit_opt : 'a raw_abstract_argument_type -> 'a option raw_abstract_argument_type =
+ fun t -> unsafe_of_genarg (OptArgType (unquote t))
+
+type _ target =
+| TgAny : 's target
+| TgTactic : int -> Tacexpr.raw_tactic_expr target
+
+(** Quite ad-hoc *)
+let get_tacentry (type s) (n : int) (t : s target) : s entry_name = match t with
+| TgAny -> EntryName (rawwit wit_tactic, atactic n)
+| TgTactic m ->
+ let check_lvl n =
+ Int.equal m n
+ && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *)
+ && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *)
+ in
+ if check_lvl n then EntryName (rawwit wit_tactic, Aself)
+ else if check_lvl (n + 1) then EntryName (rawwit wit_tactic, Anext)
+ else EntryName (rawwit wit_tactic, atactic n)
+
let rec interp_entry_name static up_level s sep =
let l = String.length s in
if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then
- let t, g = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in
- ListArgType t, Alist1 g
+ let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in
+ EntryName (wit_list t, Alist1 g)
else if l > 12 && coincide s "ne_" 0 &&
coincide s "_list_sep" (l-9) then
- let t, g = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in
- ListArgType t, Alist1sep (g,sep)
+ let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in
+ EntryName (wit_list t, Alist1sep (g,sep))
else if l > 5 && coincide s "_list" (l-5) then
- let t, g = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in
- ListArgType t, Alist0 g
+ let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in
+ EntryName (wit_list t, Alist0 g)
else if l > 9 && coincide s "_list_sep" (l-9) then
- let t, g = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in
- ListArgType t, Alist0sep (g,sep)
+ let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in
+ EntryName (wit_list t, Alist0sep (g,sep))
else if l > 4 && coincide s "_opt" (l-4) then
- let t, g = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in
- OptArgType t, Aopt g
+ let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in
+ EntryName (wit_opt t, Aopt g)
else if l > 5 && coincide s "_mods" (l-5) then
- let t, g = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in
- ListArgType t, Amodifiers g
+ let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in
+ EntryName (wit_list t, Amodifiers g)
else
let s = match s with "hyp" -> "var" | _ -> s in
- let check_lvl n = match up_level with
- | None -> false
- | Some m -> Int.equal m n
- && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *)
- && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *)
- in
- let t, se =
match tactic_level s with
- | Some n ->
- (** Quite ad-hoc *)
- let t = unquote (rawwit wit_tactic) in
- let se =
- if check_lvl n then Aself
- else if check_lvl (n + 1) then Anext
- else Atactic n
- in
- (Some t, se)
+ | Some n -> get_tacentry n up_level
| None ->
- try Some (type_of_entry uprim s), Aentry ("prim",s) with Not_found ->
- try Some (type_of_entry uconstr s), Aentry ("constr",s) with Not_found ->
- try Some (type_of_entry utactic s), Aentry ("tactic",s) with Not_found ->
+ try try_get_entry uprim s with Not_found ->
+ try try_get_entry uconstr s with Not_found ->
+ try try_get_entry utactic s with Not_found ->
if static then
error ("Unknown entry "^s^".")
else
- None, Aentry ("",s) in
- let t =
- match t with
- | Some t -> t
- | None -> ExtraArgType s in
- t, se
+ EntryName (unsafe_of_genarg (ExtraArgType s), Aentry (Entry.dynamic s))
let list_entry_names () =
let add_entry key (entry, _) accu = (key, entry) :: accu in
- let ans = Hashtbl.fold add_entry (snd uprim) [] in
- let ans = Hashtbl.fold add_entry (snd uconstr) ans in
- Hashtbl.fold add_entry (snd utactic) ans
+ let ans = Hashtbl.fold add_entry (get_utable uprim) [] in
+ let ans = Hashtbl.fold add_entry (get_utable uconstr) ans in
+ Hashtbl.fold add_entry (get_utable utactic) ans
diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli
index 2146ad964..c224dbad9 100644
--- a/parsing/pcoq.mli
+++ b/parsing/pcoq.mli
@@ -14,13 +14,12 @@ open Genarg
open Constrexpr
open Tacexpr
open Libnames
-open Compat
open Misctypes
open Genredexpr
(** The parser of Coq *)
-module Gram : GrammarSig
+module Gram : Compat.GrammarSig
(** The parser of Coq is built from three kinds of rule declarations:
@@ -106,28 +105,40 @@ type grammar_object
(** Type of reinitialization data *)
type gram_reinit = gram_assoc * gram_position
+(** General entry keys *)
+
+(** This intermediate abstract representation of entries can
+ both be reified into mlexpr for the ML extensions and
+ dynamically interpreted as entries for the Coq level extensions
+*)
+
+type ('self, 'a) entry_key = ('self, 'a) Extend.symbol =
+| Atoken : Tok.t -> ('self, string) entry_key
+| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key
+| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key
+| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key
+| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key
+| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key
+| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key
+| Aself : ('self, 'self) entry_key
+| Anext : ('self, 'self) entry_key
+| Aentry : 'a Entry.t -> ('self, 'a) entry_key
+| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key
+
(** Add one extension at some camlp4 position of some camlp4 entry *)
-val grammar_extend :
+val unsafe_grammar_extend :
grammar_object Gram.entry ->
gram_reinit option (** for reinitialization if ever needed *) ->
Gram.extend_statment -> unit
+val grammar_extend :
+ 'a Gram.entry ->
+ gram_reinit option (** for reinitialization if ever needed *) ->
+ 'a Extend.extend_statment -> unit
+
(** Remove the last n extensions *)
val remove_grammars : int -> unit
-
-
-
-(** The type of typed grammar objects *)
-type typed_entry
-
-(** The possible types for extensible grammars *)
-type entry_type = argument_type
-
-val type_of_typed_entry : typed_entry -> entry_type
-val object_of_typed_entry : typed_entry -> grammar_object Gram.entry
-val weaken_entry : 'a Gram.entry -> grammar_object Gram.entry
-
(** Temporary activate camlp4 verbosity *)
val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit
@@ -138,11 +149,7 @@ val parse_string : 'a Gram.entry -> string -> 'a
val eoi_entry : 'a Gram.entry -> 'a Gram.entry
val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry
-(** Table of Coq statically defined grammar entries *)
-
-type gram_universe
-
-(** There are four predefined universes: "prim", "constr", "tactic", "vernac" *)
+type gram_universe = Entry.universe
val get_univ : string -> gram_universe
@@ -151,7 +158,6 @@ val uconstr : gram_universe
val utactic : gram_universe
val uvernac : gram_universe
-val create_entry : gram_universe -> string -> entry_type -> typed_entry
val create_generic_entry : string -> ('a, rlevel) abstract_argument_type ->
'a Gram.entry
@@ -258,38 +264,25 @@ val symbol_of_constr_prod_entry_key : gram_assoc option ->
constr_entry_key -> bool -> constr_prod_entry_key ->
Gram.symbol
-(** General entry keys *)
-
-(** This intermediate abstract representation of entries can
- both be reified into mlexpr for the ML extensions and
- dynamically interpreted as entries for the Coq level extensions
-*)
-
-type prod_entry_key =
- | Alist1 of prod_entry_key
- | Alist1sep of prod_entry_key * string
- | Alist0 of prod_entry_key
- | Alist0sep of prod_entry_key * string
- | Aopt of prod_entry_key
- | Amodifiers of prod_entry_key
- | Aself
- | Anext
- | Atactic of int
- | Agram of string
- | Aentry of string * string
+val name_of_entry : 'a Gram.entry -> 'a Entry.t
(** Binding general entry keys to symbols *)
val symbol_of_prod_entry_key :
- prod_entry_key -> Gram.symbol
+ ('self, 'a) entry_key -> Gram.symbol
+
+type 's entry_name = EntryName :
+ 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name
(** Interpret entry names of the form "ne_constr_list" as entry keys *)
+type _ target = TgAny : 's target | TgTactic : int -> raw_tactic_expr target
+
val interp_entry_name : bool (** true to fail on unknown entry *) ->
- int option -> string -> string -> entry_type * prod_entry_key
+ 's target -> string -> string -> 's entry_name
(** Recover the list of all known tactic notation entries. *)
-val list_entry_names : unit -> (string * entry_type) list
+val list_entry_names : unit -> (string * argument_type) list
(** Registering/resetting the level of a constr entry *)
diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml
index 57268a9cf..5a49fc8f4 100644
--- a/plugins/btauto/refl_btauto.ml
+++ b/plugins/btauto/refl_btauto.ml
@@ -1,3 +1,4 @@
+open Proofview.Notations
let contrib_name = "btauto"
@@ -216,7 +217,7 @@ module Btauto = struct
Tacticals.tclFAIL 0 msg gl
let try_unification env =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let eq = Lazy.force eq in
let t = decomp_term concl in
@@ -228,10 +229,10 @@ module Btauto = struct
| _ ->
let msg = str "Btauto: Internal error" in
Tacticals.New.tclFAIL 0 msg
- end
+ end }
let tac =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let eq = Lazy.force eq in
let bool = Lazy.force Bool.typ in
@@ -255,6 +256,6 @@ module Btauto = struct
| _ ->
let msg = str "Cannot recognize a boolean equality" in
Tacticals.New.tclFAIL 0 msg
- end
+ end }
end
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml
index 068cb25cf..8c15f54af 100644
--- a/plugins/cc/cctac.ml
+++ b/plugins/cc/cctac.ml
@@ -22,6 +22,7 @@ open Ccproof
open Pp
open Errors
open Util
+open Proofview.Notations
let reference dir s = lazy (Coqlib.gen_reference "CC" dir s)
@@ -254,13 +255,13 @@ let new_app_global f args k =
let new_refine c = Proofview.V82.tactic (refine c)
let assert_before n c =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let evm, _ = Tacmach.New.pf_apply type_of gl c in
Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (assert_before n c)
- end
+ end }
let rec proof_tac p : unit Proofview.tactic =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let type_of t = Tacmach.New.pf_unsafe_type_of gl t in
try (* type_of can raise exceptions *)
match p.p_rule with
@@ -325,10 +326,10 @@ let rec proof_tac p : unit Proofview.tactic =
app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in
Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf)
with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
- end
+ end }
let refute_tac c t1 t2 p =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
let intype =
Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls tt1)) gl
@@ -338,14 +339,14 @@ let refute_tac c t1 t2 p =
let false_t=mkApp (c,[|mkVar hid|]) in
Tacticals.New.tclTHENS (neweq (assert_before (Name hid)))
[proof_tac p; simplest_elim false_t]
- end
+ end }
let refine_exact_check c gl =
let evm, _ = pf_apply type_of gl c in
Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl
let convert_to_goal_tac c t1 t2 p =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
let sort =
Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls tt2)) gl
@@ -357,20 +358,20 @@ let convert_to_goal_tac c t1 t2 p =
let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in
Tacticals.New.tclTHENS (neweq (assert_before (Name e)))
[proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]
- end
+ end }
let convert_to_hyp_tac c1 t1 c2 t2 p =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let tt2=constr_of_term t2 in
let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in
let false_t=mkApp (c2,[|mkVar h|]) in
Tacticals.New.tclTHENS (assert_before (Name h) tt2)
[convert_to_goal_tac c1 t1 t2 p;
simplest_elim false_t]
- end
+ end }
let discriminate_tac (cstr,u as cstru) p =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in
let intype =
Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls t1)) gl
@@ -384,7 +385,7 @@ let discriminate_tac (cstr,u as cstru) p =
let identity = Universes.constr_of_global (Lazy.force _I) in
(* let trivial=pf_unsafe_type_of gls identity in *)
let trivial = Universes.constr_of_global (Lazy.force _True) in
- let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Proofview.Goal.sigma gl) in
+ let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Tacmach.New.project gl) in
let outtype = mkSort outtype in
let pred=mkLambda(Name xid,outtype,mkRel 1) in
let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in
@@ -399,7 +400,7 @@ let discriminate_tac (cstr,u as cstru) p =
Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm)
(Tacticals.New.tclTHENS (neweq (assert_before (Name hid)))
[proof_tac p; Proofview.V82.tactic (endt refine_exact_check)])
- end
+ end }
(* wrap everything *)
@@ -411,7 +412,7 @@ let build_term_to_complete uf meta pac =
applistc (mkConstructU cinfo.ci_constr) all_args
let cc_tactic depth additionnal_terms =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
Coqlib.check_required_library Coqlib.logic_module_name;
let _ = debug (Pp.str "Reading subgoal ...") in
let state = Tacmach.New.of_old (fun gls -> make_prb gls depth additionnal_terms) gl in
@@ -462,7 +463,7 @@ let cc_tactic depth additionnal_terms =
convert_to_goal_tac id ta tb p
| HeqnH (ida,idb) ->
convert_to_hyp_tac ida ta idb tb p
- end
+ end }
let cc_fail gls =
errorlabstrm "Congruence" (Pp.str "congruence failed.")
@@ -485,8 +486,7 @@ let congruence_tac depth l =
let mk_eq f c1 c2 k =
Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc ->
- Proofview.Goal.enter begin
- fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let open Tacmach.New in
let evm, ty = pf_apply type_of gl c1 in
let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in
@@ -494,10 +494,10 @@ let mk_eq f c1 c2 k =
let evm, _ = type_of (pf_env gl) evm term in
Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm))
(k term)
- end)
+ end })
let f_equal =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let cut_eq c1 c2 =
try (* type_of can raise an exception *)
@@ -523,4 +523,4 @@ let f_equal =
| Type_errors.TypeError _ -> Proofview.tclUNIT ()
| e -> Proofview.tclZERO ~info e
end
- end
+ end }
diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml
index 1a9080647..1741df533 100644
--- a/plugins/decl_mode/decl_proof_instr.ml
+++ b/plugins/decl_mode/decl_proof_instr.ml
@@ -29,6 +29,7 @@ open Termops
open Namegen
open Goptions
open Misctypes
+open Sigma.Notations
(* Strictness option *)
@@ -86,7 +87,7 @@ Please \"suppose\" something or \"end\" it now."
| _ -> ()
let mk_evd metalist gls =
- let evd0= create_goal_evar_defs (sig_sig gls) in
+ let evd0= clear_metas (sig_sig gls) in
let add_one (meta,typ) evd =
meta_declare meta typ evd in
List.fold_right add_one metalist evd0
@@ -1305,7 +1306,11 @@ let understand_my_constr env sigma c concl =
Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType concl) (frob rawc)
let my_refine c gls =
- let oc sigma = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in
+ let oc = { run = begin fun sigma ->
+ let sigma = Sigma.to_evar_map sigma in
+ let (sigma, c) = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in
+ Sigma.Unsafe.of_pair (c, sigma)
+ end } in
Proofview.V82.of_tactic (Tactics.New.refine oc) gls
(* end focus/claim *)
diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml
index d6c29283f..2db0f1a4c 100644
--- a/plugins/derive/derive.ml
+++ b/plugins/derive/derive.ml
@@ -93,6 +93,7 @@ let start_deriving f suchthat lemma =
ignore (Declare.declare_constant lemma lemma_def)
in
+ let terminator = Proof_global.make_terminator terminator in
let () = Proof_global.start_dependent_proof lemma kind goals terminator in
let _ = Proof_global.with_current_proof begin fun _ p ->
Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p
diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
index 7a56cd665..e5c9b2707 100644
--- a/plugins/fourier/fourierR.ml
+++ b/plugins/fourier/fourierR.ml
@@ -19,6 +19,7 @@ open Globnames
open Tacmach
open Fourier
open Contradiction
+open Proofview.Notations
(******************************************************************************
Opérations sur les combinaisons linéaires affines.
@@ -462,7 +463,7 @@ exception GoalDone
(* Résolution d'inéquations linéaires dans R *)
let rec fourier () =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
Coqlib.check_required_library ["Coq";"fourier";"Fourier"];
let goal = strip_outer_cast concl in
@@ -622,7 +623,7 @@ let rec fourier () =
(* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *)
!tac
(* ((tclABSTRACT None !tac) gl) *)
- end
+ end }
;;
(*
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index 169a70600..c9dd18a2f 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -52,10 +52,10 @@ let rec print_debug_queue e =
let _ =
match e with
| Some e ->
- Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
+ Pp.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal" ++ fnl() ++ goal))
| None ->
begin
- Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal);
+ Pp.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal);
end in
print_debug_queue None ;
end
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index 3dbd43806..bf9da870e 100644
--- a/plugins/funind/indfun.ml
+++ b/plugins/funind/indfun.ml
@@ -10,6 +10,7 @@ open Glob_term
open Declarations
open Misctypes
open Decl_kinds
+open Sigma.Notations
let is_rec_info scheme_info =
let test_branche min acc (_,_,br) =
@@ -85,7 +86,7 @@ let functional_induction with_clean c princl pat =
in
let encoded_pat_as_patlist =
List.make (List.length args + List.length c_list - 1) None @ [pat] in
- List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr (fun env sigma -> sigma,(c,NoBindings))),(None,pat),None))
+ List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None))
(args@c_list) encoded_pat_as_patlist
in
let princ' = Some (princ,bindings) in
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
index d97940142..d074bbabd 100644
--- a/plugins/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -70,8 +70,8 @@ let do_observe_tac s tac g =
with reraise ->
let reraise = Errors.push reraise in
let e = Cerrors.process_vernac_interp_error reraise in
- observe (str "observation "++ s++str " raised exception " ++
- Errors.iprint e ++ str " on goal " ++ goal );
+ observe (hov 0 (str "observation "++ s++str " raised exception " ++
+ Errors.iprint e ++ str " on goal" ++ fnl() ++ goal ));
iraise reraise;;
diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml
index 5d41ec723..685a5e8bd 100644
--- a/plugins/funind/recdef.ml
+++ b/plugins/funind/recdef.ml
@@ -212,10 +212,10 @@ let rec print_debug_queue b e =
begin
let lmsg,goal = Stack.pop debug_queue in
if b then
- Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
+ Pp.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal" ++ fnl() ++ goal))
else
begin
- Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal);
+ Pp.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal));
end;
(* print_debug_queue false e; *)
end
@@ -1327,7 +1327,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp
tclFIRST[
tclTHEN
(Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)))
- e_assumption;
+ (Proofview.V82.of_tactic e_assumption);
Eauto.eauto_with_bases
(true,5)
[Evd.empty,Lazy.force refl_equal]
diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v
index 675321d99..31d051cb4 100644
--- a/plugins/micromega/Psatz.v
+++ b/plugins/micromega/Psatz.v
@@ -96,6 +96,14 @@ Ltac psatzl dom :=
Ltac lra :=
first [ psatzl R | psatzl Q ].
+Ltac nra :=
+ unfold Rdiv in * ;
+ xnra ;
+ abstract
+ (intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
+ apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity).
+
(* Local Variables: *)
diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml
index b4f305dd7..63485ab26 100644
--- a/plugins/micromega/certificate.ml
+++ b/plugins/micromega/certificate.ml
@@ -63,82 +63,82 @@ let r_spec = z_spec
let dev_form n_spec p =
let rec dev_form p =
match p with
- | Mc.PEc z -> Poly.constant (n_spec.number_to_num z)
- | Mc.PEX v -> Poly.variable (C2Ml.positive v)
- | Mc.PEmul(p1,p2) ->
- let p1 = dev_form p1 in
- let p2 = dev_form p2 in
- Poly.product p1 p2
- | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2)
- | Mc.PEopp p -> Poly.uminus (dev_form p)
- | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2))
- | Mc.PEpow(p,n) ->
- let p = dev_form p in
- let n = C2Ml.n n in
- let rec pow n =
- if Int.equal n 0
- then Poly.constant (n_spec.number_to_num n_spec.unit)
- else Poly.product p (pow (n-1)) in
- pow n in
- dev_form p
+ | Mc.PEc z -> Poly.constant (n_spec.number_to_num z)
+ | Mc.PEX v -> Poly.variable (C2Ml.positive v)
+ | Mc.PEmul(p1,p2) ->
+ let p1 = dev_form p1 in
+ let p2 = dev_form p2 in
+ Poly.product p1 p2
+ | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2)
+ | Mc.PEopp p -> Poly.uminus (dev_form p)
+ | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2))
+ | Mc.PEpow(p,n) ->
+ let p = dev_form p in
+ let n = C2Ml.n n in
+ let rec pow n =
+ if Int.equal n 0
+ then Poly.constant (n_spec.number_to_num n_spec.unit)
+ else Poly.product p (pow (n-1)) in
+ pow n in
+ dev_form p
let monomial_to_polynomial mn =
Monomial.fold
(fun v i acc ->
- let v = Ml2C.positive v in
- let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
- if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *)
- then mn
- else Mc.PEmul(mn,acc))
- mn
- (Mc.PEc (Mc.Zpos Mc.XH))
+ let v = Ml2C.positive v in
+ let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
+ if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *)
+ then mn
+ else Mc.PEmul(mn,acc))
+ mn
+ (Mc.PEc (Mc.Zpos Mc.XH))
let list_to_polynomial vars l =
assert (List.for_all (fun x -> ceiling_num x =/ x) l);
let var x = monomial_to_polynomial (List.nth vars x) in
-
+
let rec xtopoly p i = function
| [] -> p
| c::l -> if c =/ (Int 0) then xtopoly p (i+1) l
- else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
- let mn =
- if Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH))
- then var i
- else Mc.PEmul (c,var i) in
- let p' = if Pervasives.(=) p (Mc.PEc Mc.Z0) then mn else
- Mc.PEadd (mn, p) in
- xtopoly p' (i+1) l in
-
- xtopoly (Mc.PEc Mc.Z0) 0 l
+ else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
+ let mn =
+ if Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH))
+ then var i
+ else Mc.PEmul (c,var i) in
+ let p' = if Pervasives.(=) p (Mc.PEc Mc.Z0) then mn else
+ Mc.PEadd (mn, p) in
+ xtopoly p' (i+1) l in
+
+ xtopoly (Mc.PEc Mc.Z0) 0 l
let rec fixpoint f x =
let y' = f x in
- if Pervasives.(=) y' x then y'
- else fixpoint f y'
+ if Pervasives.(=) y' x then y'
+ else fixpoint f y'
let rec_simpl_cone n_spec e =
let simpl_cone =
Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in
let rec rec_simpl_cone = function
- | Mc.PsatzMulE(t1, t2) ->
- simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2))
- | Mc.PsatzAdd(t1,t2) ->
- simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2))
- | x -> simpl_cone x in
- rec_simpl_cone e
-
-
+ | Mc.PsatzMulE(t1, t2) ->
+ simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2))
+ | Mc.PsatzAdd(t1,t2) ->
+ simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2))
+ | x -> simpl_cone x in
+ rec_simpl_cone e
+
+
let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c
type cone_prod =
- Const of cone
- | Ideal of cone *cone
- | Mult of cone * cone
- | Other of cone
+ Const of cone
+| Ideal of cone *cone
+| Mult of cone * cone
+| Other of cone
and cone = Mc.zWitness
@@ -147,32 +147,32 @@ let factorise_linear_cone c =
let rec cone_list c l =
match c with
- | Mc.PsatzAdd (x,r) -> cone_list r (x::l)
- | _ -> c :: l in
-
+ | Mc.PsatzAdd (x,r) -> cone_list r (x::l)
+ | _ -> c :: l in
+
let factorise c1 c2 =
match c1 , c2 with
- | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') ->
- if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
- | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') ->
- if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
- | _ -> None in
-
+ | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') ->
+ if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
+ | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') ->
+ if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
+ | _ -> None in
+
let rec rebuild_cone l pending =
match l with
- | [] -> (match pending with
- | None -> Mc.PsatzZ
- | Some p -> p
- )
- | e::l ->
- (match pending with
- | None -> rebuild_cone l (Some e)
- | Some p -> (match factorise p e with
- | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e))
- | Some f -> rebuild_cone l (Some f) )
- ) in
+ | [] -> (match pending with
+ | None -> Mc.PsatzZ
+ | Some p -> p
+ )
+ | e::l ->
+ (match pending with
+ | None -> rebuild_cone l (Some e)
+ | Some p -> (match factorise p e with
+ | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e))
+ | Some f -> rebuild_cone l (Some f) )
+ ) in
- (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None)
+ (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None)
@@ -199,28 +199,28 @@ open Mfourier
let constrain_monomial mn l =
let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in
- if Pervasives.(=) mn Monomial.const
- then
- { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ;
- op = Eq ;
- cst = Big_int zero_big_int }
- else
- { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ;
- op = Eq ;
- cst = Big_int zero_big_int }
+ if Pervasives.(=) mn Monomial.const
+ then
+ { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ;
+ op = Eq ;
+ cst = Big_int zero_big_int }
+ else
+ { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ;
+ op = Eq ;
+ cst = Big_int zero_big_int }
-
+
let positivity l =
let rec xpositivity i l =
match l with
- | [] -> []
- | (_,Mc.Equal)::l -> xpositivity (i+1) l
- | (_,_)::l ->
- {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ;
- op = Ge ;
- cst = Int 0 } :: (xpositivity (i+1) l)
+ | [] -> []
+ | (_,Mc.Equal)::l -> xpositivity (i+1) l
+ | (_,_)::l ->
+ {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ;
+ op = Ge ;
+ cst = Int 0 } :: (xpositivity (i+1) l)
in
- xpositivity 0 l
+ xpositivity 0 l
let string_of_op = function
@@ -241,23 +241,23 @@ let build_linear_system l =
let monomials =
List.fold_left (fun acc p ->
- Poly.fold (fun m _ acc -> MonSet.add m acc) p acc)
- (MonSet.singleton Monomial.const) l'
+ Poly.fold (fun m _ acc -> MonSet.add m acc) p acc)
+ (MonSet.singleton Monomial.const) l'
in (* For each monomial, compute a constraint *)
let s0 =
MonSet.fold (fun mn res -> (constrain_monomial mn l')::res) monomials [] in
- (* I need at least something strictly positive *)
+ (* I need at least something strictly positive *)
let strict = {
coeffs = Vect.from_list ((Big_int unit_big_int)::
(List.map (fun (x,y) ->
- match y with Mc.Strict ->
- Big_int unit_big_int
- | _ -> Big_int zero_big_int) l));
+ match y with Mc.Strict ->
+ Big_int unit_big_int
+ | _ -> Big_int zero_big_int) l));
op = Ge ; cst = Big_int unit_big_int } in
(* Add the positivity constraint *)
- {coeffs = Vect.from_list ([Big_int unit_big_int]) ;
- op = Ge ;
- cst = Big_int zero_big_int}::(strict::(positivity l)@s0)
+ {coeffs = Vect.from_list ([Big_int unit_big_int]) ;
+ op = Ge ;
+ cst = Big_int zero_big_int}::(strict::(positivity l)@s0)
let big_int_to_z = Ml2C.bigint
@@ -266,32 +266,32 @@ let big_int_to_z = Ml2C.bigint
-- at a lower layer, certificates are using nums... *)
let make_certificate n_spec (cert,li) =
let bint_to_cst = n_spec.bigint_to_number in
- match cert with
- | [] -> failwith "empty_certificate"
- | e::cert' ->
-(* let cst = match compare_big_int e zero_big_int with
- | 0 -> Mc.PsatzZ
- | 1 -> Mc.PsatzC (bint_to_cst e)
- | _ -> failwith "positivity error"
- in *)
- let rec scalar_product cert l =
- match cert with
- | [] -> Mc.PsatzZ
- | c::cert ->
- match l with
- | [] -> failwith "make_certificate(1)"
- | i::l ->
- let r = scalar_product cert l in
- match compare_big_int c zero_big_int with
- | -1 -> Mc.PsatzAdd (
- Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
- r)
- | 0 -> r
- | _ -> Mc.PsatzAdd (
- Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
- r) in
- (factorise_linear_cone
- (simplify_cone n_spec (scalar_product cert' li)))
+ match cert with
+ | [] -> failwith "empty_certificate"
+ | e::cert' ->
+ (* let cst = match compare_big_int e zero_big_int with
+ | 0 -> Mc.PsatzZ
+ | 1 -> Mc.PsatzC (bint_to_cst e)
+ | _ -> failwith "positivity error"
+ in *)
+ let rec scalar_product cert l =
+ match cert with
+ | [] -> Mc.PsatzZ
+ | c::cert ->
+ match l with
+ | [] -> failwith "make_certificate(1)"
+ | i::l ->
+ let r = scalar_product cert l in
+ match compare_big_int c zero_big_int with
+ | -1 -> Mc.PsatzAdd (
+ Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
+ r)
+ | 0 -> r
+ | _ -> Mc.PsatzAdd (
+ Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
+ r) in
+ (factorise_linear_cone
+ (simplify_cone n_spec (scalar_product cert' li)))
exception Found of Monomial.t
@@ -301,91 +301,157 @@ exception Strict
module MonMap = Map.Make(Monomial)
let primal l =
- let vr = ref 0 in
-
- let vect_of_poly map p =
- Poly.fold (fun mn vl (map,vect) ->
- if Pervasives.(=) mn Monomial.const
- then (map,vect)
- else
- let (mn,m) = try (MonMap.find mn map,map) with Not_found -> let res = (!vr, MonMap.add mn !vr map) in incr vr ; res in
- (m,if Int.equal (sign_num vl) 0 then vect else (mn,vl)::vect)) p (map,[]) in
-
- let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in
+ let vr = ref 0 in
+
+ let vect_of_poly map p =
+ Poly.fold (fun mn vl (map,vect) ->
+ if Pervasives.(=) mn Monomial.const
+ then (map,vect)
+ else
+ let (mn,m) = try (MonMap.find mn map,map) with Not_found -> let res = (!vr, MonMap.add mn !vr map) in incr vr ; res in
+ (m,if Int.equal (sign_num vl) 0 then vect else (mn,vl)::vect)) p (map,[]) in
+
+ let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in
- let cmp x y = Int.compare (fst x) (fst y) in
+ let cmp x y = Int.compare (fst x) (fst y) in
- snd (List.fold_right (fun (p,op) (map,l) ->
- let (mp,vect) = vect_of_poly map p in
- let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in
+ snd (List.fold_right (fun (p,op) (map,l) ->
+ let (mp,vect) = vect_of_poly map p in
+ let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in
- (mp,cstr::l)) l (MonMap.empty,[]))
+ (mp,cstr::l)) l (MonMap.empty,[]))
let dual_raw_certificate (l: (Poly.t * Mc.op1) list) =
-(* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *)
-
+ (* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *)
+
let sys = build_linear_system l in
- try
- match Fourier.find_point sys with
- | Inr _ -> None
- | Inl cert -> Some (rats_to_ints (Vect.to_list cert))
- (* should not use rats_to_ints *)
- with x when Errors.noncritical x ->
- if debug
- then (Printf.printf "raw certificate %s" (Printexc.to_string x);
- flush stdout) ;
- None
+ try
+ match Fourier.find_point sys with
+ | Inr _ -> None
+ | Inl cert -> Some (rats_to_ints (Vect.to_list cert))
+ (* should not use rats_to_ints *)
+ with x when Errors.noncritical x ->
+ if debug
+ then (Printf.printf "raw certificate %s" (Printexc.to_string x);
+ flush stdout) ;
+ None
let raw_certificate l =
- try
- let p = primal l in
- match Fourier.find_point p with
- | Inr prf ->
- if debug then Printf.printf "AProof : %a\n" pp_proof prf ;
- let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in
- if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ;
- Some (rats_to_ints (Vect.to_list cert))
- | Inl _ -> None
- with Strict ->
+ try
+ let p = primal l in
+ match Fourier.find_point p with
+ | Inr prf ->
+ if debug then Printf.printf "AProof : %a\n" pp_proof prf ;
+ let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in
+ if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ;
+ Some (rats_to_ints (Vect.to_list cert))
+ | Inl _ -> None
+ with Strict ->
(* Fourier elimination should handle > *)
- dual_raw_certificate l
+ dual_raw_certificate l
let simple_linear_prover l =
let (lc,li) = List.split l in
- match raw_certificate lc with
- | None -> None (* No certificate *)
- | Some cert -> Some (cert,li)
-
+ match raw_certificate lc with
+ | None -> None (* No certificate *)
+ | Some cert -> Some (cert,li)
+
let linear_prover n_spec l =
- let build_system n_spec l =
- let li = List.combine l (interval 0 (List.length l -1)) in
- let (l1,l') = List.partition
- (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in
- List.map
- (fun ((x,y),i) -> match y with
- Mc.NonEqual -> failwith "cannot happen"
- | y -> ((dev_form n_spec x, y),i)) l' in
- let l' = build_system n_spec l in
- simple_linear_prover (*n_spec*) l'
+ let build_system n_spec l =
+ let li = List.combine l (interval 0 (List.length l -1)) in
+ let (l1,l') = List.partition
+ (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in
+ List.map
+ (fun ((x,y),i) -> match y with
+ Mc.NonEqual -> failwith "cannot happen"
+ | y -> ((dev_form n_spec x, y),i)) l' in
+ let l' = build_system n_spec l in
+ simple_linear_prover (*n_spec*) l'
let linear_prover n_spec l =
try linear_prover n_spec l
with x when Errors.noncritical x ->
- (print_string (Printexc.to_string x); None)
+ (print_string (Printexc.to_string x); None)
+
+let compute_max_nb_cstr l d =
+ let len = List.length l in
+ max len (max d (len * d))
+
+let linear_prover_with_cert prfdepth spec l =
+ max_nb_cstr := compute_max_nb_cstr l prfdepth ;
+ match linear_prover spec l with
+ | None -> None
+ | Some cert -> Some (make_certificate spec cert)
+
+let nlinear_prover prfdepth (sys: (Mc.q Mc.pExpr * Mc.op1) list) =
+ LinPoly.MonT.clear ();
+ max_nb_cstr := compute_max_nb_cstr sys prfdepth ;
+ (* Assign a proof to the initial hypotheses *)
+ let sys = mapi (fun c i -> (c,Mc.PsatzIn (Ml2C.nat i))) sys in
+
+
+ (* Add all the product of hypotheses *)
+ let prod = all_pairs (fun ((c,o),p) ((c',o'),p') ->
+ ((Mc.PEmul(c,c') , Mc.opMult o o') , Mc.PsatzMulE(p,p'))) sys in
+
+ (* Only filter those have a meaning *)
+ let prod = List.fold_left (fun l ((c,o),p) ->
+ match o with
+ | None -> l
+ | Some o -> ((c,o),p) :: l) [] prod in
+
+ let sys = sys @ prod in
+
+ let square =
+ (* Collect the squares and state that they are positive *)
+ let pols = List.map (fun ((p,_),_) -> dev_form q_spec p) sys in
+ let square =
+ List.fold_left (fun acc p ->
+ Poly.fold
+ (fun m _ acc ->
+ match Monomial.sqrt m with
+ | None -> acc
+ | Some s -> MonMap.add s m acc) p acc) MonMap.empty pols in
+
+ let pol_of_mon m =
+ Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc q_spec.unit) in
+
+ let norm0 =
+ Mc.norm q_spec.zero q_spec.unit Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool in
+
+
+ MonMap.fold (fun s m acc -> ((pol_of_mon m , Mc.NonStrict), Mc.PsatzSquare(norm0 (pol_of_mon s)))::acc) square [] in
+
+ Printf.printf "#square %i\n" (List.length square) ;
+ flush stdout ;
+
+ let sys = sys @ square in
-let linear_prover_with_cert spec l =
- match linear_prover spec l with
- | None -> None
- | Some cert -> Some (make_certificate spec cert)
+ (* Call the linear prover without the proofs *)
+ let sys_no_prf = List.map fst sys in
+
+ match linear_prover q_spec sys_no_prf with
+ | None -> None
+ | Some cert ->
+ let cert = make_certificate q_spec cert in
+ let rec map_psatz = function
+ | Mc.PsatzIn n -> snd (List.nth sys (C2Ml.nat n))
+ | Mc.PsatzSquare c -> Mc.PsatzSquare c
+ | Mc.PsatzMulC(c,p) -> Mc.PsatzMulC(c, map_psatz p)
+ | Mc.PsatzMulE(p1,p2) -> Mc.PsatzMulE(map_psatz p1,map_psatz p2)
+ | Mc.PsatzAdd(p1,p2) -> Mc.PsatzAdd(map_psatz p1,map_psatz p2)
+ | Mc.PsatzC c -> Mc.PsatzC c
+ | Mc.PsatzZ -> Mc.PsatzZ in
+ Some (map_psatz cert)
@@ -395,11 +461,11 @@ let make_linear_system l =
(Poly.constant (Int 0)) l' in
let monomials = Poly.fold
(fun mn _ l -> if Pervasives.(=) mn Monomial.const then l else mn::l) monomials [] in
- (List.map (fun (c,op) ->
- {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ;
- op = op ;
- cst = minus_num ( (Poly.get Monomial.const c))}) l
- ,monomials)
+ (List.map (fun (c,op) ->
+ {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ;
+ op = op ;
+ cst = minus_num ( (Poly.get Monomial.const c))}) l
+ ,monomials)
let pplus x y = Mc.PEadd(x,y)
@@ -413,7 +479,7 @@ let rec mem p x l =
let rec remove_assoc p x l =
match l with [] -> [] | e::l -> if p x (fst e) then
- remove_assoc p x l else e::(remove_assoc p x l)
+ remove_assoc p x l else e::(remove_assoc p x l)
let eq x y = Int.equal (Vect.compare x y) 0
@@ -424,39 +490,39 @@ let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l
only searching for naive cutting planes *)
let develop_constraint z_spec (e,k) =
- match k with
- | Mc.NonStrict -> (dev_form z_spec e , Ge)
- | Mc.Equal -> (dev_form z_spec e , Eq)
- | _ -> assert false
+ match k with
+ | Mc.NonStrict -> (dev_form z_spec e , Ge)
+ | Mc.Equal -> (dev_form z_spec e , Eq)
+ | _ -> assert false
let op_of_op_compat = function
- | Ge -> Mc.NonStrict
- | Eq -> Mc.Equal
+ | Ge -> Mc.NonStrict
+ | Eq -> Mc.Equal
let integer_vector coeffs =
- let vars , coeffs = List.split coeffs in
- List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs))
+ let vars , coeffs = List.split coeffs in
+ List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs))
let integer_cstr {coeffs = coeffs ; op = op ; cst = cst } =
- let vars , coeffs = List.split coeffs in
- match rats_to_ints (cst::coeffs) with
- | cst :: coeffs ->
- {
- coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ;
- op = op ; cst = Big_int cst}
- | _ -> assert false
-
+ let vars , coeffs = List.split coeffs in
+ match rats_to_ints (cst::coeffs) with
+ | cst :: coeffs ->
+ {
+ coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ;
+ op = op ; cst = Big_int cst}
+ | _ -> assert false
+
let pexpr_of_cstr_compat var cstr =
- let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in
- try
- let expr = list_to_polynomial var (Vect.to_list coeffs) in
- let d = Ml2C.bigint (denominator cst) in
- let n = Ml2C.bigint (numerator cst) in
- (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op)
- with Failure _ -> failwith "pexpr_of_cstr_compat"
+ let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in
+ try
+ let expr = list_to_polynomial var (Vect.to_list coeffs) in
+ let d = Ml2C.bigint (denominator cst) in
+ let n = Ml2C.bigint (numerator cst) in
+ (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op)
+ with Failure _ -> failwith "pexpr_of_cstr_compat"
@@ -465,41 +531,41 @@ open Sos_types
let rec scale_term t =
match t with
- | Zero -> unit_big_int , Zero
- | Const n -> (denominator n) , Const (Big_int (numerator n))
- | Var n -> unit_big_int , Var n
- | Inv _ -> failwith "scale_term : not implemented"
- | Opp t -> let s, t = scale_term t in s, Opp t
- | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in
- let g = gcd_big_int s1 s2 in
- let s1' = div_big_int s1 g in
- let s2' = div_big_int s2 g in
- let e = mult_big_int g (mult_big_int s1' s2') in
- if Int.equal (compare_big_int e unit_big_int) 0
- then (unit_big_int, Add (y1,y2))
- else e, Add (Mul(Const (Big_int s2'), y1),
- Mul (Const (Big_int s1'), y2))
- | Sub _ -> failwith "scale term: not implemented"
- | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in
- mult_big_int s1 s2 , Mul (y1, y2)
- | Pow(t,n) -> let s,t = scale_term t in
- power_big_int_positive_int s n , Pow(t,n)
- | _ -> failwith "scale_term : not implemented"
+ | Zero -> unit_big_int , Zero
+ | Const n -> (denominator n) , Const (Big_int (numerator n))
+ | Var n -> unit_big_int , Var n
+ | Inv _ -> failwith "scale_term : not implemented"
+ | Opp t -> let s, t = scale_term t in s, Opp t
+ | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in
+ let g = gcd_big_int s1 s2 in
+ let s1' = div_big_int s1 g in
+ let s2' = div_big_int s2 g in
+ let e = mult_big_int g (mult_big_int s1' s2') in
+ if Int.equal (compare_big_int e unit_big_int) 0
+ then (unit_big_int, Add (y1,y2))
+ else e, Add (Mul(Const (Big_int s2'), y1),
+ Mul (Const (Big_int s1'), y2))
+ | Sub _ -> failwith "scale term: not implemented"
+ | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in
+ mult_big_int s1 s2 , Mul (y1, y2)
+ | Pow(t,n) -> let s,t = scale_term t in
+ power_big_int_positive_int s n , Pow(t,n)
+ | _ -> failwith "scale_term : not implemented"
let scale_term t =
let (s,t') = scale_term t in
- s,t'
+ s,t'
let get_index_of_ith_match f i l =
let rec get j res l =
match l with
- | [] -> failwith "bad index"
- | e::l -> if f e
- then
- (if Int.equal j i then res else get (j+1) (res+1) l )
- else get j (res+1) l in
- get 0 0 l
+ | [] -> failwith "bad index"
+ | e::l -> if f e
+ then
+ (if Int.equal j i then res else get (j+1) (res+1) l )
+ else get j (res+1) l in
+ get 0 0 l
let rec scale_certificate pos = match pos with
@@ -511,97 +577,97 @@ let rec scale_certificate pos = match pos with
| Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n))
| Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n))
| Square t -> let s,t' = scale_term t in
- mult_big_int s s , Square t'
+ mult_big_int s s , Square t'
| Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in
- mult_big_int s1 s2 , Eqmul (y1,y2)
+ mult_big_int s1 s2 , Eqmul (y1,y2)
| Sum (y, z) -> let s1,y1 = scale_certificate y
- and s2,y2 = scale_certificate z in
- let g = gcd_big_int s1 s2 in
- let s1' = div_big_int s1 g in
- let s2' = div_big_int s2 g in
- mult_big_int g (mult_big_int s1' s2'),
- Sum (Product(Rational_le (Big_int s2'), y1),
- Product (Rational_le (Big_int s1'), y2))
+ and s2,y2 = scale_certificate z in
+ let g = gcd_big_int s1 s2 in
+ let s1' = div_big_int s1 g in
+ let s2' = div_big_int s2 g in
+ mult_big_int g (mult_big_int s1' s2'),
+ Sum (Product(Rational_le (Big_int s2'), y1),
+ Product (Rational_le (Big_int s1'), y2))
| Product (y, z) ->
- let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in
- mult_big_int s1 s2 , Product (y1,y2)
+ let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in
+ mult_big_int s1 s2 , Product (y1,y2)
open Micromega
- let rec term_to_q_expr = function
- | Const n -> PEc (Ml2C.q n)
- | Zero -> PEc ( Ml2C.q (Int 0))
- | Var s -> PEX (Ml2C.index
- (int_of_string (String.sub s 1 (String.length s - 1))))
- | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2)
- | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2)
- | Opp p -> PEopp (term_to_q_expr p)
- | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n)
- | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2)
- | _ -> failwith "term_to_q_expr: not implemented"
-
- let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e)
-
-
- let rec product l =
- match l with
- | [] -> Mc.PsatzZ
- | [i] -> Mc.PsatzIn (Ml2C.nat i)
- | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l)
+let rec term_to_q_expr = function
+ | Const n -> PEc (Ml2C.q n)
+ | Zero -> PEc ( Ml2C.q (Int 0))
+ | Var s -> PEX (Ml2C.index
+ (int_of_string (String.sub s 1 (String.length s - 1))))
+ | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2)
+ | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2)
+ | Opp p -> PEopp (term_to_q_expr p)
+ | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n)
+ | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2)
+ | _ -> failwith "term_to_q_expr: not implemented"
+
+let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e)
+
+
+let rec product l =
+ match l with
+ | [] -> Mc.PsatzZ
+ | [i] -> Mc.PsatzIn (Ml2C.nat i)
+ | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l)
let q_cert_of_pos pos =
let rec _cert_of_pos = function
- Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
+ Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
| Axiom_le i -> Mc.PsatzIn (Ml2C.nat i)
| Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i)
| Monoid l -> product l
| Rational_eq n | Rational_le n | Rational_lt n ->
- if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
- Mc.PsatzC (Ml2C.q n)
+ if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
+ Mc.PsatzC (Ml2C.q n)
| Square t -> Mc.PsatzSquare (term_to_q_pol t)
| Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y)
| Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z)
| Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in
- simplify_cone q_spec (_cert_of_pos pos)
+ simplify_cone q_spec (_cert_of_pos pos)
- let rec term_to_z_expr = function
- | Const n -> PEc (Ml2C.bigint (big_int_of_num n))
- | Zero -> PEc ( Z0)
- | Var s -> PEX (Ml2C.index
- (int_of_string (String.sub s 1 (String.length s - 1))))
- | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2)
- | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2)
- | Opp p -> PEopp (term_to_z_expr p)
- | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n)
- | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2)
- | _ -> failwith "term_to_z_expr: not implemented"
+let rec term_to_z_expr = function
+ | Const n -> PEc (Ml2C.bigint (big_int_of_num n))
+ | Zero -> PEc ( Z0)
+ | Var s -> PEX (Ml2C.index
+ (int_of_string (String.sub s 1 (String.length s - 1))))
+ | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2)
+ | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2)
+ | Opp p -> PEopp (term_to_z_expr p)
+ | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n)
+ | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2)
+ | _ -> failwith "term_to_z_expr: not implemented"
- let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e)
+let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e)
let z_cert_of_pos pos =
let s,pos = (scale_certificate pos) in
let rec _cert_of_pos = function
- Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
+ Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
| Axiom_le i -> Mc.PsatzIn (Ml2C.nat i)
| Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i)
| Monoid l -> product l
| Rational_eq n | Rational_le n | Rational_lt n ->
- if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
- Mc.PsatzC (Ml2C.bigint (big_int_of_num n))
+ if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
+ Mc.PsatzC (Ml2C.bigint (big_int_of_num n))
| Square t -> Mc.PsatzSquare (term_to_z_pol t)
| Eqmul (t, y) ->
- let is_unit =
- match t with
- | Const n -> n =/ Int 1
- | _ -> false in
- if is_unit
- then _cert_of_pos y
- else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y)
+ let is_unit =
+ match t with
+ | Const n -> n =/ Int 1
+ | _ -> false in
+ if is_unit
+ then _cert_of_pos y
+ else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y)
| Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z)
| Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in
- simplify_cone z_spec (_cert_of_pos pos)
+ simplify_cone z_spec (_cert_of_pos pos)
(** All constraints (initial or derived) have an index and have a justification i.e., proof.
Given a constraint, all the coefficients are always integers.
@@ -612,116 +678,109 @@ open Num
open Big_int
open Polynomial
-(*module Mc = Micromega*)
-(*module Ml2C = Mutils.CamlToCoq
-module C2Ml = Mutils.CoqToCaml
-*)
-let debug = false
-
-
module Env =
struct
- type t = int list
+ type t = int list
- let id_of_hyp hyp l =
- let rec xid_of_hyp i l =
- match l with
- | [] -> failwith "id_of_hyp"
- | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in
- xid_of_hyp 0 l
+ let id_of_hyp hyp l =
+ let rec xid_of_hyp i l =
+ match l with
+ | [] -> failwith "id_of_hyp"
+ | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in
+ xid_of_hyp 0 l
end
let coq_poly_of_linpol (p,c) =
- let pol_of_mon m =
- Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in
+ let pol_of_mon m =
+ Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in
- List.fold_left (fun acc (x,v) ->
- let mn = LinPoly.MonT.retrieve x in
- Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p
-
+ List.fold_left (fun acc (x,v) ->
+ let mn = LinPoly.MonT.retrieve x in
+ Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p
+
let rec cmpl_prf_rule env = function
- | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env))
- | Cst i -> Mc.PsatzC (Ml2C.bigint i)
- | Zero -> Mc.PsatzZ
- | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2)
- | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2)
- | MulC(lp,p) -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in
- Mc.PsatzMulC(lp,cmpl_prf_rule env p)
- | Square lp -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp))
- | _ -> failwith "Cuts should already be compiled"
-
+ | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env))
+ | Cst i -> Mc.PsatzC (Ml2C.bigint i)
+ | Zero -> Mc.PsatzZ
+ | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2)
+ | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2)
+ | MulC(lp,p) -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in
+ Mc.PsatzMulC(lp,cmpl_prf_rule env p)
+ | Square lp -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp))
+ | _ -> failwith "Cuts should already be compiled"
+
let rec cmpl_proof env = function
- | Done -> Mc.DoneProof
- | Step(i,p,prf) ->
- begin
- match p with
- | CutPrf p' ->
- Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf)
- | _ -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf)
- end
- | Enum(i,p1,_,p2,l) ->
- Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l)
+ | Done -> Mc.DoneProof
+ | Step(i,p,prf) ->
+ begin
+ match p with
+ | CutPrf p' ->
+ Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf)
+ | _ -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf)
+ end
+ | Enum(i,p1,_,p2,l) ->
+ Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l)
let compile_proof env prf =
- let id = 1 + proof_max_id prf in
- let _,prf = normalise_proof id prf in
- if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf;
- cmpl_proof env prf
+ let id = 1 + proof_max_id prf in
+ let _,prf = normalise_proof id prf in
+ if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf;
+ cmpl_proof env prf
type prf_sys = (cstr_compat * prf_rule) list
let xlinear_prover sys =
- match Fourier.find_point sys with
- | Inr prf ->
- if debug then Printf.printf "AProof : %a\n" pp_proof prf ;
- let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in
- if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ;
- Some (rats_to_ints (Vect.to_list cert))
- | Inl _ -> None
+ match Fourier.find_point sys with
+ | Inr prf ->
+ if debug then Printf.printf "AProof : %a\n" pp_proof prf ;
+ let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in
+ if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ;
+ Some (rats_to_ints (Vect.to_list cert))
+ | Inl _ -> None
let output_num o n = output_string o (string_of_num n)
let output_bigint o n = output_string o (string_of_big_int n)
let proof_of_farkas prf cert =
-(* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *)
- let rec mk_farkas acc prf cert =
- match prf, cert with
- | _ , [] -> acc
- | [] , _ -> failwith "proof_of_farkas : not enough hyps"
- | p::prf,c::cert ->
- mk_farkas (add_proof (mul_proof c p) acc) prf cert in
- let res = mk_farkas Zero prf cert in
+ (* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *)
+ let rec mk_farkas acc prf cert =
+ match prf, cert with
+ | _ , [] -> acc
+ | [] , _ -> failwith "proof_of_farkas : not enough hyps"
+ | p::prf,c::cert ->
+ mk_farkas (add_proof (mul_proof c p) acc) prf cert in
+ let res = mk_farkas Zero prf cert in
(*Printf.printf "==> %a" output_prf_rule res ; *)
- res
+ res
let linear_prover sys =
- let (sysi,prfi) = List.split sys in
- match xlinear_prover sysi with
- | None -> None
- | Some cert -> Some (proof_of_farkas prfi cert)
+ let (sysi,prfi) = List.split sys in
+ match xlinear_prover sysi with
+ | None -> None
+ | Some cert -> Some (proof_of_farkas prfi cert)
let linear_prover =
- if debug
- then
- fun sys ->
- Printf.printf "<linear_prover"; flush stdout ;
- let res = linear_prover sys in
- Printf.printf ">"; flush stdout ;
- res
- else linear_prover
+ if debug
+ then
+ fun sys ->
+ Printf.printf "<linear_prover"; flush stdout ;
+ let res = linear_prover sys in
+ Printf.printf ">"; flush stdout ;
+ res
+ else linear_prover
@@ -733,11 +792,11 @@ let linear_prover =
*)
type checksat =
- | Tauto (* Tautology *)
- | Unsat of prf_rule (* Unsatisfiable *)
- | Cut of cstr_compat * prf_rule (* Cutting plane *)
- | Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *)
-
+| Tauto (* Tautology *)
+| Unsat of prf_rule (* Unsatisfiable *)
+| Cut of cstr_compat * prf_rule (* Cutting plane *)
+| Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *)
+
(** [check_sat]
- detects constraints that are not satisfiable;
@@ -745,83 +804,83 @@ type checksat =
*)
let check_sat (cstr,prf) =
- let {coeffs=coeffs ; op=op ; cst=cst} = cstr in
- match coeffs with
- | [] ->
- if eval_op op (Int 0) cst then Tauto else Unsat prf
- | _ ->
- let gcdi = (gcd_list (List.map snd coeffs)) in
- let gcd = Big_int gcdi in
- if eq_num gcd (Int 1)
- then Normalise(cstr,prf)
- else
- if Int.equal (sign_num (mod_num cst gcd)) 0
- then (* We can really normalise *)
- begin
- assert (sign_num gcd >=1 ) ;
- let cstr = {
- coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs;
- op = op ; cst = cst // gcd
- } in
- Normalise(cstr,Gcd(gcdi,prf))
- (* Normalise(cstr,CutPrf prf)*)
- end
- else
- match op with
- | Eq -> Unsat (CutPrf prf)
- | Ge ->
- let cstr = {
- coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs;
- op = op ; cst = ceiling_num (cst // gcd)
- } in Cut(cstr,CutPrf prf)
+ let {coeffs=coeffs ; op=op ; cst=cst} = cstr in
+ match coeffs with
+ | [] ->
+ if eval_op op (Int 0) cst then Tauto else Unsat prf
+ | _ ->
+ let gcdi = (gcd_list (List.map snd coeffs)) in
+ let gcd = Big_int gcdi in
+ if eq_num gcd (Int 1)
+ then Normalise(cstr,prf)
+ else
+ if Int.equal (sign_num (mod_num cst gcd)) 0
+ then (* We can really normalise *)
+ begin
+ assert (sign_num gcd >=1 ) ;
+ let cstr = {
+ coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs;
+ op = op ; cst = cst // gcd
+ } in
+ Normalise(cstr,Gcd(gcdi,prf))
+ (* Normalise(cstr,CutPrf prf)*)
+ end
+ else
+ match op with
+ | Eq -> Unsat (CutPrf prf)
+ | Ge ->
+ let cstr = {
+ coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs;
+ op = op ; cst = ceiling_num (cst // gcd)
+ } in Cut(cstr,CutPrf prf)
(** Proof generating pivoting over variable v *)
let pivot v (c1,p1) (c2,p2) =
- let {coeffs = v1 ; op = op1 ; cst = n1} = c1
- and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
+ let {coeffs = v1 ; op = op1 ; cst = n1} = c1
+ and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
(* Could factorise gcd... *)
- let xpivot cv1 cv2 =
- (
- {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ;
- op = Proof.add_op op1 op2 ;
- cst = n1 */ cv1 +/ n2 */ cv2 },
+ let xpivot cv1 cv2 =
+ (
+ {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ;
+ op = Proof.add_op op1 op2 ;
+ cst = n1 */ cv1 +/ n2 */ cv2 },
- AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in
+ AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in
+
+ match Vect.get v v1 , Vect.get v v2 with
+ | None , _ | _ , None -> None
+ | Some a , Some b ->
+ if Int.equal ((sign_num a) * (sign_num b)) (-1)
+ then
+ let cv1 = abs_num b
+ and cv2 = abs_num a in
+ Some (xpivot cv1 cv2)
+ else
+ if op1 == Eq
+ then
+ let cv1 = minus_num (b */ (Int (sign_num a)))
+ and cv2 = abs_num a in
+ Some (xpivot cv1 cv2)
+ else if op2 == Eq
+ then
+ let cv1 = abs_num b
+ and cv2 = minus_num (a */ (Int (sign_num b))) in
+ Some (xpivot cv1 cv2)
+ else None (* op2 could be Eq ... this might happen *)
- match Vect.get v v1 , Vect.get v v2 with
- | None , _ | _ , None -> None
- | Some a , Some b ->
- if Int.equal ((sign_num a) * (sign_num b)) (-1)
- then
- let cv1 = abs_num b
- and cv2 = abs_num a in
- Some (xpivot cv1 cv2)
- else
- if op1 == Eq
- then
- let cv1 = minus_num (b */ (Int (sign_num a)))
- and cv2 = abs_num a in
- Some (xpivot cv1 cv2)
- else if op2 == Eq
- then
- let cv1 = abs_num b
- and cv2 = minus_num (a */ (Int (sign_num b))) in
- Some (xpivot cv1 cv2)
- else None (* op2 could be Eq ... this might happen *)
-
exception FoundProof of prf_rule
let simpl_sys sys =
- List.fold_left (fun acc (c,p) ->
- match check_sat (c,p) with
- | Tauto -> acc
- | Unsat prf -> raise (FoundProof prf)
- | Cut(c,p) -> (c,p)::acc
- | Normalise (c,p) -> (c,p)::acc) [] sys
+ List.fold_left (fun acc (c,p) ->
+ match check_sat (c,p) with
+ | Tauto -> acc
+ | Unsat prf -> raise (FoundProof prf)
+ | Cut(c,p) -> (c,p)::acc
+ | Normalise (c,p) -> (c,p)::acc) [] sys
(** [ext_gcd a b] is the extended Euclid algorithm.
@@ -829,77 +888,77 @@ let simpl_sys sys =
Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
*)
let rec ext_gcd a b =
- if Int.equal (sign_big_int b) 0
- then (unit_big_int,zero_big_int)
- else
- let (q,r) = quomod_big_int a b in
- let (s,t) = ext_gcd b r in
- (t, sub_big_int s (mult_big_int q t))
+ if Int.equal (sign_big_int b) 0
+ then (unit_big_int,zero_big_int)
+ else
+ let (q,r) = quomod_big_int a b in
+ let (s,t) = ext_gcd b r in
+ (t, sub_big_int s (mult_big_int q t))
let pp_ext_gcd a b =
- let a' = big_int_of_int a in
- let b' = big_int_of_int b in
-
- let (x,y) = ext_gcd a' b' in
- Printf.fprintf stdout "%s * %s + %s * %s = %s\n"
- (string_of_big_int x) (string_of_big_int a')
- (string_of_big_int y) (string_of_big_int b')
- (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b')))
+ let a' = big_int_of_int a in
+ let b' = big_int_of_int b in
+
+ let (x,y) = ext_gcd a' b' in
+ Printf.fprintf stdout "%s * %s + %s * %s = %s\n"
+ (string_of_big_int x) (string_of_big_int a')
+ (string_of_big_int y) (string_of_big_int b')
+ (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b')))
exception Result of (int * (proof * cstr_compat))
let split_equations psys =
- List.partition (fun (c,p) -> c.op == Eq)
+ List.partition (fun (c,p) -> c.op == Eq)
let extract_coprime (c1,p1) (c2,p2) =
- let rec exist2 vect1 vect2 =
- match vect1 , vect2 with
- | _ , [] | [], _ -> None
- | (v1,n1)::vect1' , (v2, n2) :: vect2' ->
- if Pervasives.(=) v1 v2
- then
- if Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0
- then Some (v1,n1,n2)
- else
- exist2 vect1' vect2'
- else
- if v1 < v2
- then exist2 vect1' vect2
- else exist2 vect1 vect2' in
-
- if c1.op == Eq && c2.op == Eq
- then exist2 c1.coeffs c2.coeffs
- else None
+ let rec exist2 vect1 vect2 =
+ match vect1 , vect2 with
+ | _ , [] | [], _ -> None
+ | (v1,n1)::vect1' , (v2, n2) :: vect2' ->
+ if Pervasives.(=) v1 v2
+ then
+ if Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0
+ then Some (v1,n1,n2)
+ else
+ exist2 vect1' vect2'
+ else
+ if v1 < v2
+ then exist2 vect1' vect2
+ else exist2 vect1 vect2' in
+
+ if c1.op == Eq && c2.op == Eq
+ then exist2 c1.coeffs c2.coeffs
+ else None
let extract2 pred l =
- let rec xextract2 rl l =
- match l with
- | [] -> (None,rl) (* Did not find *)
- | e::l ->
- match extract (pred e) l with
- | None,_ -> xextract2 (e::rl) l
- | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in
-
- xextract2 [] l
+ let rec xextract2 rl l =
+ match l with
+ | [] -> (None,rl) (* Did not find *)
+ | e::l ->
+ match extract (pred e) l with
+ | None,_ -> xextract2 (e::rl) l
+ | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in
+
+ xextract2 [] l
let extract_coprime_equation psys =
- extract2 extract_coprime psys
+ extract2 extract_coprime psys
let apply_and_normalise f psys =
- List.fold_left (fun acc pc' ->
- match f pc' with
- | None -> pc'::acc
- | Some pc' ->
- match check_sat pc' with
- | Tauto -> acc
- | Unsat prf -> raise (FoundProof prf)
- | Cut(c,p) -> (c,p)::acc
- | Normalise (c,p) -> (c,p)::acc
- ) [] psys
+ List.fold_left (fun acc pc' ->
+ match f pc' with
+ | None -> pc'::acc
+ | Some pc' ->
+ match check_sat pc' with
+ | Tauto -> acc
+ | Unsat prf -> raise (FoundProof prf)
+ | Cut(c,p) -> (c,p)::acc
+ | Normalise (c,p) -> (c,p)::acc
+ ) [] psys
@@ -908,314 +967,317 @@ let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys
let reduce_coprime psys =
- let oeq,sys = extract_coprime_equation psys in
- match oeq with
- | None -> None (* Nothing to do *)
- | Some((v,n1,n2),(c1,p1),(c2,p2) ) ->
- let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in
- let l1' = Big_int l1 and l2' = Big_int l2 in
- let cstr =
- {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs);
- op = Eq ;
- cst = (l1' */ c1.cst) +/ (l2' */ c2.cst)
- } in
- let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in
-
- Some (pivot_sys v (cstr,prf) ((c1,p1)::sys))
+ let oeq,sys = extract_coprime_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some((v,n1,n2),(c1,p1),(c2,p2) ) ->
+ let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in
+ let l1' = Big_int l1 and l2' = Big_int l2 in
+ let cstr =
+ {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs);
+ op = Eq ;
+ cst = (l1' */ c1.cst) +/ (l2' */ c2.cst)
+ } in
+ let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in
+
+ Some (pivot_sys v (cstr,prf) ((c1,p1)::sys))
(** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *)
let reduce_unary psys =
- let is_unary_equation (cstr,prf) =
- if cstr.op == Eq
- then
- try
- Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs))
- with Not_found -> None
- else None in
-
- let (oeq,sys) = extract is_unary_equation psys in
- match oeq with
- | None -> None (* Nothing to do *)
- | Some(v,pc) ->
- Some(pivot_sys v pc sys)
+ let is_unary_equation (cstr,prf) =
+ if cstr.op == Eq
+ then
+ try
+ Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs))
+ with Not_found -> None
+ else None in
+
+ let (oeq,sys) = extract is_unary_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) ->
+ Some(pivot_sys v pc sys)
let reduce_non_lin_unary psys =
- let is_unary_equation (cstr,prf) =
- if cstr.op == Eq
- then
- try
- let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in
- let x' = LinPoly.MonT.retrieve x in
- if List.for_all (fun (y,_) -> Pervasives.(=) y x || Int.equal (snd (Monomial.div (LinPoly.MonT.retrieve y) x')) 0) cstr.coeffs
- then Some x
- else None
- with Not_found -> None
- else None in
-
-
- let (oeq,sys) = extract is_unary_equation psys in
- match oeq with
- | None -> None (* Nothing to do *)
- | Some(v,pc) ->
- Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys)
+ let is_unary_equation (cstr,prf) =
+ if cstr.op == Eq
+ then
+ try
+ let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in
+ let x' = LinPoly.MonT.retrieve x in
+ if List.for_all (fun (y,_) -> Pervasives.(=) y x || Int.equal (snd (Monomial.div (LinPoly.MonT.retrieve y) x')) 0) cstr.coeffs
+ then Some x
+ else None
+ with Not_found -> None
+ else None in
+
+
+ let (oeq,sys) = extract is_unary_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) ->
+ Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys)
let reduce_var_change psys =
- let rec rel_prime vect =
- match vect with
- | [] -> None
- | (x,v)::vect ->
- let v = numerator v in
- try
- let (x',v') = List.find (fun (_,v') ->
- let v' = numerator v' in
- eq_big_int (gcd_big_int v v') unit_big_int) vect in
- Some ((x,v),(x',numerator v'))
- with Not_found -> rel_prime vect in
-
- let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in
-
- let (oeq,sys) = extract rel_prime psys in
-
- match oeq with
- | None -> None
- | Some(((x,v),(x',v')),(c,p)) ->
- let (l1,l2) = ext_gcd v v' in
- let l1,l2 = Big_int l1 , Big_int l2 in
+ let rec rel_prime vect =
+ match vect with
+ | [] -> None
+ | (x,v)::vect ->
+ let v = numerator v in
+ try
+ let (x',v') = List.find (fun (_,v') ->
+ let v' = numerator v' in
+ eq_big_int (gcd_big_int v v') unit_big_int) vect in
+ Some ((x,v),(x',numerator v'))
+ with Not_found -> rel_prime vect in
- let get v vect =
- match Vect.get v vect with
- | None -> Int 0
- | Some n -> n in
+ let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in
- let pivot_eq (c',p') =
- let {coeffs = coeffs ; op = op ; cst = cst} = c' in
- let vx = get x coeffs in
- let vx' = get x' coeffs in
- let m = minus_num (vx */ l1 +/ vx' */ l2) in
- Some ({coeffs =
- Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} ,
- AddPrf(MulC(([], m),p),p')) in
+ let (oeq,sys) = extract rel_prime psys in
+
+ match oeq with
+ | None -> None
+ | Some(((x,v),(x',v')),(c,p)) ->
+ let (l1,l2) = ext_gcd v v' in
+ let l1,l2 = Big_int l1 , Big_int l2 in
- Some (apply_and_normalise pivot_eq sys)
+ let get v vect =
+ match Vect.get v vect with
+ | None -> Int 0
+ | Some n -> n in
+ let pivot_eq (c',p') =
+ let {coeffs = coeffs ; op = op ; cst = cst} = c' in
+ let vx = get x coeffs in
+ let vx' = get x' coeffs in
+ let m = minus_num (vx */ l1 +/ vx' */ l2) in
+ Some ({coeffs =
+ Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} ,
+ AddPrf(MulC(([], m),p),p')) in
+ Some (apply_and_normalise pivot_eq sys)
- let reduce_pivot psys =
- let is_equation (cstr,prf) =
- if cstr.op == Eq
- then
- try
- Some (fst (List.hd cstr.coeffs))
- with Not_found -> None
- else None in
- let (oeq,sys) = extract is_equation psys in
- match oeq with
- | None -> None (* Nothing to do *)
- | Some(v,pc) ->
- if debug then
- Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst);
- Some(pivot_sys v pc sys)
+let reduce_pivot psys =
+ let is_equation (cstr,prf) =
+ if cstr.op == Eq
+ then
+ try
+ Some (fst (List.hd cstr.coeffs))
+ with Not_found -> None
+ else None in
+ let (oeq,sys) = extract is_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) ->
+ if debug then
+ Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst);
+ Some(pivot_sys v pc sys)
- let iterate_until_stable f x =
- let rec iter x =
- match f x with
- | None -> x
- | Some x' -> iter x' in
- iter x
- let rec app_funs l x =
- match l with
- | [] -> None
- | f::fl ->
- match f x with
- | None -> app_funs fl x
- | Some x' -> Some x'
- let reduction_equations psys =
- iterate_until_stable (app_funs
- [reduce_unary ; reduce_coprime ;
- reduce_var_change (*; reduce_pivot*)]) psys
+let iterate_until_stable f x =
+ let rec iter x =
+ match f x with
+ | None -> x
+ | Some x' -> iter x' in
+ iter x
- let reduction_non_lin_equations psys =
- iterate_until_stable (app_funs
- [reduce_non_lin_unary (*; reduce_coprime ;
- reduce_var_change ; reduce_pivot *)]) psys
+let rec app_funs l x =
+ match l with
+ | [] -> None
+ | f::fl ->
+ match f x with
+ | None -> app_funs fl x
+ | Some x' -> Some x'
+
+let reduction_equations psys =
+ iterate_until_stable (app_funs
+ [reduce_unary ; reduce_coprime ;
+ reduce_var_change (*; reduce_pivot*)]) psys
+
+let reduction_non_lin_equations psys =
+ iterate_until_stable (app_funs
+ [reduce_non_lin_unary (*; reduce_coprime ;
+ reduce_var_change ; reduce_pivot *)]) psys
(** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *)
- let get_bound sys =
- let is_small (v,i) =
- match Itv.range i with
- | None -> false
- | Some i -> i <=/ (Int 1) in
-
- let select_best (x1,i1) (x2,i2) =
- if Itv.smaller_itv i1 i2
- then (x1,i1) else (x2,i2) in
+let get_bound sys =
+ let is_small (v,i) =
+ match Itv.range i with
+ | None -> false
+ | Some i -> i <=/ (Int 1) in
+
+ let select_best (x1,i1) (x2,i2) =
+ if Itv.smaller_itv i1 i2
+ then (x1,i1) else (x2,i2) in
(* For lia, there are no equations => these precautions are not needed *)
(* For nlia, there are equations => do not enumerate over equations! *)
- let all_planes sys =
- let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in
- match eq with
- | [] -> List.rev_map (fun c -> c.coeffs) ineq
- | _ ->
- List.fold_left (fun acc c ->
- if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq
- then acc else c.coeffs ::acc) [] ineq in
-
- let smallest_interval =
- List.fold_left
- (fun acc vect ->
- if is_small acc
- then acc
- else
- match Fourier.optimise vect sys with
- | None -> acc
- | Some i ->
- if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ;
- select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in
- let smallest_interval =
- match smallest_interval
- with
- | (x,(Some i, Some j)) -> Some(i,x,j)
- | x -> None (* This should not be possible *)
- in
- match smallest_interval with
- | Some (lb,e,ub) ->
- let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in
- let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in
- (match
+ let all_planes sys =
+ let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in
+ match eq with
+ | [] -> List.rev_map (fun c -> c.coeffs) ineq
+ | _ ->
+ List.fold_left (fun acc c ->
+ if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq
+ then acc else c.coeffs ::acc) [] ineq in
+
+ let smallest_interval =
+ List.fold_left
+ (fun acc vect ->
+ if is_small acc
+ then acc
+ else
+ match Fourier.optimise vect sys with
+ | None -> acc
+ | Some i ->
+ if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ;
+ select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in
+ let smallest_interval =
+ match smallest_interval
+ with
+ | (x,(Some i, Some j)) -> Some(i,x,j)
+ | x -> None (* This should not be possible *)
+ in
+ match smallest_interval with
+ | Some (lb,e,ub) ->
+ let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in
+ let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in
+ (match
(* x <= ub -> x > ub *)
- xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys),
+ xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys),
(* lb <= x -> lb > x *)
- xlinear_prover
- ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys)
- with
- | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub)
- | _ -> failwith "Interval without proof"
- )
- | None -> None
-
-
- let check_sys sys =
- List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys
-
-
- let xlia reduction_equations sys =
-
- let rec enum_proof (id:int) (sys:prf_sys) : proof option =
- if debug then (Printf.printf "enum_proof\n" ; flush stdout) ;
- assert (check_sys sys) ;
-
- let nsys,prf = List.split sys in
- match get_bound nsys with
- | None -> None (* Is the systeme really unbounded ? *)
- | Some(prf1,(lb,e,ub),prf2) ->
- if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ;
- (match start_enum id e (ceiling_num lb) (floor_num ub) sys
- with
- | Some prfl ->
- Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl))
- | None -> None
- )
-
- and start_enum id e clb cub sys =
- if clb >/ cub
- then Some []
- else
- let eq = {coeffs = e ; op = Eq ; cst = clb} in
- match aux_lia (id+1) ((eq, Def id) :: sys) with
- | None -> None
- | Some prf ->
- match start_enum id e (clb +/ (Int 1)) cub sys with
- | None -> None
- | Some l -> Some (prf::l)
-
- and aux_lia (id:int) (sys:prf_sys) : proof option =
- assert (check_sys sys) ;
- if debug then Printf.printf "xlia: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ;
- try
- let sys = reduction_equations sys in
- if debug then
+ xlinear_prover
+ ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys)
+ with
+ | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub)
+ | _ -> failwith "Interval without proof"
+ )
+ | None -> None
+
+
+let check_sys sys =
+ List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys
+
+
+let xlia (can_enum:bool) reduction_equations sys =
+
+
+ let rec enum_proof (id:int) (sys:prf_sys) : proof option =
+ if debug then (Printf.printf "enum_proof\n" ; flush stdout) ;
+ assert (check_sys sys) ;
+
+ let nsys,prf = List.split sys in
+ match get_bound nsys with
+ | None -> None (* Is the systeme really unbounded ? *)
+ | Some(prf1,(lb,e,ub),prf2) ->
+ if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ;
+ (match start_enum id e (ceiling_num lb) (floor_num ub) sys
+ with
+ | Some prfl ->
+ Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl))
+ | None -> None
+ )
+
+ and start_enum id e clb cub sys =
+ if clb >/ cub
+ then Some []
+ else
+ let eq = {coeffs = e ; op = Eq ; cst = clb} in
+ match aux_lia (id+1) ((eq, Def id) :: sys) with
+ | None -> None
+ | Some prf ->
+ match start_enum id e (clb +/ (Int 1)) cub sys with
+ | None -> None
+ | Some l -> Some (prf::l)
+
+ and aux_lia (id:int) (sys:prf_sys) : proof option =
+ assert (check_sys sys) ;
+ if debug then Printf.printf "xlia: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ;
+ try
+ let sys = reduction_equations sys in
+ if debug then
Printf.printf "after reduction: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ;
- match linear_prover sys with
- | Some prf -> Some (Step(id,prf,Done))
- | None -> enum_proof id sys
- with FoundProof prf ->
+ match linear_prover sys with
+ | Some prf -> Some (Step(id,prf,Done))
+ | None -> if can_enum then enum_proof id sys else None
+ with FoundProof prf ->
(* [reduction_equations] can find a proof *)
- Some(Step(id,prf,Done)) in
+ Some(Step(id,prf,Done)) in
(* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*)
- let id = List.length sys in
- let orpf =
- try
- let sys = simpl_sys sys in
- aux_lia id sys
- with FoundProof pr -> Some(Step(id,pr,Done)) in
- match orpf with
- | None -> None
- | Some prf ->
+ let id = List.length sys in
+ let orpf =
+ try
+ let sys = simpl_sys sys in
+ aux_lia id sys
+ with FoundProof pr -> Some(Step(id,pr,Done)) in
+ match orpf with
+ | None -> None
+ | Some prf ->
(*Printf.printf "direct proof %a\n" output_proof prf ; *)
- let env = mapi (fun _ i -> i) sys in
- let prf = compile_proof env prf in
+ let env = mapi (fun _ i -> i) sys in
+ let prf = compile_proof env prf in
(*try
if Mc.zChecker sys' prf then Some prf else
raise Certificate.BadCertificate
with Failure s -> (Printf.printf "%s" s ; Some prf)
*) Some prf
-
-
- let cstr_compat_of_poly (p,o) =
- let (v,c) = LinPoly.linpol_of_pol p in
- {coeffs = v ; op = o ; cst = minus_num c }
-
-
- let lia sys =
- LinPoly.MonT.clear ();
- let sys = List.map (develop_constraint z_spec) sys in
- let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in
- let sys = mapi (fun c i -> (c,Hyp i)) sys in
- xlia reduction_equations sys
-
-
- let nlia sys =
- LinPoly.MonT.clear ();
- let sys = List.map (develop_constraint z_spec) sys in
- let sys = mapi (fun c i -> (c,Hyp i)) sys in
-
- let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in
-
- let collect_square =
- List.fold_left (fun acc ((p,_),_) -> Poly.fold
- (fun m _ acc ->
- match Monomial.sqrt m with
- | None -> acc
- | Some s -> MonMap.add s m acc) p acc) MonMap.empty sys in
- let sys = MonMap.fold (fun s m acc ->
- let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in
- let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in
- ((m, Ge), (Square s))::acc) collect_square sys in
-
-(* List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*)
-
- let sys =
- if is_linear then sys
- else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') ->
- ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in
+
- let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in
- assert (check_sys sys) ;
- xlia (if is_linear then reduction_equations else reduction_non_lin_equations) sys
+let cstr_compat_of_poly (p,o) =
+ let (v,c) = LinPoly.linpol_of_pol p in
+ {coeffs = v ; op = o ; cst = minus_num c }
+
+
+let lia (can_enum:bool) (prfdepth:int) sys =
+ LinPoly.MonT.clear ();
+ max_nb_cstr := compute_max_nb_cstr sys prfdepth ;
+ let sys = List.map (develop_constraint z_spec) sys in
+ let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in
+ let sys = mapi (fun c i -> (c,Hyp i)) sys in
+ xlia can_enum reduction_equations sys
+
+
+let nlia enum prfdepth sys =
+ LinPoly.MonT.clear ();
+ max_nb_cstr := compute_max_nb_cstr sys prfdepth;
+ let sys = List.map (develop_constraint z_spec) sys in
+ let sys = mapi (fun c i -> (c,Hyp i)) sys in
+
+ let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in
+
+ let collect_square =
+ List.fold_left (fun acc ((p,_),_) -> Poly.fold
+ (fun m _ acc ->
+ match Monomial.sqrt m with
+ | None -> acc
+ | Some s -> MonMap.add s m acc) p acc) MonMap.empty sys in
+ let sys = MonMap.fold (fun s m acc ->
+ let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in
+ let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in
+ ((m, Ge), (Square s))::acc) collect_square sys in
+
+ (* List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*)
+
+ let sys =
+ if is_linear then sys
+ else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') ->
+ ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in
+
+ let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in
+ assert (check_sys sys) ;
+ xlia enum (if is_linear then reduction_equations else reduction_non_lin_equations) sys
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
index 2812e36ed..470e21c82 100644
--- a/plugins/micromega/coq_micromega.ml
+++ b/plugins/micromega/coq_micromega.ml
@@ -18,6 +18,9 @@
open Pp
open Mutils
+open Proofview
+open Goptions
+open Proofview.Notations
(**
* Debug flag
@@ -37,6 +40,53 @@ let time str f x =
flush stdout);
res
+
+(* Limit the proof search *)
+
+let max_depth = max_int
+
+(* Search limit for provers over Q R *)
+let lra_proof_depth = ref max_depth
+
+
+(* Search limit for provers over Z *)
+let lia_enum = ref true
+let lia_proof_depth = ref max_depth
+
+let get_lia_option () =
+ (!lia_enum,!lia_proof_depth)
+
+let get_lra_option () =
+ !lra_proof_depth
+
+
+
+let _ =
+
+ let int_opt l vref =
+ {
+ optsync = true;
+ optdepr = false;
+ optname = List.fold_right (^) l "";
+ optkey = l ;
+ optread = (fun () -> Some !vref);
+ optwrite = (fun x -> vref := (match x with None -> max_depth | Some v -> v))
+ } in
+
+ let lia_enum_opt =
+ {
+ optsync = true;
+ optdepr = false;
+ optname = "Lia Enum";
+ optkey = ["Lia";"Enum"];
+ optread = (fun () -> !lia_enum);
+ optwrite = (fun x -> lia_enum := x)
+ } in
+ ignore (declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth)) ;
+ ignore (declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth)) ;
+ ignore (declare_bool_option lia_enum_opt)
+
+
(**
* Initialize a tag type to the Tag module declaration (see Mutils).
*)
@@ -359,6 +409,7 @@ struct
let coq_Qmake = lazy (constant "Qmake")
let coq_Rcst = lazy (constant "Rcst")
+
let coq_C0 = lazy (m_constant "C0")
let coq_C1 = lazy (m_constant "C1")
let coq_CQ = lazy (m_constant "CQ")
@@ -1094,10 +1145,6 @@ struct
| N (a) -> Mc.N(f2f a)
| I(a,_,b) -> Mc.I(f2f a,f2f b)
- let is_prop t =
- match t with
- | Names.Anonymous -> true (* Not quite right *)
- | Names.Name x -> false
let mkC f1 f2 = C(f1,f2)
let mkD f1 f2 = D(f1,f2)
@@ -1121,6 +1168,11 @@ struct
(A(at,tg,t), env,Tag.next tg)
with e when Errors.noncritical e -> (X(t),env,tg) in
+ let is_prop term =
+ let ty = Typing.unsafe_type_of (Tacmach.pf_env gl) (Tacmach.project gl) term in
+ let sort = Typing.sort_of (Tacmach.pf_env gl) (ref (Tacmach.project gl)) ty in
+ Term.is_prop_sort sort in
+
let rec xparse_formula env tg term =
match kind_of_term term with
| App(l,rst) ->
@@ -1140,13 +1192,15 @@ struct
let g,env,tg = xparse_formula env tg b in
mkformula_binary mkIff term f g,env,tg
| _ -> parse_atom env tg term)
- | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) ->
+ | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b)->
let f,env,tg = xparse_formula env tg a in
let g,env,tg = xparse_formula env tg b in
mkformula_binary mkI term f g,env,tg
| _ when eq_constr term (Lazy.force coq_True) -> (TT,env,tg)
| _ when eq_constr term (Lazy.force coq_False) -> (FF,env,tg)
- | _ -> X(term),env,tg in
+ | _ when is_prop term -> X(term),env,tg
+ | _ -> raise ParseError
+ in
xparse_formula env tg ((*Reductionops.whd_zeta*) term)
let dump_formula typ dump_atom f =
@@ -1377,50 +1431,57 @@ let rcst_domain_spec = lazy {
dump_proof = dump_psatz coq_Q dump_q
}
+open Proofview.Notations
+
+
(**
* Instanciate the current Coq goal with a Micromega formula, a varmap, and a
* witness.
*)
-
-
-let micromega_order_change spec cert cert_typ env ff : Tacmach.tactic =
+let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) =
let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__z"^(string_of_int i)))) 0 env in
let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in
let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in
let vm = dump_varmap (spec.typ) env in
- (* todo : directly generate the proof term - or generalize befor conversion? *)
- Tacticals.tclTHENSEQ [
- (fun gl ->
- Proofview.V82.of_tactic (Tactics.change_concl
- (set
- [
- ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
- ("__varmap", vm, Term.mkApp
- (Coqlib.gen_constant_in_modules "VarMap"
- [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|spec.typ|]));
- ("__wit", cert, cert_typ)
- ]
- (Tacmach.pf_concl gl))) gl);
- Tactics.generalize env ;
- Tacticals.tclTHENSEQ (List.map (fun id -> Proofview.V82.of_tactic (Tactics.introduction id)) ids) ;
- ]
-
+ (* todo : directly generate the proof term - or generalize before conversion? *)
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let gl = Tacmach.New.of_old (fun x -> x) gl in
+ Tacticals.New.tclTHENLIST
+ [
+ Tactics.change_concl
+ (set
+ [
+ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
+ ("__varmap", vm, Term.mkApp
+ (Coqlib.gen_constant_in_modules "VarMap"
+ [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|spec.typ|]));
+ ("__wit", cert, cert_typ)
+ ]
+ (Tacmach.pf_concl gl))
+ ;
+ Tactics.new_generalize env ;
+ Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)
+ ]
+ end }
(**
* The datastructures that aggregate prover attributes.
*)
-type ('a,'prf) prover = {
+type ('option,'a,'prf) prover = {
name : string ; (* name of the prover *)
- prover : 'a list -> 'prf option ; (* the prover itself *)
+ get_option : unit ->'option ; (* find the options of the prover *)
+ prover : 'option * 'a list -> 'prf option ; (* the prover itself *)
hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *)
compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *)
pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *)
pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*)
}
+
+
(**
* Given a list of provers and a disjunction of atoms, find a proof of any of
* the atoms. Returns an (optional) pair of a proof and a prover
@@ -1430,7 +1491,7 @@ type ('a,'prf) prover = {
let find_witness provers polys1 =
let provers = List.map (fun p ->
(fun l ->
- match p.prover l with
+ match p.prover (p.get_option (),l) with
| None -> None
| Some prf -> Some(prf,p)) , p.name) provers in
try_any provers (List.map fst polys1)
@@ -1485,7 +1546,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) =
let res = try prover.compact prf remap with x when Errors.noncritical x ->
if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ;
(* This should not happen -- this is the recovery plan... *)
- match prover.prover (List.map fst new_cl) with
+ match prover.prover (prover.get_option () ,List.map fst new_cl) with
| None -> failwith "proof compaction error"
| Some p -> p
in
@@ -1646,58 +1707,76 @@ let micromega_gen
(negate:'cst atom -> 'cst mc_cnf)
(normalise:'cst atom -> 'cst mc_cnf)
unsat deduce
- spec prover gl =
- let concl = Tacmach.pf_concl gl in
- let hyps = Tacmach.pf_hyps_types gl in
- try
- let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
- let env = Env.elements env in
- let spec = Lazy.force spec in
-
+ spec prover =
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let gl = Tacmach.New.of_old (fun x -> x) gl in
+ let concl = Tacmach.pf_concl gl in
+ let hyps = Tacmach.pf_hyps_types gl in
+ try
+ let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
+ let env = Env.elements env in
+ let spec = Lazy.force spec in
+
match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl with
- | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl
- | Some (ids,ff',res') ->
- (Tacticals.tclTHENSEQ
- [
- Tactics.generalize (List.map Term.mkVar ids) ;
- micromega_order_change spec res'
- (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff'
- ]) gl
- with
- | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
- | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
- Tacticals.tclFAIL 0 (Pp.str
- (" Skipping what remains of this tactic: the complexity of the goal requires "
- ^ "the use of a specialized external tool called csdp. \n\n"
- ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
- ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl
-
-
-
-let micromega_order_changer cert env ff gl =
- let coeff = Lazy.force coq_Rcst in
- let dump_coeff = dump_Rcst in
- let typ = Lazy.force coq_R in
- let cert_typ = (Term.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in
+ | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness")
+ | Some (ids,ff',res') ->
+ (Tacticals.New.tclTHENLIST
+ [
+ Tactics.new_generalize (List.map Term.mkVar ids) ;
+ micromega_order_change spec res'
+ (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff'
+ ])
+ with
+ | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment")
+ | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout")
+ | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
+ Tacticals.New.tclFAIL 0 (Pp.str
+ (" Skipping what remains of this tactic: the complexity of the goal requires "
+ ^ "the use of a specialized external tool called csdp. \n\n"
+ ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
+ ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp"))
+ end }
+
+let micromega_gen parse_arith
+ (negate:'cst atom -> 'cst mc_cnf)
+ (normalise:'cst atom -> 'cst mc_cnf)
+ unsat deduce
+ spec prover =
+ (micromega_gen parse_arith negate normalise unsat deduce spec prover)
+
+
+let micromega_order_changer cert env ff =
+ let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__z"^(string_of_int i)))) 0 env in
+ let coeff = Lazy.force coq_Rcst in
+ let dump_coeff = dump_Rcst in
+ let typ = Lazy.force coq_R in
+ let cert_typ = (Term.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in
+
let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in
let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in
let vm = dump_varmap (typ) env in
- Proofview.V82.of_tactic (Tactics.change_concl
- (set
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let gl = Tacmach.New.of_old (fun x -> x) gl in
+ Tacticals.New.tclTHENLIST
[
- ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
- ("__varmap", vm, Term.mkApp
- (Coqlib.gen_constant_in_modules "VarMap"
- [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|]));
- ("__wit", cert, cert_typ)
+ (Tactics.change_concl
+ (set
+ [
+ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
+ ("__varmap", vm, Term.mkApp
+ (Coqlib.gen_constant_in_modules "VarMap"
+ [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|]));
+ ("__wit", cert, cert_typ)
+ ]
+ (Tacmach.pf_concl gl)));
+ Tactics.new_generalize env ;
+ Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)
]
- (Tacmach.pf_concl gl)
- ))
- gl
+ end }
-let micromega_genr prover gl =
+let micromega_genr prover =
let parse_arith = parse_rarith in
let negate = Mc.rnegate in
let normalise = Mc.rnormalise in
@@ -1710,39 +1789,41 @@ let micromega_genr prover gl =
proof_typ = Lazy.force coq_QWitness ;
dump_proof = dump_psatz coq_Q dump_q
} in
-
- let concl = Tacmach.pf_concl gl in
- let hyps = Tacmach.pf_hyps_types gl in
- try
- let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
- let env = Env.elements env in
- let spec = Lazy.force spec in
-
- let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in
- let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in
-
- match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl with
- | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let gl = Tacmach.New.of_old (fun x -> x) gl in
+ let concl = Tacmach.pf_concl gl in
+ let hyps = Tacmach.pf_hyps_types gl in
+ try
+ let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
+ let env = Env.elements env in
+ let spec = Lazy.force spec in
+
+ let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in
+ let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in
+
+ match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl with
+ | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness")
| Some (ids,ff',res') ->
let (ff,ids') = formula_hyps_concl
(List.filter (fun (n,_) -> List.mem n ids) hyps) concl in
-
- (Tacticals.tclTHENSEQ
+ (Tacticals.New.tclTHENLIST
[
- Tactics.generalize (List.map Term.mkVar ids) ;
+ Tactics.new_generalize (List.map Term.mkVar ids) ;
micromega_order_changer res' env (abstract_wrt_formula ff' ff)
- ]) gl
+ ])
with
- | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
- | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
- Tacticals.tclFAIL 0 (Pp.str
+ | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "TimeOut")
+ | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment")
+ | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
+ Tacticals.New.tclFAIL 0 (Pp.str
(" Skipping what remains of this tactic: the complexity of the goal requires "
^ "the use of a specialized external tool called csdp. \n\n"
^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
- ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl
-
+ ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp"))
+ end }
+let micromega_genr prover = (micromega_genr prover)
let lift_ratproof prover l =
@@ -1898,38 +1979,61 @@ let compact_pt pt f =
let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l)
-let linear_prover_Z = {
- name = "linear prover" ;
- prover = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ;
- hyps = hyps_of_pt ;
- compact = compact_pt ;
- pp_prf = pp_proof_term;
- pp_f = fun o x -> pp_pol pp_z o (fst x)
-}
+module CacheZ = PHashtable(struct
+ type prover_option = bool * int
+ type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list)
+ let equal = (=)
+ let hash = Hashtbl.hash
+end)
+
+module CacheQ = PHashtable(struct
+ type t = int * ((Mc.q Mc.pol * Mc.op1) list)
+ let equal = (=)
+ let hash = Hashtbl.hash
+end)
+
+let memo_zlinear_prover = CacheZ.memo "lia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s)
+let memo_nlia = CacheZ.memo "nlia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s)
+let memo_nra = CacheQ.memo "nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s)
+
+
+
let linear_prover_Q = {
- name = "linear prover";
- prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ;
- hyps = hyps_of_cone ;
- compact = compact_cone ;
- pp_prf = pp_psatz pp_q ;
- pp_f = fun o x -> pp_pol pp_q o (fst x)
+ name = "linear prover";
+ get_option = get_lra_option ;
+ prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ;
+ hyps = hyps_of_cone ;
+ compact = compact_cone ;
+ pp_prf = pp_psatz pp_q ;
+ pp_f = fun o x -> pp_pol pp_q o (fst x)
}
let linear_prover_R = {
name = "linear prover";
- prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ;
+ get_option = get_lra_option ;
+ prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ;
hyps = hyps_of_cone ;
compact = compact_cone ;
pp_prf = pp_psatz pp_q ;
pp_f = fun o x -> pp_pol pp_q o (fst x)
}
+let nlinear_prover_R = {
+ name = "nra";
+ get_option = get_lra_option;
+ prover = memo_nra ;
+ hyps = hyps_of_cone ;
+ compact = compact_cone ;
+ pp_prf = pp_psatz pp_q ;
+ pp_f = fun o x -> pp_pol pp_q o (fst x)
+}
let non_linear_prover_Q str o = {
name = "real nonlinear prover";
- prover = call_csdpcert_q (str, o);
+ get_option = (fun () -> (str,o));
+ prover = (fun (o,l) -> call_csdpcert_q o l);
hyps = hyps_of_cone;
compact = compact_cone ;
pp_prf = pp_psatz pp_q ;
@@ -1938,7 +2042,8 @@ let non_linear_prover_Q str o = {
let non_linear_prover_R str o = {
name = "real nonlinear prover";
- prover = call_csdpcert_q (str, o);
+ get_option = (fun () -> (str,o));
+ prover = (fun (o,l) -> call_csdpcert_q o l);
hyps = hyps_of_cone;
compact = compact_cone;
pp_prf = pp_psatz pp_q;
@@ -1947,30 +2052,19 @@ let non_linear_prover_R str o = {
let non_linear_prover_Z str o = {
name = "real nonlinear prover";
- prover = lift_ratproof (call_csdpcert_z (str, o));
+ get_option = (fun () -> (str,o));
+ prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l);
hyps = hyps_of_pt;
compact = compact_pt;
pp_prf = pp_proof_term;
pp_f = fun o x -> pp_pol pp_z o (fst x)
}
-module CacheZ = PHashtable(struct
- type t = (Mc.z Mc.pol * Mc.op1) list
- let equal = Pervasives.(=)
- let hash = Hashtbl.hash
-end)
-
-let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.lia)
-let memo_nlia = CacheZ.memo "nlia.cache" (lift_pexpr_prover Certificate.nlia)
-
-(*let memo_zlinear_prover = (lift_pexpr_prover Lia.lia)*)
-(*let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover)*)
-
-
let linear_Z = {
name = "lia";
- prover = memo_zlinear_prover ;
+ get_option = get_lia_option;
+ prover = memo_zlinear_prover ;
hyps = hyps_of_pt;
compact = compact_pt;
pp_prf = pp_proof_term;
@@ -1979,7 +2073,8 @@ let linear_Z = {
let nlinear_Z = {
name = "nlia";
- prover = memo_nlia ;
+ get_option = get_lia_option;
+ prover = memo_nlia ;
hyps = hyps_of_pt;
compact = compact_pt;
pp_prf = pp_proof_term;
@@ -2001,56 +2096,56 @@ let tauto_lia ff =
* solvers
*)
-let psatzl_Z gl =
+let psatzl_Z =
micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
- [ linear_prover_Z ] gl
+ [ linear_Z ]
-let psatzl_Q gl =
+let psatzl_Q =
micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec
- [ linear_prover_Q ] gl
+ [ linear_prover_Q ]
-let psatz_Q i gl =
+let psatz_Q i =
micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec
- [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl
-
-
-let psatzl_R gl =
- micromega_genr [ linear_prover_R ] gl
+ [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ]
+let psatzl_R =
+ micromega_genr [ linear_prover_R ]
-let psatz_R i gl =
- micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] gl
+let psatz_R i =
+ micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ]
-let psatz_Z i gl =
+let psatz_Z i =
micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
- [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl
+ [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ]
-let sos_Z gl =
+let sos_Z =
micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
- [ non_linear_prover_Z "pure_sos" None ] gl
+ [ non_linear_prover_Z "pure_sos" None ]
-let sos_Q gl =
+let sos_Q =
micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec
- [ non_linear_prover_Q "pure_sos" None ] gl
+ [ non_linear_prover_Q "pure_sos" None ]
-let sos_R gl =
- micromega_genr [ non_linear_prover_R "pure_sos" None ] gl
+let sos_R =
+ micromega_genr [ non_linear_prover_R "pure_sos" None ]
-let xlia gl =
+let xlia =
try
micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
- [ linear_Z ] gl
+ [ linear_Z ]
with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise
-let xnlia gl =
+let xnlia =
try
micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
- [ nlinear_Z ] gl
+ [ nlinear_Z ]
with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise
+let nra =
+ micromega_genr [ nlinear_prover_R ]
(* Local Variables: *)
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 1ac44a426..62f0ae503 100644
--- a/plugins/micromega/g_micromega.ml4
+++ b/plugins/micromega/g_micromega.ml4
@@ -26,53 +26,49 @@ let out_arg = function
| ArgArg x -> x
TACTIC EXTEND PsatzZ
-| [ "psatz_Z" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (out_arg i)) ]
-| [ "psatz_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (-1)) ]
+| [ "psatz_Z" int_or_var(i) ] -> [ (Coq_micromega.psatz_Z (out_arg i)) ]
+| [ "psatz_Z" ] -> [ (Coq_micromega.psatz_Z (-1)) ]
END
TACTIC EXTEND Lia
-[ "xlia" ] -> [ Proofview.V82.tactic (Coq_micromega.xlia) ]
+[ "xlia" ] -> [ (Coq_micromega.xlia) ]
END
TACTIC EXTEND Nia
-[ "xnlia" ] -> [ Proofview.V82.tactic (Coq_micromega.xnlia) ]
+[ "xnlia" ] -> [ (Coq_micromega.xnlia) ]
END
-
+TACTIC EXTEND NRA
+[ "xnra" ] -> [ (Coq_micromega.nra)]
+END
TACTIC EXTEND Sos_Z
-| [ "sos_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_Z) ]
+| [ "sos_Z" ] -> [ (Coq_micromega.sos_Z) ]
END
TACTIC EXTEND Sos_Q
-| [ "sos_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_Q) ]
+| [ "sos_Q" ] -> [ (Coq_micromega.sos_Q) ]
END
TACTIC EXTEND Sos_R
-| [ "sos_R" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_R) ]
-END
-
-(*
-TACTIC EXTEND Omicron
-[ "psatzl_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.psatzl_Z) ]
+| [ "sos_R" ] -> [ (Coq_micromega.sos_R) ]
END
-*)
TACTIC EXTEND LRA_Q
-[ "psatzl_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.psatzl_Q) ]
+[ "psatzl_Q" ] -> [ (Coq_micromega.psatzl_Q) ]
END
TACTIC EXTEND LRA_R
-[ "psatzl_R" ] -> [ Proofview.V82.tactic (Coq_micromega.psatzl_R) ]
+[ "psatzl_R" ] -> [ (Coq_micromega.psatzl_R) ]
END
TACTIC EXTEND PsatzR
-| [ "psatz_R" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_R (out_arg i)) ]
-| [ "psatz_R" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_R (-1)) ]
+| [ "psatz_R" int_or_var(i) ] -> [ (Coq_micromega.psatz_R (out_arg i)) ]
+| [ "psatz_R" ] -> [ (Coq_micromega.psatz_R (-1)) ]
END
TACTIC EXTEND PsatzQ
-| [ "psatz_Q" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (out_arg i)) ]
-| [ "psatz_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (-1)) ]
+| [ "psatz_Q" int_or_var(i) ] -> [ (Coq_micromega.psatz_Q (out_arg i)) ]
+| [ "psatz_Q" ] -> [ (Coq_micromega.psatz_Q (-1)) ]
END
diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml
index a36369d22..0261d7349 100644
--- a/plugins/micromega/mfourier.ml
+++ b/plugins/micromega/mfourier.ml
@@ -98,12 +98,12 @@ module PSet = ISet
module System = Hashtbl.Make(Vect)
- type proof =
- | Hyp of int
- | Elim of var * proof * proof
- | And of proof * proof
-
+type proof =
+| Hyp of int
+| Elim of var * proof * proof
+| And of proof * proof
+let max_nb_cstr = ref max_int
type system = {
sys : cstr_info ref System.t ;
@@ -208,8 +208,7 @@ let merge_cstr_info i1 i2 =
*)
let xadd_cstr vect cstr_info sys =
- if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ;
- try
+ try
let info = System.find sys vect in
match merge_cstr_info cstr_info !info with
| None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf)))
@@ -217,6 +216,13 @@ let xadd_cstr vect cstr_info sys =
with
| Not_found -> System.replace sys vect (ref cstr_info)
+exception TimeOut
+
+let xadd_cstr vect cstr_info sys =
+ if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ;
+ if System.length sys < !max_nb_cstr
+ then xadd_cstr vect cstr_info sys
+ else raise TimeOut
type cstr_ext =
| Contradiction (** The constraint is contradictory.
diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml
index a07cbec68..465c7afce 100644
--- a/plugins/micromega/mutils.ml
+++ b/plugins/micromega/mutils.ml
@@ -66,6 +66,15 @@ let all_sym_pairs f l =
| e::l -> xpairs (pair_with acc e l) l in
xpairs [] l
+let all_pairs f l =
+ let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in
+
+ let rec xpairs acc l =
+ match l with
+ | [] -> acc
+ | e::lx -> xpairs (pair_with acc e l) lx in
+ xpairs [] l
+
let rec map3 f l1 l2 l3 =
diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml
index aac9a7d31..976ab949c 100644
--- a/plugins/omega/coq_omega.ml
+++ b/plugins/omega/coq_omega.ml
@@ -27,6 +27,7 @@ open Globnames
open Nametab
open Contradiction
open Misctypes
+open Proofview.Notations
module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
open OmegaSolver
@@ -34,9 +35,9 @@ open OmegaSolver
(* Added by JCF, 09/03/98 *)
let elim_id id =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
simplest_elim (Tacmach.New.pf_global id gl)
- end
+ end }
let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl
let timing timer_name f arg = f arg
@@ -1416,7 +1417,7 @@ let reintroduce id =
open Proofview.Notations
let coq_omega =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
clear_constr_tables ();
let hyps_types = Tacmach.New.pf_hyps_types gl in
let destructure_omega = Tacmach.New.of_old destructure_omega gl in
@@ -1464,12 +1465,12 @@ let coq_omega =
Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path)
with NO_CONTRADICTION -> Tacticals.New.tclZEROMSG (Pp.str"Omega can't solve this system")
end
- end
+ end }
let coq_omega = coq_omega
let nat_inject =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in
let rec explore p t : unit Proofview.tactic =
try match destructurate_term t with
@@ -1603,7 +1604,7 @@ let nat_inject =
in
let hyps_types = Tacmach.New.pf_hyps_types gl in
loop (List.rev hyps_types)
- end
+ end }
let dec_binop = function
| Zne -> coq_dec_Zne
@@ -1673,22 +1674,22 @@ let onClearedName id tac =
(* so renaming may be necessary *)
Tacticals.New.tclTHEN
(Proofview.V82.tactic (tclTRY (clear [id])))
- (Proofview.Goal.nf_enter begin fun gl ->
+ (Proofview.Goal.nf_enter { enter = begin fun gl ->
let id = Tacmach.New.of_old (fresh_id [] id) gl in
Tacticals.New.tclTHEN (introduction id) (tac id)
- end)
+ end })
let onClearedName2 id tac =
Tacticals.New.tclTHEN
(Proofview.V82.tactic (tclTRY (clear [id])))
- (Proofview.Goal.nf_enter begin fun gl ->
+ (Proofview.Goal.nf_enter { enter = begin fun gl ->
let id1 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_left")) gl in
let id2 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_right")) gl in
Tacticals.New.tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ]
- end)
+ end })
let destructure_hyps =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let type_of = Tacmach.New.pf_unsafe_type_of gl in
let decidability = Tacmach.New.of_old decidability gl in
let pf_nf = Tacmach.New.of_old pf_nf gl in
@@ -1828,10 +1829,10 @@ let destructure_hyps =
in
let hyps = Proofview.Goal.hyps gl in
loop hyps
- end
+ end }
let destructure_goal =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let decidability = Tacmach.New.of_old decidability gl in
let rec loop t =
@@ -1855,7 +1856,7 @@ let destructure_goal =
Tacticals.New.tclTHEN goal_tac destructure_hyps
in
(loop concl)
- end
+ end }
let destructure_goal = destructure_goal
diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml
index 2a2ef30fb..04936cd83 100644
--- a/plugins/quote/quote.ml
+++ b/plugins/quote/quote.ml
@@ -109,6 +109,7 @@ open Pattern
open Patternops
open Constr_matching
open Tacmach
+open Proofview.Notations
(*i*)
(*s First, we need to access some Coq constants
@@ -227,7 +228,7 @@ let compute_ivs f cs gl =
let (args3, body3) = decompose_lam body2 in
let nargs3 = List.length args3 in
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let is_conv = Reductionops.is_conv env sigma in
begin match decomp_term body3 with
| Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *)
@@ -446,7 +447,7 @@ let quote_terms ivs lc =
yet. *)
let quote f lid =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let f = Tacmach.New.pf_global f gl in
let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in
let ivs = compute_ivs f cl gl in
@@ -459,10 +460,10 @@ let quote f lid =
match ivs.variable_lhs with
| None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast
| Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast
- end
+ end }
let gen_quote cont c f lid =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let f = Tacmach.New.pf_global f gl in
let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in
let ivs = compute_ivs f cl gl in
@@ -474,7 +475,7 @@ let gen_quote cont c f lid =
match ivs.variable_lhs with
| None -> cont (mkApp (f, [| p |]))
| Some _ -> cont (mkApp (f, [| vm; p |]))
- end
+ end }
(*i
diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4
new file mode 100644
index 000000000..856ec0db5
--- /dev/null
+++ b/plugins/setoid_ring/g_newring.ml4
@@ -0,0 +1,90 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Pp
+open Util
+open Libnames
+open Printer
+open Newring_ast
+open Newring
+
+DECLARE PLUGIN "newring_plugin"
+
+TACTIC EXTEND protect_fv
+ [ "protect_fv" string(map) "in" ident(id) ] ->
+ [ Proofview.V82.tactic (protect_tac_in map id) ]
+| [ "protect_fv" string(map) ] ->
+ [ Proofview.V82.tactic (protect_tac map) ]
+END
+
+TACTIC EXTEND closed_term
+ [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
+ [ Proofview.V82.tactic (closed_term t l) ]
+END
+
+VERNAC ARGUMENT EXTEND ring_mod
+ | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ]
+ | [ "abstract" ] -> [ Ring_kind Abstract ]
+ | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ]
+ | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
+ | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
+ | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
+ | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
+ | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
+ | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
+ | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
+ [ Pow_spec (Closed l, pow_spec) ]
+ | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
+ [ Pow_spec (CstTac cst_tac, pow_spec) ]
+ | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
+END
+
+VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF
+ | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
+ [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in
+ add_theory id (ic t) set k cst (pre,post) power sign div]
+ | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [
+ msg_notice (strbrk "The following ring structures have been declared:");
+ Spmap.iter (fun fn fi ->
+ msg_notice (hov 2
+ (Ppconstr.pr_id (Libnames.basename fn)++spc()++
+ str"with carrier "++ pr_constr fi.ring_carrier++spc()++
+ str"and equivalence relation "++ pr_constr fi.ring_req))
+ ) !from_name ]
+END
+
+TACTIC EXTEND ring_lookup
+| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
+ [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t]
+END
+
+VERNAC ARGUMENT EXTEND field_mod
+ | [ ring_mod(m) ] -> [ Ring_mod m ]
+ | [ "completeness" constr(inj) ] -> [ Inject inj ]
+END
+
+VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF
+| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] ->
+ [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in
+ add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div]
+| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [
+ msg_notice (strbrk "The following field structures have been declared:");
+ Spmap.iter (fun fn fi ->
+ msg_notice (hov 2
+ (Ppconstr.pr_id (Libnames.basename fn)++spc()++
+ str"with carrier "++ pr_constr fi.field_carrier++spc()++
+ str"and equivalence relation "++ pr_constr fi.field_req))
+ ) !field_from_name ]
+END
+
+TACTIC EXTEND field_lookup
+| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] ->
+ [ let (t,l) = List.sep_last lt in field_lookup f lH l t ]
+END
diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml
index c7185ff25..142257bc8 100644
--- a/plugins/setoid_ring/newring.ml4
+++ b/plugins/setoid_ring/newring.ml
@@ -30,8 +30,8 @@ open Declare
open Decl_kinds
open Entries
open Misctypes
-
-DECLARE PLUGIN "newring_plugin"
+open Newring_ast
+open Proofview.Notations
(****************************************************************************)
(* controlled reduction *)
@@ -105,13 +105,6 @@ let protect_tac_in map id =
Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp));;
-TACTIC EXTEND protect_fv
- [ "protect_fv" string(map) "in" ident(id) ] ->
- [ Proofview.V82.tactic (protect_tac_in map id) ]
-| [ "protect_fv" string(map) ] ->
- [ Proofview.V82.tactic (protect_tac map) ]
-END;;
-
(****************************************************************************)
let closed_term t l =
@@ -120,12 +113,6 @@ let closed_term t l =
if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt())
;;
-TACTIC EXTEND closed_term
- [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
- [ Proofview.V82.tactic (closed_term t l) ]
-END
-;;
-
(* TACTIC EXTEND echo
| [ "echo" constr(t) ] ->
[ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ]
@@ -143,6 +130,10 @@ let closed_term_ast l =
mltac_plugin = "newring_plugin";
mltac_tactic = "closed_term";
} in
+ let tacname = {
+ mltac_name = tacname;
+ mltac_index = 0;
+ } in
let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in
TacFun([Some(Id.of_string"t")],
TacML(Loc.ghost,tacname,
@@ -355,20 +346,6 @@ let _ = add_map "ring"
(****************************************************************************)
(* Ring database *)
-type ring_info =
- { ring_carrier : types;
- ring_req : constr;
- ring_setoid : constr;
- ring_ext : constr;
- ring_morph : constr;
- ring_th : constr;
- ring_cst_tac : glob_tactic_expr;
- ring_pow_tac : glob_tactic_expr;
- ring_lemma1 : constr;
- ring_lemma2 : constr;
- ring_pre_tac : glob_tactic_expr;
- ring_post_tac : glob_tactic_expr }
-
module Cmap = Map.Make(Constr)
let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table"
@@ -600,13 +577,6 @@ let dest_morph env sigma m_spec =
(c,czero,cone,cadd,cmul,None,None,ceqb,phi)
| _ -> error "bad morphism structure"
-
-type 'constr coeff_spec =
- Computational of 'constr (* equality test *)
- | Abstract (* coeffs = Z *)
- | Morphism of 'constr (* general morphism *)
-
-
let reflect_coeff rkind =
(* We build an ill-typed terms on purpose... *)
match rkind with
@@ -614,10 +584,6 @@ let reflect_coeff rkind =
| Computational c -> lapp coq_comp [|c|]
| Morphism m -> lapp coq_morph [|m|]
-type cst_tac_spec =
- CstTac of raw_tactic_expr
- | Closed of reference list
-
let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
match cst_tac with
Some (CstTac t) -> Tacintern.glob_tactic t
@@ -721,41 +687,12 @@ let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div =
ring_post_tac = posttac }) in
()
-type 'constr ring_mod =
- Ring_kind of 'constr coeff_spec
- | Const_tac of cst_tac_spec
- | Pre_tac of raw_tactic_expr
- | Post_tac of raw_tactic_expr
- | Setoid of Constrexpr.constr_expr * Constrexpr.constr_expr
- | Pow_spec of cst_tac_spec * Constrexpr.constr_expr
- (* Syntaxification tactic , correctness lemma *)
- | Sign_spec of Constrexpr.constr_expr
- | Div_spec of Constrexpr.constr_expr
-
-
let ic_coeff_spec = function
| Computational t -> Computational (ic_unsafe t)
| Morphism t -> Morphism (ic_unsafe t)
| Abstract -> Abstract
-VERNAC ARGUMENT EXTEND ring_mod
- | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ]
- | [ "abstract" ] -> [ Ring_kind Abstract ]
- | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ]
- | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
- | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
- | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
- | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
- | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
- | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
- | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
- [ Pow_spec (Closed l, pow_spec) ]
- | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
- [ Pow_spec (CstTac cst_tac, pow_spec) ]
- | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
-END
-
let set_once s r v =
if Option.is_empty !r then r := Some v else error (s^" cannot be set twice")
@@ -780,20 +717,6 @@ let process_ring_mods l =
let k = match !kind with Some k -> k | None -> Abstract in
(k, !set, !cst_tac, !pre, !post, !power, !sign, !div)
-VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF
- | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
- [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in
- add_theory id (ic t) set k cst (pre,post) power sign div]
- | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [
- msg_notice (strbrk "The following ring structures have been declared:");
- Spmap.iter (fun fn fi ->
- msg_notice (hov 2
- (Ppconstr.pr_id (Libnames.basename fn)++spc()++
- str"with carrier "++ pr_constr fi.ring_carrier++spc()++
- str"and equivalence relation "++ pr_constr fi.ring_req))
- ) !from_name ]
-END
-
(*****************************************************************************)
(* The tactics consist then only in a lookup in the ring database and
call the appropriate ltac. *)
@@ -825,8 +748,8 @@ let ltac_ring_structure e =
lemma1;lemma2;pretac;posttac]
let ring_lookup (f:glob_tactic_expr) lH rl t =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
try (* find_ring_strucure can raise an exception *)
let evdref = ref sigma in
@@ -837,14 +760,7 @@ let ring_lookup (f:glob_tactic_expr) lH rl t =
let ring = ltac_ring_structure e in
Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl]))
with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
- end
-
-TACTIC EXTEND ring_lookup
-| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
- [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t]
-END
-
-
+ end }
(***********************************************************************)
@@ -919,19 +835,6 @@ let dest_field env evd th_spec =
(Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
| _ -> error "bad field structure"
-type field_info =
- { field_carrier : types;
- field_req : constr;
- field_cst_tac : glob_tactic_expr;
- field_pow_tac : glob_tactic_expr;
- field_ok : constr;
- field_simpl_eq_ok : constr;
- field_simpl_ok : constr;
- field_simpl_eq_in_ok : constr;
- field_cond : constr;
- field_pre_tac : glob_tactic_expr;
- field_post_tac : glob_tactic_expr }
-
let field_from_carrier = Summary.ref Cmap.empty ~name:"field-tac-carrier-table"
let field_from_name = Summary.ref Spmap.empty ~name:"field-tac-name-table"
@@ -1078,15 +981,6 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power
field_pre_tac = pretac;
field_post_tac = posttac }) in ()
-type 'constr field_mod =
- Ring_mod of 'constr ring_mod
- | Inject of Constrexpr.constr_expr
-
-VERNAC ARGUMENT EXTEND field_mod
- | [ ring_mod(m) ] -> [ Ring_mod m ]
- | [ "completeness" constr(inj) ] -> [ Inject inj ]
-END
-
let process_field_mods l =
let kind = ref None in
let set = ref None in
@@ -1111,21 +1005,6 @@ let process_field_mods l =
let k = match !kind with Some k -> k | None -> Abstract in
(k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div)
-VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF
-| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] ->
- [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in
- add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div]
-| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [
- msg_notice (strbrk "The following field structures have been declared:");
- Spmap.iter (fun fn fi ->
- msg_notice (hov 2
- (Ppconstr.pr_id (Libnames.basename fn)++spc()++
- str"with carrier "++ pr_constr fi.field_carrier++spc()++
- str"and equivalence relation "++ pr_constr fi.field_req))
- ) !field_from_name ]
-END
-
-
let ltac_field_structure e =
let req = carg e.field_req in
let cst_tac = Tacexp e.field_cst_tac in
@@ -1141,8 +1020,8 @@ let ltac_field_structure e =
field_simpl_eq_in_ok;cond_ok;pretac;posttac]
let field_lookup (f:glob_tactic_expr) lH rl t =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
try
let evdref = ref sigma in
@@ -1153,10 +1032,4 @@ let field_lookup (f:glob_tactic_expr) lH rl t =
let field = ltac_field_structure e in
Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl]))
with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
- end
-
-
-TACTIC EXTEND field_lookup
-| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] ->
- [ let (t,l) = List.sep_last lt in field_lookup f lH l t ]
-END
+ end }
diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli
new file mode 100644
index 000000000..4bd3383d6
--- /dev/null
+++ b/plugins/setoid_ring/newring.mli
@@ -0,0 +1,78 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Names
+open Constr
+open Libnames
+open Globnames
+open Constrexpr
+open Tacexpr
+open Proof_type
+open Newring_ast
+
+val protect_tac_in : string -> Id.t -> tactic
+
+val protect_tac : string -> tactic
+
+val closed_term : constr -> global_reference list -> tactic
+
+val process_ring_mods :
+ constr_expr ring_mod list ->
+ constr coeff_spec * (constr * constr) option *
+ cst_tac_spec option * raw_tactic_expr option *
+ raw_tactic_expr option *
+ (cst_tac_spec * constr_expr) option *
+ constr_expr option * constr_expr option
+
+val add_theory :
+ Id.t ->
+ Evd.evar_map * constr ->
+ (constr * constr) option ->
+ constr coeff_spec ->
+ cst_tac_spec option ->
+ raw_tactic_expr option * raw_tactic_expr option ->
+ (cst_tac_spec * constr_expr) option ->
+ constr_expr option ->
+ constr_expr option -> unit
+
+val ic : constr_expr -> Evd.evar_map * constr
+
+val from_name : ring_info Spmap.t ref
+
+val ring_lookup :
+ glob_tactic_expr ->
+ constr list ->
+ constr list -> constr -> unit Proofview.tactic
+
+val process_field_mods :
+ constr_expr field_mod list ->
+ constr coeff_spec *
+ (constr * constr) option * constr option *
+ cst_tac_spec option * raw_tactic_expr option *
+ raw_tactic_expr option *
+ (cst_tac_spec * constr_expr) option *
+ constr_expr option * constr_expr option
+
+val add_field_theory :
+ Id.t ->
+ Evd.evar_map * constr ->
+ (constr * constr) option ->
+ constr coeff_spec ->
+ cst_tac_spec option ->
+ constr option ->
+ raw_tactic_expr option * raw_tactic_expr option ->
+ (cst_tac_spec * constr_expr) option ->
+ constr_expr option ->
+ constr_expr option -> unit
+
+val field_from_name : field_info Spmap.t ref
+
+val field_lookup :
+ glob_tactic_expr ->
+ constr list ->
+ constr list -> constr -> unit Proofview.tactic
diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/setoid_ring/newring_ast.mli
new file mode 100644
index 000000000..c26fcc8d1
--- /dev/null
+++ b/plugins/setoid_ring/newring_ast.mli
@@ -0,0 +1,63 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Constr
+open Libnames
+open Constrexpr
+open Tacexpr
+
+type 'constr coeff_spec =
+ Computational of 'constr (* equality test *)
+ | Abstract (* coeffs = Z *)
+ | Morphism of 'constr (* general morphism *)
+
+type cst_tac_spec =
+ CstTac of raw_tactic_expr
+ | Closed of reference list
+
+type 'constr ring_mod =
+ Ring_kind of 'constr coeff_spec
+ | Const_tac of cst_tac_spec
+ | Pre_tac of raw_tactic_expr
+ | Post_tac of raw_tactic_expr
+ | Setoid of constr_expr * constr_expr
+ | Pow_spec of cst_tac_spec * constr_expr
+ (* Syntaxification tactic , correctness lemma *)
+ | Sign_spec of constr_expr
+ | Div_spec of constr_expr
+
+type 'constr field_mod =
+ Ring_mod of 'constr ring_mod
+ | Inject of constr_expr
+
+type ring_info =
+ { ring_carrier : types;
+ ring_req : constr;
+ ring_setoid : constr;
+ ring_ext : constr;
+ ring_morph : constr;
+ ring_th : constr;
+ ring_cst_tac : glob_tactic_expr;
+ ring_pow_tac : glob_tactic_expr;
+ ring_lemma1 : constr;
+ ring_lemma2 : constr;
+ ring_pre_tac : glob_tactic_expr;
+ ring_post_tac : glob_tactic_expr }
+
+type field_info =
+ { field_carrier : types;
+ field_req : constr;
+ field_cst_tac : glob_tactic_expr;
+ field_pow_tac : glob_tactic_expr;
+ field_ok : constr;
+ field_simpl_eq_ok : constr;
+ field_simpl_ok : constr;
+ field_simpl_eq_in_ok : constr;
+ field_cond : constr;
+ field_pre_tac : glob_tactic_expr;
+ field_post_tac : glob_tactic_expr }
diff --git a/plugins/setoid_ring/newring_plugin.mllib b/plugins/setoid_ring/newring_plugin.mllib
index a98392f1e..7d6c49588 100644
--- a/plugins/setoid_ring/newring_plugin.mllib
+++ b/plugins/setoid_ring/newring_plugin.mllib
@@ -1,2 +1,3 @@
Newring
Newring_plugin_mod
+G_newring
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index bb07bf056..60d92f4be 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -22,6 +22,7 @@ open Evarsolve
open Globnames
open Evd
open Pretype_errors
+open Sigma.Notations
type unify_fun = transparent_state ->
env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result
@@ -830,7 +831,9 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
(i,t2::ks, m-1, test)
else
let dloc = (Loc.ghost,Evar_kinds.InternalHole) in
- let (i',ev) = new_evar env i ~src:dloc (substl ks b) in
+ let i = Sigma.Unsafe.of_evar_map i in
+ let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in
+ let i' = Sigma.to_evar_map i' in
(i', ev :: ks, m - 1,test))
(evd,[],List.length bs,fun i -> Success i) bs
in
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index d3d6901b6..bc9f08331 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -239,17 +239,6 @@ let make_pure_subst evi args =
| _ -> anomaly (Pp.str "Instance does not match its signature"))
(evar_filtered_context evi) (Array.rev_to_list args,[]))
-(**********************)
-(* Creating new evars *)
-(**********************)
-
-let evar_counter_summary_name = "evar counter"
-
-(* Generator of existential names *)
-let new_untyped_evar =
- let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in
- fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr
-
(*------------------------------------*
* functional operations on evar sets *
*------------------------------------*)
@@ -354,17 +343,15 @@ let push_rel_context_to_named_context env typ =
let default_source = (Loc.ghost,Evar_kinds.InternalHole)
let restrict_evar evd evk filter candidates =
- let evk' = new_untyped_evar () in
- let evd = Evd.restrict evk evk' filter ?candidates evd in
+ let evd, evk' = Evd.restrict evk filter ?candidates evd in
Evd.declare_future_goal evk' evd, evk'
let new_pure_evar_full evd evi =
- let evk = new_untyped_evar () in
- let evd = Evd.add evd evk evi in
+ let (evd, evk) = Evd.new_evar evd evi in
let evd = Evd.declare_future_goal evk evd in
(evd, evk)
-let new_pure_evar sign evd ?(src=default_source) ?filter ?candidates ?store ?naming ?(principal=false) typ =
+let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ =
let default_naming =
if principal then
(* waiting for a more principled approach
@@ -374,8 +361,16 @@ let new_pure_evar sign evd ?(src=default_source) ?filter ?candidates ?store ?nam
Misctypes.IntroAnonymous
in
let naming = Option.default default_naming naming in
- let newevk = new_untyped_evar() in
- let evd = evar_declare sign newevk typ ~src ?filter ?candidates ?store ~naming evd in
+ let evi = {
+ evar_hyps = sign;
+ evar_concl = typ;
+ evar_body = Evar_empty;
+ evar_filter = filter;
+ evar_source = src;
+ evar_candidates = candidates;
+ evar_extra = store; }
+ in
+ let (evd, newevk) = Evd.new_evar evd ~naming evi in
let evd =
if principal then Evd.declare_principal_goal newevk evd
else Evd.declare_future_goal newevk evd
@@ -390,7 +385,7 @@ let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?prin
(* [new_evar] declares a new existential in an env env with type typ *)
(* Converting the env into the sign of the evar to define *)
-let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
+let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in
let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in
let instance =
@@ -399,9 +394,14 @@ let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
| Some filter -> Filter.filter_list filter instance in
new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance
+let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
+ let evd = Sigma.to_evar_map evd in
+ let (sigma, c) = new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ in
+ Sigma.Unsafe.of_pair (c, sigma)
+
let new_type_evar env evd ?src ?filter ?naming ?principal rigid =
let evd', s = new_sort_variable rigid evd in
- let evd', e = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in
+ let evd', e = new_evar_unsafe env evd' ?src ?filter ?naming ?principal (mkSort s) in
evd', (e, s)
let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid =
@@ -419,7 +419,7 @@ let e_new_Type ?(rigid=Evd.univ_flexible) env evdref =
(* The same using side-effect *)
let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty =
- let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in
+ let (evd',ev) = new_evar_unsafe env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in
evdref := evd';
ev
@@ -722,7 +722,7 @@ let define_pure_evar_as_product evd evk =
let filter = Filter.extend 1 (evar_filter evi) in
if is_prop_sort s then
(* Impredicative product, conclusion must fall in [Prop]. *)
- new_evar newenv evd1 concl ~src ~filter
+ new_evar_unsafe newenv evd1 concl ~src ~filter
else
let evd3, (rng, srng) =
new_type_evar newenv evd1 univ_flexible_alg ~src ~filter in
@@ -768,7 +768,7 @@ let define_pure_evar_as_lambda env evd evk =
let newenv = push_named (id, None, dom) evenv in
let filter = Filter.extend 1 (evar_filter evi) in
let src = evar_source evk evd1 in
- let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
+ let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
let lam = mkLambda (Name id, dom, subst_var id body) in
Evd.define evk lam evd2, lam
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index f1d94b0a4..96648bb11 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -22,10 +22,10 @@ val mk_new_meta : unit -> constr
(** {6 Creating a fresh evar given their type and context} *)
val new_evar :
- env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+ env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
?candidates:constr list -> ?store:Store.t ->
?naming:Misctypes.intro_pattern_naming_expr ->
- ?principal:bool -> types -> evar_map * constr
+ ?principal:bool -> types -> (constr, 'r) Sigma.sigma
val new_pure_evar :
named_context_val -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
@@ -252,4 +252,3 @@ val subterm_source : existential_key -> Evar_kinds.t Loc.located ->
Evar_kinds.t Loc.located
val meta_counter_summary_name : string
-val evar_counter_summary_name : string
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index d484df69c..c2cf1f83d 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -134,7 +134,7 @@ let interp_universe_level_name evd (loc,s) =
let level = Univ.Level.make dp num in
let evd =
try Evd.add_global_univ evd level
- with Univ.AlreadyDeclared -> evd
+ with UGraph.AlreadyDeclared -> evd
in evd, level
else
try
diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
index a644e3d10..b59589bda 100644
--- a/pretyping/pretyping.mllib
+++ b/pretyping/pretyping.mllib
@@ -1,7 +1,4 @@
Locusops
-Termops
-Namegen
-Evd
Reductionops
Inductiveops
Vnorm
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 24e06007e..269c723e3 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -27,6 +27,7 @@ open Recordops
open Locus
open Locusops
open Find_subterm
+open Sigma.Notations
let keyed_unification = ref (false)
let _ = Goptions.declare_bool_option {
@@ -105,7 +106,9 @@ let set_occurrences_of_last_arg args =
Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args)
let abstract_list_all_with_dependencies env evd typ c l =
- let evd,ev = new_evar env evd typ in
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (ev, evd, _) = new_evar env evd typ in
+ let evd = Sigma.to_evar_map evd in
let evd,ev' = evar_absorb_arguments env evd (destEvar ev) l in
let n = List.length l in
let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in
@@ -554,6 +557,19 @@ let isAllowedEvar flags c = match kind_of_term c with
| Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars)
| _ -> false
+
+let subst_defined_metas_evars (bl,el) c =
+ let rec substrec c = match kind_of_term c with
+ | Meta i ->
+ let select (j,_,_) = Int.equal i j in
+ substrec (pi2 (List.find select bl))
+ | Evar (evk,args) ->
+ let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in
+ (try substrec (pi3 (List.find select el))
+ with Not_found -> map_constr substrec c)
+ | _ -> map_constr substrec c
+ in try Some (substrec c) with Not_found -> None
+
let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN =
match subst_defined_metas_evars (metasubst,[]) tyM with
| None -> sigma
@@ -1142,20 +1158,20 @@ let merge_instances env sigma flags st1 st2 c1 c2 =
* close it off. But this might not always work,
* since other metavars might also need to be resolved. *)
-let applyHead env evd n c =
- let rec apprec n c cty evd =
+let applyHead env (type r) (evd : r Sigma.t) n c =
+ let rec apprec : type s. _ -> _ -> _ -> (r, s) Sigma.le -> s Sigma.t -> (constr, r) Sigma.sigma =
+ fun n c cty p evd ->
if Int.equal n 0 then
- (evd, c)
+ Sigma (c, evd, p)
else
- match kind_of_term (whd_betadeltaiota env evd cty) with
+ match kind_of_term (whd_betadeltaiota env (Sigma.to_evar_map evd) cty) with
| Prod (_,c1,c2) ->
- let (evd',evar) =
- Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
- apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
+ let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
+ apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd'
| _ -> error "Apply_Head_Then"
in
- apprec n c (Typing.unsafe_type_of env evd c) evd
-
+ apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd
+
let is_mimick_head ts f =
match kind_of_term f with
| Const (c,u) -> not (Closure.is_transparent_constant ts c)
@@ -1315,7 +1331,9 @@ let w_merge env with_types flags (evd,metas,evars) =
and mimick_undefined_evar evd flags hdc nargs sp =
let ev = Evd.find_undefined evd sp in
let sp_env = Global.env_of_context ev.evar_hyps in
- let (evd', c) = applyHead sp_env evd nargs hdc in
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (c, evd', _) = applyHead sp_env evd nargs hdc in
+ let evd' = Sigma.to_evar_map evd' in
let (evd'',mc,ec) =
unify_0 sp_env evd' CUMUL flags
(get_type_of sp_env evd' c) ev.evar_concl in
@@ -1424,9 +1442,10 @@ let indirect_dependency d decls =
pi1 (List.hd (List.filter (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls))
let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) =
+ let current_sigma = Sigma.to_evar_map current_sigma in
let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in
let sigma, subst = nf_univ_variables sigma in
- sigma, subst_univs_constr subst (nf_evar sigma c)
+ Sigma.Unsafe.of_pair (subst_univs_constr subst (nf_evar sigma c), sigma)
let default_matching_core_flags sigma =
let ts = Names.full_transparent_state in {
@@ -1577,7 +1596,11 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
in
let lastlhyp =
if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in
- (id,sign,depdecls,lastlhyp,ccl,out test)
+ let res = match out test with
+ | None -> None
+ | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma))
+ in
+ (id,sign,depdecls,lastlhyp,ccl,res)
with
SubtermUnificationError e ->
raise (PretypeError (env,sigma,CannotUnifyOccurrences e))
@@ -1599,12 +1622,13 @@ type abstraction_request =
| AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Name.t * pending_constr * clause * bool
| AbstractExact of Name.t * constr * types option * clause * bool
-type abstraction_result =
+type 'r abstraction_result =
Names.Id.t * named_context_val *
Context.named_declaration list * Names.Id.t option *
- types * (Evd.evar_map * constr) option
+ types * (constr, 'r) Sigma.sigma option
let make_abstraction env evd ccl abs =
+ let evd = Sigma.to_evar_map evd in
match abs with
| AbstractPattern (from_prefix,check,name,c,occs,check_occs) ->
make_abstraction_core name
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index 119b1a759..51a51f375 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -73,15 +73,15 @@ type abstraction_request =
| AbstractExact of Names.Name.t * constr * types option * Locus.clause * bool
val finish_evar_resolution : ?flags:Pretyping.inference_flags ->
- env -> Evd.evar_map -> pending_constr -> Evd.evar_map * constr
+ env -> 'r Sigma.t -> pending_constr -> (constr, 'r) Sigma.sigma
-type abstraction_result =
+type 'r abstraction_result =
Names.Id.t * named_context_val *
Context.named_declaration list * Names.Id.t option *
- types * (Evd.evar_map * constr) option
+ types * (constr, 'r) Sigma.sigma option
-val make_abstraction : env -> Evd.evar_map -> constr ->
- abstraction_request -> abstraction_result
+val make_abstraction : env -> 'r Sigma.t -> constr ->
+ abstraction_request -> 'r abstraction_result
val pose_all_metas_as_evars : env -> evar_map -> constr -> evar_map * constr
diff --git a/printing/pptactic.ml b/printing/pptactic.ml
index a669aef9a..72d2eedcc 100644
--- a/printing/pptactic.ml
+++ b/printing/pptactic.ml
@@ -34,13 +34,14 @@ type pp_tactic = {
}
(* ML Extensions *)
-let prtac_tab = Hashtbl.create 17
+let prtac_tab : (ml_tactic_name, pp_tactic array) Hashtbl.t =
+ Hashtbl.create 17
(* Tactic notations *)
let prnotation_tab = Summary.ref ~name:"pptactic-notation" KNmap.empty
let declare_ml_tactic_pprule key pt =
- Hashtbl.add prtac_tab (key, pt.pptac_args) pt.pptac_prods
+ Hashtbl.add prtac_tab key pt
let declare_notation_tactic_pprule kn pt =
prnotation_tab := KNmap.add kn pt !prnotation_tab
@@ -414,14 +415,18 @@ module Make
in
pr_sequence (fun x -> x) l
- let pr_extend_gen pr_gen lev s l =
+ let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l =
try
- let tags = List.map genarg_tag l in
- let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in
+ let pp_rules = Hashtbl.find prtac_tab s in
+ let pp = pp_rules.(i) in
+ let (lev', pl) = pp.pptac_prods in
let p = pr_tacarg_using_rule pr_gen (pl,l) in
if lev' > lev then surround p else p
with Not_found ->
- let name = str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic in
+ let name =
+ str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++
+ str "@" ++ int i
+ in
let args = match l with
| [] -> mt ()
| _ -> spc() ++ pr_sequence pr_gen l
@@ -756,7 +761,7 @@ module Make
pr_reference : 'ref -> std_ppcmds;
pr_name : 'nam -> std_ppcmds;
pr_generic : 'lev generic_argument -> std_ppcmds;
- pr_extend : int -> ml_tactic_name -> 'lev generic_argument list -> std_ppcmds;
+ pr_extend : int -> ml_tactic_entry -> 'lev generic_argument list -> std_ppcmds;
pr_alias : int -> KerName.t -> 'lev generic_argument list -> std_ppcmds;
}
@@ -1375,9 +1380,9 @@ module Make
pr_uconstr = pr_closed_glob_env env Evd.empty;
pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env);
pr_lconstr = pr_lconstr_env env Evd.empty;
- pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env);
- pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env);
- pr_constant = pr_and_short_name (pr_evaluable_reference_env env);
+ pr_pattern = pr_constr_pattern_env env Evd.empty;
+ pr_lpattern = pr_lconstr_pattern_env env Evd.empty;
+ pr_constant = pr_evaluable_reference_env env;
pr_reference = pr_located pr_ltac_constant;
pr_name = pr_id;
pr_generic = Genprint.generic_top_print;
@@ -1432,6 +1437,9 @@ end)
(** Registering *)
+let run_delayed c =
+ Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma }
+
let () =
let pr_bool b = if b then str "true" else str "false" in
let pr_unit _ = str "()" in
@@ -1442,7 +1450,7 @@ let () =
Constrarg.wit_intro_pattern
(Miscprint.pr_intro_pattern pr_constr_expr)
(Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c))
- (Miscprint.pr_intro_pattern (fun c -> pr_constr (snd (c (Global.env()) Evd.empty))));
+ (Miscprint.pr_intro_pattern (fun c -> pr_constr (fst (run_delayed c))));
Genprint.register_print0
Constrarg.wit_clause_dft_concl
(pr_clauses (Some true) pr_lident)
diff --git a/printing/pptactic.mli b/printing/pptactic.mli
index fa91aefcf..30b9483db 100644
--- a/printing/pptactic.mli
+++ b/printing/pptactic.mli
@@ -48,7 +48,7 @@ type pp_tactic = {
pptac_prods : int * grammar_terminals;
}
-val declare_ml_tactic_pprule : ml_tactic_name -> pp_tactic -> unit
+val declare_ml_tactic_pprule : ml_tactic_name -> pp_tactic array -> unit
val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit
(** The default pretty-printers produce {!Pp.std_ppcmds} that are
diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli
index 166a6675c..1631bda37 100644
--- a/printing/pptacticsig.mli
+++ b/printing/pptacticsig.mli
@@ -59,19 +59,19 @@ module type Pp = sig
(constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) ->
(tolerability -> raw_tactic_expr -> std_ppcmds) ->
(constr_expr -> std_ppcmds) -> int ->
- ml_tactic_name -> raw_generic_argument list -> std_ppcmds
+ ml_tactic_entry -> raw_generic_argument list -> std_ppcmds
val pr_glob_extend:
(glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) ->
(tolerability -> glob_tactic_expr -> std_ppcmds) ->
(glob_constr_pattern_and_expr -> std_ppcmds) -> int ->
- ml_tactic_name -> glob_generic_argument list -> std_ppcmds
+ ml_tactic_entry -> glob_generic_argument list -> std_ppcmds
val pr_extend :
(Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) ->
(tolerability -> glob_tactic_expr -> std_ppcmds) ->
(constr_pattern -> std_ppcmds) -> int ->
- ml_tactic_name -> typed_generic_argument list -> std_ppcmds
+ ml_tactic_entry -> typed_generic_argument list -> std_ppcmds
val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds
diff --git a/proofs/clenv.ml b/proofs/clenv.ml
index a2cccc0e0..ae790d9b8 100644
--- a/proofs/clenv.ml
+++ b/proofs/clenv.ml
@@ -24,6 +24,7 @@ open Pretype_errors
open Evarutil
open Unification
open Misctypes
+open Sigma.Notations
(* Abbreviations *)
@@ -119,7 +120,7 @@ let clenv_environments evd bound t =
clrec (evd,[]) bound t
let mk_clenv_from_env env sigma n (c,cty) =
- let evd = create_goal_evar_defs sigma in
+ let evd = clear_metas sigma in
let (evd,args,concl) = clenv_environments evd n cty in
{ templval = mk_freelisted (applist (c,args));
templtyp = mk_freelisted concl;
@@ -335,7 +336,9 @@ let clenv_pose_metas_as_evars clenv dep_mvs =
else
let src = evar_source_of_meta mv clenv.evd in
let src = adjust_meta_source clenv.evd mv src in
- let (evd,evar) = new_evar (cl_env clenv) clenv.evd ~src ty in
+ let evd = Sigma.Unsafe.of_evar_map clenv.evd in
+ let Sigma (evar, evd, _) = new_evar (cl_env clenv) evd ~src ty in
+ let evd = Sigma.to_evar_map evd in
let clenv = clenv_assign mv evar {clenv with evd=evd} in
fold clenv mvs in
fold clenv dep_mvs
@@ -432,6 +435,44 @@ let check_bindings bl =
str " occurs more than once in binding list.")
| [] -> ()
+let explain_no_such_bound_variable evd id =
+ let fold l (n, clb) =
+ let na = match clb with
+ | Cltyp (na, _) -> na
+ | Clval (na, _, _) -> na
+ in
+ if na != Anonymous then out_name na :: l else l
+ in
+ let mvl = List.fold_left fold [] (Evd.meta_list evd) in
+ errorlabstrm "Evd.meta_with_name"
+ (str"No such bound variable " ++ pr_id id ++
+ (if mvl == [] then str " (no bound variables at all in the expression)."
+ else
+ (str" (possible name" ++
+ str (if List.length mvl == 1 then " is: " else "s are: ") ++
+ pr_enum pr_id mvl ++ str").")))
+
+let meta_with_name evd id =
+ let na = Name id in
+ let fold (l1, l2 as l) (n, clb) =
+ let (na',def) = match clb with
+ | Cltyp (na, _) -> (na, false)
+ | Clval (na, _, _) -> (na, true)
+ in
+ if Name.equal na na' then if def then (n::l1,l2) else (n::l1,n::l2)
+ else l
+ in
+ let (mvl, mvnodef) = List.fold_left fold ([], []) (Evd.meta_list evd) in
+ match mvnodef, mvl with
+ | _,[] ->
+ explain_no_such_bound_variable evd id
+ | ([n],_|_,[n]) ->
+ n
+ | _ ->
+ errorlabstrm "Evd.meta_with_name"
+ (str "Binder name \"" ++ pr_id id ++
+ strbrk "\" occurs more than once in clause.")
+
let meta_of_binder clause loc mvs = function
| NamedHyp s -> meta_with_name clause.evd s
| AnonHyp n ->
@@ -576,7 +617,9 @@ let make_evar_clause env sigma ?len t =
| Cast (t, _, _) -> clrec (sigma, holes) n t
| Prod (na, t1, t2) ->
let store = Typeclasses.set_resolvable Evd.Store.empty false in
- let sigma, ev = new_evar ~store env sigma t1 in
+ let sigma = Sigma.Unsafe.of_evar_map sigma in
+ let Sigma (ev, sigma, _) = new_evar ~store env sigma t1 in
+ let sigma = Sigma.to_evar_map sigma in
let dep = dependent (mkRel 1) t2 in
let hole = {
hole_evar = ev;
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml
index aaa49f116..894b290f1 100644
--- a/proofs/clenvtac.ml
+++ b/proofs/clenvtac.ml
@@ -16,7 +16,7 @@ open Logic
open Reduction
open Tacmach
open Clenv
-
+open Proofview.Notations
(* This function put casts around metavariables whose type could not be
* infered by the refiner, that is head of applications, predicates and
@@ -83,10 +83,10 @@ open Unification
let dft = default_unify_flags
let res_pf ?(with_evars=false) ?(with_classes=true) ?(flags=dft ()) clenv =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let clenv gl = clenv_unique_resolver ~flags clenv gl in
clenv_refine with_evars ~with_classes (Tacmach.New.of_old clenv (Proofview.Goal.assume gl))
- end
+ end }
(* [unifyTerms] et [unify] ne semble pas gérer les Meta, en
particulier ne semblent pas vérifier que des instances différentes
@@ -118,12 +118,12 @@ let fail_quick_unif_flags = {
(* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *)
let unify ?(flags=fail_quick_unif_flags) m =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Tacmach.New.pf_env gl in
let n = Tacmach.New.pf_nf_concl gl in
- let evd = create_goal_evar_defs (Proofview.Goal.sigma gl) in
+ let evd = clear_metas (Tacmach.New.project gl) in
try
let evd' = w_unify env evd CONV ~flags m n in
Proofview.Unsafe.tclEVARSADVANCE evd'
with e when Errors.noncritical e -> Proofview.tclZERO e
- end
+ end }
diff --git a/proofs/logic.ml b/proofs/logic.ml
index 5c48995fc..7d101b4c7 100644
--- a/proofs/logic.ml
+++ b/proofs/logic.ml
@@ -95,12 +95,12 @@ let check_typability env sigma c =
forces the user to give them in order). *)
let clear_hyps env sigma ids sign cl =
- let evdref = ref (Evd.create_goal_evar_defs sigma) in
+ let evdref = ref (Evd.clear_metas sigma) in
let (hyps,cl) = Evarutil.clear_hyps_in_evi env evdref sign cl ids in
(hyps, cl, !evdref)
let clear_hyps2 env sigma ids sign t cl =
- let evdref = ref (Evd.create_goal_evar_defs sigma) in
+ let evdref = ref (Evd.clear_metas sigma) in
let (hyps,t,cl) = Evarutil.clear_hyps2_in_evi env evdref sign t cl ids in
(hyps, t, cl, !evdref)
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index 02dbd1fdc..86bc44a62 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -134,7 +134,8 @@ let next = let n = ref 0 in fun () -> incr n; !n
let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac =
let evd = Evd.from_ctx ctx in
- start_proof id goal_kind evd sign typ (fun _ -> ());
+ let terminator = Proof_global.make_terminator (fun _ -> ()) in
+ start_proof id goal_kind evd sign typ terminator;
try
let status = by tac in
let _,(const,univs,_) = cook_proof () in
diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml
index 809ed41c7..e036ae3a1 100644
--- a/proofs/proof_global.ml
+++ b/proofs/proof_global.ml
@@ -91,6 +91,9 @@ type pstate = {
mode : proof_mode Ephemeron.key;
}
+let make_terminator f = f
+let apply_terminator f = f
+
(* The head of [!pstates] is the actual current proof, the other ones are
to be resumed when the current proof is closed or aborted. *)
let pstates = ref ([] : pstate list)
@@ -295,6 +298,11 @@ let get_open_goals () =
(List.map (fun (l1,l2) -> List.length l1 + List.length l2) gll) +
List.length shelf
+let constrain_variables init uctx =
+ let levels = Univ.Instance.levels (Univ.UContext.instance init) in
+ let cstrs = UState.constrain_variables levels uctx in
+ Univ.ContextSet.add_constraints cstrs (UState.context_set uctx)
+
let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
let { pid; section_vars; strength; proof; terminator } = cur_pstate () in
let poly = pi2 strength (* Polymorphic *) in
@@ -324,7 +332,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
if keep_body_ucst_separate ||
not (Safe_typing.empty_private_constants = eff) then
let initunivs = Evd.evar_context_universe_context initial_euctx in
- let ctx = Evd.evar_universe_context_set initunivs universes in
+ let ctx = constrain_variables initunivs universes in
(* For vi2vo compilation proofs are computed now but we need to
* complement the univ constraints of the typ with the ones of
* the body. So we keep the two sets distinct. *)
@@ -332,7 +340,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
(initunivs, typ), ((body, ctx_body), eff)
else
let initunivs = Univ.UContext.empty in
- let ctx = Evd.evar_universe_context_set initunivs universes in
+ let ctx = constrain_variables initunivs universes in
(* Since the proof is computed now, we can simply have 1 set of
* constraints in which we merge the ones for the body and the ones
* for the typ *)
@@ -347,7 +355,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl =
let initunivs = Evd.evar_context_universe_context initial_euctx in
Future.from_val (initunivs, nf t),
Future.chain ~pure:true p (fun (pt,eff) ->
- (pt,Evd.evar_universe_context_set initunivs (Future.force univs)),eff)
+ (pt,constrain_variables initunivs (Future.force univs)),eff)
in
let entries =
Future.map2 (fun p (_, t) ->
diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli
index f8615e849..a67481e71 100644
--- a/proofs/proof_global.mli
+++ b/proofs/proof_global.mli
@@ -70,9 +70,12 @@ type proof_ending =
| Proved of Vernacexpr.opacity_flag *
(Vernacexpr.lident * Decl_kinds.theorem_kind option) option *
proof_object
-type proof_terminator = proof_ending -> unit
+type proof_terminator
type closed_proof = proof_object * proof_terminator
+val make_terminator : (proof_ending -> unit) -> proof_terminator
+val apply_terminator : proof_terminator -> proof_ending -> unit
+
(** [start_proof id str goals terminator] starts a proof of name [id]
with goals [goals] (a list of pairs of environment and
conclusion); [str] describes what kind of theorem/definition this
diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib
index 32bf5576f..1bd701cb9 100644
--- a/proofs/proofs.mllib
+++ b/proofs/proofs.mllib
@@ -4,8 +4,6 @@ Evar_refiner
Proof_using
Proof_type
Proof_errors
-Logic_monad
-Proofview_monad
Logic
Proofview
Proof
diff --git a/proofs/proofview.ml b/proofs/proofview.ml
index de6d60567..bded518e7 100644
--- a/proofs/proofview.ml
+++ b/proofs/proofview.ml
@@ -16,6 +16,7 @@
open Pp
open Util
open Proofview_monad
+open Sigma.Notations
(** Main state of tactics *)
type proofview = Proofview_monad.proofview
@@ -64,7 +65,9 @@ let dependent_init =
let rec aux = function
| TNil sigma -> [], { solution = sigma; comb = []; }
| TCons (env, sigma, typ, t) ->
- let (sigma, econstr ) = Evarutil.new_evar env sigma ~src ~store typ in
+ let sigma = Sigma.Unsafe.of_evar_map sigma in
+ let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in
+ let sigma = Sigma.to_evar_map sigma in
let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in
let (gl, _) = Term.destEvar econstr in
let entry = (econstr, typ) :: ret in
@@ -887,19 +890,11 @@ module Unsafe = struct
end
+module UnsafeRepr = Proof.Unsafe
-
-(** {7 Notations} *)
-
-module Notations = struct
- let (>>=) = tclBIND
- let (<*>) = tclTHEN
- let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
-end
-
-open Notations
-
-
+let (>>=) = tclBIND
+let (<*>) = tclTHEN
+let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
(** {6 Goal-dependent tactics} *)
@@ -913,17 +908,20 @@ let catchable_exception = function
module Goal = struct
- type 'a t = {
+ type ('a, 'r) t = {
env : Environ.env;
sigma : Evd.evar_map;
concl : Term.constr ;
self : Evar.t ; (* for compatibility with old-style definitions *)
}
- let assume (gl : 'a t) = (gl :> [ `NF ] t)
+ type ('a, 'b) enter =
+ { enter : 'r. ('a, 'r) t -> 'b }
+
+ let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t)
let env { env=env } = env
- let sigma { sigma=sigma } = sigma
+ let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma
let hyps { env=env } = Environ.named_context env
let concl { concl=concl } = concl
let extra { sigma=sigma; self=self } = Goal.V82.extra sigma self
@@ -949,7 +947,7 @@ module Goal = struct
tclEVARMAP >>= fun sigma ->
try
let (gl, sigma) = nf_gmake env sigma goal in
- tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f gl))
+ tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl))
with e when catchable_exception e ->
let (e, info) = Errors.push e in
tclZERO ~info e
@@ -967,7 +965,7 @@ module Goal = struct
gmake_with info env sigma goal
let enter f =
- let f gl = InfoL.tag (Info.DBranch) (f gl) in
+ let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in
InfoL.tag (Info.Dispatch) begin
iter_goal begin fun goal ->
Env.get >>= fun env ->
@@ -979,6 +977,43 @@ module Goal = struct
end
end
+ type ('a, 'b) s_enter =
+ { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma }
+
+ let s_enter f =
+ InfoL.tag (Info.Dispatch) begin
+ iter_goal begin fun goal ->
+ Env.get >>= fun env ->
+ tclEVARMAP >>= fun sigma ->
+ try
+ let gl = gmake env sigma goal in
+ let sigma = Sigma.Unsafe.of_evar_map sigma in
+ let Sigma (tac, sigma, _) = f.s_enter gl sigma in
+ let sigma = Sigma.to_evar_map sigma in
+ tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac)
+ with e when catchable_exception e ->
+ let (e, info) = Errors.push e in
+ tclZERO ~info e
+ end
+ end
+
+ let nf_s_enter f =
+ InfoL.tag (Info.Dispatch) begin
+ iter_goal begin fun goal ->
+ Env.get >>= fun env ->
+ tclEVARMAP >>= fun sigma ->
+ try
+ let (gl, sigma) = nf_gmake env sigma goal in
+ let sigma = Sigma.Unsafe.of_evar_map sigma in
+ let Sigma (tac, sigma, _) = f.s_enter gl sigma in
+ let sigma = Sigma.to_evar_map sigma in
+ tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac)
+ with e when catchable_exception e ->
+ let (e, info) = Errors.push e in
+ tclZERO ~info e
+ end
+ end
+
let goals =
Env.get >>= fun env ->
Pv.get >>= fun step ->
@@ -998,6 +1033,8 @@ module Goal = struct
(* compatibility *)
let goal { self=self } = self
+ let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t)
+
end
@@ -1022,8 +1059,9 @@ struct
let (pr_constrv,pr_constr) =
Hook.make ~default:(fun _env _sigma _c -> Pp.str"<constr>") ()
- let refine ?(unsafe = true) f = Goal.enter begin fun gl ->
+ let refine ?(unsafe = true) f = Goal.enter { Goal.enter = begin fun gl ->
let sigma = Goal.sigma gl in
+ let sigma = Sigma.to_evar_map sigma in
let env = Goal.env gl in
let concl = Goal.concl gl in
(** Save the [future_goals] state to restore them after the
@@ -1031,7 +1069,7 @@ struct
let prev_future_goals = Evd.future_goals sigma in
let prev_principal_goal = Evd.principal_future_goal sigma in
(** Create the refinement term *)
- let (sigma, c) = f (Evd.reset_future_goals sigma) in
+ let (c, sigma) = Sigma.run (Evd.reset_future_goals sigma) f in
let evs = Evd.future_goals sigma in
let evkmain = Evd.principal_future_goal sigma in
(** Check that the introduced evars are well-typed *)
@@ -1059,7 +1097,7 @@ struct
let open Proof in
InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >>
Pv.set { solution = sigma; comb; }
- end
+ end }
(** Useful definitions *)
@@ -1071,12 +1109,16 @@ struct
in
evd , j'.Environ.uj_val
- let refine_casted ?unsafe f = Goal.enter begin fun gl ->
+ let refine_casted ?unsafe f = Goal.enter { Goal.enter = begin fun gl ->
let concl = Goal.concl gl in
let env = Goal.env gl in
- let f h = let (h, c) = f h in with_type env h c concl in
+ let f = { run = fun h ->
+ let Sigma (c, h, p) = f.run h in
+ let sigma, c = with_type env (Sigma.to_evar_map h) c concl in
+ Sigma (c, Sigma.Unsafe.of_evar_map sigma, p)
+ } in
refine ?unsafe f
- end
+ end }
end
@@ -1211,3 +1253,15 @@ module V82 = struct
let (e, info) = Errors.push e in tclZERO ~info e
end
+
+(** {7 Notations} *)
+
+module Notations = struct
+ let (>>=) = tclBIND
+ let (<*>) = tclTHEN
+ let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
+ type ('a, 'b) enter = ('a, 'b) Goal.enter =
+ { enter : 'r. ('a, 'r) Goal.t -> 'b }
+ type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter =
+ { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma }
+end
diff --git a/proofs/proofview.mli b/proofs/proofview.mli
index 927df33a0..aafd4c575 100644
--- a/proofs/proofview.mli
+++ b/proofs/proofview.mli
@@ -405,65 +405,84 @@ module Unsafe : sig
val mark_as_goal : proofview -> Evar.t -> proofview
end
-(** {7 Notations} *)
-
-module Notations : sig
-
- (** {!tclBIND} *)
- val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
- (** {!tclTHEN} *)
- val (<*>) : unit tactic -> 'a tactic -> 'a tactic
- (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *)
- val (<+>) : 'a tactic -> 'a tactic -> 'a tactic
-
+(** This module gives access to the innards of the monad. Its use is
+ restricted to very specific cases. *)
+module UnsafeRepr :
+sig
+ type state = Proofview_monad.Logical.Unsafe.state
+ val repr : 'a tactic -> ('a, state, state, iexn) Logic_monad.BackState.t
+ val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic
end
-
(** {6 Goal-dependent tactics} *)
module Goal : sig
- (** The type of goals. The parameter type is a phantom argument indicating
- whether the data contained in the goal has been normalized w.r.t. the
- current sigma. If it is the case, it is flagged [ `NF ]. You may still
- access the un-normalized data using {!assume} if you known you do not rely
- on the assumption of being normalized, at your own risk. *)
- type 'a t
+ (** Type of goals.
+
+ The first parameter type is a phantom argument indicating whether the data
+ contained in the goal has been normalized w.r.t. the current sigma. If it
+ is the case, it is flagged [ `NF ]. You may still access the un-normalized
+ data using {!assume} if you known you do not rely on the assumption of
+ being normalized, at your own risk.
+
+ The second parameter is a stage indicating where the goal belongs. See
+ module {!Sigma}.
+ *)
+ type ('a, 'r) t
(** Assume that you do not need the goal to be normalized. *)
- val assume : 'a t -> [ `NF ] t
+ val assume : ('a, 'r) t -> ([ `NF ], 'r) t
(** Normalises the argument goal. *)
- val normalize : 'a t -> [ `NF ] t tactic
+ val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic
(** [concl], [hyps], [env] and [sigma] given a goal [gl] return
respectively the conclusion of [gl], the hypotheses of [gl], the
environment of [gl] (i.e. the global environment and the
hypotheses) and the current evar map. *)
- val concl : [ `NF ] t -> Term.constr
- val hyps : [ `NF ] t -> Context.named_context
- val env : 'a t -> Environ.env
- val sigma : 'a t -> Evd.evar_map
- val extra : 'a t -> Evd.Store.t
+ val concl : ([ `NF ], 'r) t -> Term.constr
+ val hyps : ([ `NF ], 'r) t -> Context.named_context
+ val env : ('a, 'r) t -> Environ.env
+ val sigma : ('a, 'r) t -> 'r Sigma.t
+ val extra : ('a, 'r) t -> Evd.Store.t
(** Returns the goal's conclusion even if the goal is not
normalised. *)
- val raw_concl : 'a t -> Term.constr
+ val raw_concl : ('a, 'r) t -> Term.constr
+
+ type ('a, 'b) enter =
+ { enter : 'r. ('a, 'r) t -> 'b }
(** [nf_enter t] applies the goal-dependent tactic [t] in each goal
independently, in the manner of {!tclINDEPENDENT} except that
the current goal is also given as an argument to [t]. The goal
is normalised with respect to evars. *)
- val nf_enter : ([ `NF ] t -> unit tactic) -> unit tactic
+ val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic
(** Like {!nf_enter}, but does not normalize the goal beforehand. *)
- val enter : ([ `LZ ] t -> unit tactic) -> unit tactic
+ val enter : ([ `LZ ], unit tactic) enter -> unit tactic
+
+ type ('a, 'b) s_enter =
+ { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma }
- (** Recover the list of current goals under focus, without evar-normalization *)
- val goals : [ `LZ ] t tactic list tactic
+ (** A variant of {!enter} allows to work with a monotonic state. The evarmap
+ returned by the argument is put back into the current state before firing
+ the returned tactic. *)
+ val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic
+
+ (** Like {!s_enter}, but normalizes the goal beforehand. *)
+ val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic
+
+ (** Recover the list of current goals under focus, without evar-normalization.
+ FIXME: encapsulate the level in an existential type. *)
+ val goals : ([ `LZ ], 'r) t tactic list tactic
(** Compatibility: avoid if possible *)
- val goal : [ `NF ] t -> Evar.t
+ val goal : ([ `NF ], 'r) t -> Evar.t
+
+ (** Every goal is valid at a later stage. FIXME: take a later evarmap *)
+ val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t
end
@@ -478,7 +497,7 @@ module Refine : sig
(** {7 Refinement primitives} *)
- val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * Constr.t) -> unit tactic
+ val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic
(** In [refine ?unsafe t], [t] is a term with holes under some
[evar_map] context. The term [t] is used as a partial solution
for the current goal (refine is a goal-dependent tactic), the
@@ -494,7 +513,7 @@ module Refine : sig
(** [with_type env sigma c t] ensures that [c] is of type [t]
inserting a coercion if needed. *)
- val refine_casted : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map*Constr.t) -> unit tactic
+ val refine_casted : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic
(** Like {!refine} except the refined term is coerced to the conclusion of the
current goal. *)
@@ -574,3 +593,20 @@ module V82 : sig
the monad. *)
val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic
end
+
+(** {7 Notations} *)
+
+module Notations : sig
+
+ (** {!tclBIND} *)
+ val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
+ (** {!tclTHEN} *)
+ val (<*>) : unit tactic -> 'a tactic -> 'a tactic
+ (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *)
+ val (<+>) : 'a tactic -> 'a tactic -> 'a tactic
+
+ type ('a, 'b) enter = ('a, 'b) Goal.enter =
+ { enter : 'r. ('a, 'r) Goal.t -> 'b }
+ type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter =
+ { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma }
+end
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
index 4238d1e37..57c60cbee 100644
--- a/proofs/tacmach.ml
+++ b/proofs/tacmach.ml
@@ -158,11 +158,15 @@ let pr_glls glls =
(* Variants of [Tacmach] functions built with the new proof engine *)
module New = struct
+ let project gl =
+ let sigma = Proofview.Goal.sigma gl in
+ Sigma.to_evar_map sigma
+
let pf_apply f gl =
- f (Proofview.Goal.env gl) (Proofview.Goal.sigma gl)
+ f (Proofview.Goal.env gl) (project gl)
let of_old f gl =
- f { Evd.it = Proofview.Goal.goal gl ; sigma = Proofview.Goal.sigma gl }
+ f { Evd.it = Proofview.Goal.goal gl ; sigma = project gl; }
let pf_global id gl =
(** We only check for the existence of an [id] in [hyps] *)
@@ -212,11 +216,11 @@ module New = struct
let hyps = Proofview.Goal.hyps gl in
List.hd hyps
- let pf_nf_concl (gl : [ `LZ ] Proofview.Goal.t) =
+ let pf_nf_concl (gl : ([ `LZ ], 'r) Proofview.Goal.t) =
(** We normalize the conclusion just after *)
let gl = Proofview.Goal.assume gl in
let concl = Proofview.Goal.concl gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = project gl in
nf_evar sigma concl
let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t
@@ -235,6 +239,6 @@ module New = struct
let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t
let pf_compute gl t = pf_apply compute gl t
- let pf_nf_evar gl t = nf_evar (Proofview.Goal.sigma gl) t
+ let pf_nf_evar gl t = nf_evar (project gl) t
end
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
index a0e1a0157..c45fd250c 100644
--- a/proofs/tacmach.mli
+++ b/proofs/tacmach.mli
@@ -106,36 +106,38 @@ val pr_glls : goal list sigma -> Pp.std_ppcmds
(* Variants of [Tacmach] functions built with the new proof engine *)
module New : sig
- val pf_apply : (env -> evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a
- val pf_global : identifier -> 'a Proofview.Goal.t -> constr
- val of_old : (Proof_type.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a
+ val pf_apply : (env -> evar_map -> 'a) -> ('b, 'r) Proofview.Goal.t -> 'a
+ val pf_global : identifier -> ('a, 'r) Proofview.Goal.t -> constr
+ (** FIXME: encapsulate the level in an existential type. *)
+ val of_old : (Proof_type.goal Evd.sigma -> 'a) -> ([ `NF ], 'r) Proofview.Goal.t -> 'a
- val pf_env : 'a Proofview.Goal.t -> Environ.env
- val pf_concl : [ `NF ] Proofview.Goal.t -> types
+ val project : ('a, 'r) Proofview.Goal.t -> Evd.evar_map
+ val pf_env : ('a, 'r) Proofview.Goal.t -> Environ.env
+ val pf_concl : ([ `NF ], 'r) Proofview.Goal.t -> types
- val pf_unsafe_type_of : 'a Proofview.Goal.t -> Term.constr -> Term.types
- val pf_type_of : 'a Proofview.Goal.t -> Term.constr -> evar_map * Term.types
- val pf_conv_x : 'a Proofview.Goal.t -> Term.constr -> Term.constr -> bool
+ val pf_unsafe_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.types
+ val pf_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> evar_map * Term.types
+ val pf_conv_x : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.constr -> bool
- val pf_get_new_id : identifier -> [ `NF ] Proofview.Goal.t -> identifier
- val pf_ids_of_hyps : 'a Proofview.Goal.t -> identifier list
- val pf_hyps_types : 'a Proofview.Goal.t -> (identifier * types) list
+ val pf_get_new_id : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> identifier
+ val pf_ids_of_hyps : ('a, 'r) Proofview.Goal.t -> identifier list
+ val pf_hyps_types : ('a, 'r) Proofview.Goal.t -> (identifier * types) list
- val pf_get_hyp : identifier -> [ `NF ] Proofview.Goal.t -> named_declaration
- val pf_get_hyp_typ : identifier -> [ `NF ] Proofview.Goal.t -> types
- val pf_last_hyp : [ `NF ] Proofview.Goal.t -> named_declaration
+ val pf_get_hyp : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> named_declaration
+ val pf_get_hyp_typ : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> types
+ val pf_last_hyp : ([ `NF ], 'r) Proofview.Goal.t -> named_declaration
- val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types
- val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> pinductive * types
+ val pf_nf_concl : ([ `LZ ], 'r) Proofview.Goal.t -> types
+ val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> types -> pinductive * types
- val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types
- val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types
+ val pf_hnf_constr : ('a, 'r) Proofview.Goal.t -> constr -> types
+ val pf_hnf_type_of : ('a, 'r) Proofview.Goal.t -> constr -> types
- val pf_whd_betadeltaiota : 'a Proofview.Goal.t -> constr -> constr
- val pf_compute : 'a Proofview.Goal.t -> constr -> constr
+ val pf_whd_betadeltaiota : ('a, 'r) Proofview.Goal.t -> constr -> constr
+ val pf_compute : ('a, 'r) Proofview.Goal.t -> constr -> constr
- val pf_matches : 'a Proofview.Goal.t -> constr_pattern -> constr -> patvar_map
+ val pf_matches : ('a, 'r) Proofview.Goal.t -> constr_pattern -> constr -> patvar_map
- val pf_nf_evar : 'a Proofview.Goal.t -> constr -> constr
+ val pf_nf_evar : ('a, 'r) Proofview.Goal.t -> constr -> constr
end
diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml
index 6d6215c52..fb23a28fe 100644
--- a/proofs/tactic_debug.ml
+++ b/proofs/tactic_debug.ml
@@ -12,6 +12,7 @@ open Pp
open Tacexpr
open Termops
open Nameops
+open Proofview.Notations
let (prtac, tactic_printer) = Hook.make ()
let (prmatchpatt, match_pattern_printer) = Hook.make ()
@@ -47,10 +48,10 @@ let db_pr_goal gl =
str" " ++ pc) ++ fnl ()
let db_pr_goal =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let pg = db_pr_goal gl in
Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg))
- end
+ end }
(* Prints the commands *)
diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml
index e3fb0b607..e525031e6 100644
--- a/stm/asyncTaskQueue.ml
+++ b/stm/asyncTaskQueue.ml
@@ -297,7 +297,7 @@ module Make(T : Task) = struct
let slave_feeder oc fb =
Marshal.to_channel oc (RespFeedback fb) []; flush oc in
Pp.set_feeder (fun x -> slave_feeder (Option.get !slave_oc) x);
- Pp.log_via_feedback ();
+ Pp.log_via_feedback (fun msg -> Richpp.repr (Richpp.richpp_of_pp msg));
Universes.set_remote_new_univ_level (bufferize (fun () ->
marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel;
match unmarshal_more_data (Option.get !slave_ic) with
diff --git a/stm/lemmas.ml b/stm/lemmas.ml
index 6c1832688..17a10ccba 100644
--- a/stm/lemmas.ml
+++ b/stm/lemmas.ml
@@ -328,7 +328,8 @@ let check_exist =
)
let universe_proof_terminator compute_guard hook =
- let open Proof_global in function
+ let open Proof_global in
+ make_terminator begin function
| Admitted (id,k,pe,ctx) ->
admit (id,k,pe) (hook (Some ctx)) ();
Pp.feedback Feedback.AddedAxiom
@@ -346,12 +347,16 @@ let universe_proof_terminator compute_guard hook =
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 kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook =
- let terminator = standard_proof_terminator compute_guard hook in
+let start_proof id 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
@@ -360,8 +365,11 @@ let start_proof id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook =
!start_hook c;
Pfedit.start_proof id kind sigma sign c ?init_tac terminator
-let start_proof_univs id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook =
- let terminator = universe_proof_terminator compute_guard hook in
+let start_proof_univs id 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
@@ -421,7 +429,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook =
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 = Evd.evar_universe_context_set (*FIXME*) Univ.UContext.empty ctx 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
@@ -491,7 +499,7 @@ let save_proof ?proof = function
| _ -> None in
Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None),universes)
in
- Proof_global.get_terminator() pe
+ Proof_global.apply_terminator (Proof_global.get_terminator ()) pe
| Vernacexpr.Proved (is_opaque,idopt) ->
let (proof_obj,terminator) =
match proof with
@@ -501,7 +509,7 @@ let save_proof ?proof = function
in
(* if the proof is given explicitly, nothing has to be deleted *)
if Option.is_empty proof then Pfedit.delete_current_proof ();
- terminator (Proof_global.Proved (is_opaque,idopt,proof_obj))
+ Proof_global.(apply_terminator terminator (Proved (is_opaque,idopt,proof_obj)))
(* Miscellaneous *)
diff --git a/stm/lemmas.mli b/stm/lemmas.mli
index 6556aa229..dca6afe19 100644
--- a/stm/lemmas.mli
+++ b/stm/lemmas.mli
@@ -24,11 +24,15 @@ val call_hook :
(** A hook start_proof calls on the type of the definition being started *)
val set_start_hook : (types -> unit) -> unit
-val start_proof : Id.t -> goal_kind -> Evd.evar_map -> ?sign:Environ.named_context_val -> types ->
+val start_proof : Id.t -> 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 -> goal_kind -> Evd.evar_map -> ?sign:Environ.named_context_val -> types ->
+val start_proof_univs : Id.t -> goal_kind -> Evd.evar_map ->
+ ?terminator:(lemma_possible_guards -> (Proof_global.proof_universes option -> unit declaration_hook) -> Proof_global.proof_terminator) ->
+ ?sign:Environ.named_context_val -> types ->
?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards ->
(Proof_global.proof_universes option -> unit declaration_hook) -> unit
@@ -40,6 +44,11 @@ val start_proof_with_initialization :
(Id.t * (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 ->
+ (Proof_global.proof_universes option -> unit declaration_hook) ->
+ Proof_global.proof_terminator
+
val standard_proof_terminator :
Proof_global.lemma_possible_guards -> unit declaration_hook ->
Proof_global.proof_terminator
diff --git a/stm/stm.ml b/stm/stm.ml
index 88a1fbbf4..7dc0ff84a 100644
--- a/stm/stm.ml
+++ b/stm/stm.ml
@@ -166,7 +166,7 @@ type visit = { step : step; next : Stateid.t }
(* Parts of the system state that are morally part of the proof state *)
let summary_pstate = [ Evarutil.meta_counter_summary_name;
- Evarutil.evar_counter_summary_name;
+ Evd.evar_counter_summary_name;
"program-tcc-table" ]
type state = {
system : States.state;
diff --git a/tactics/auto.ml b/tactics/auto.ml
index a6b53d76c..4a520612f 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -76,7 +76,7 @@ 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 = Proofview.Goal.sigma gl in
+ 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 =
@@ -96,11 +96,11 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl =
in clenv, c
let unify_resolve poly flags ((c : raw_hint), clenv) =
- Proofview.Goal.nf_enter begin fun gl ->
+ 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
+ end }
let unify_resolve_nodelta poly h = unify_resolve poly auto_unif_flags h
@@ -119,10 +119,11 @@ let exact poly (c,clenv) =
let ctx = Evd.evar_universe_context clenv.evd in
ctx, c
in
- Proofview.Goal.enter begin fun gl ->
- let sigma = Evd.merge_universe_context (Proofview.Goal.sigma gl) ctx in
- Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (exact_check c')
- end
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
+ let sigma = Sigma.to_evar_map sigma in
+ let sigma = Evd.merge_universe_context sigma ctx in
+ Sigma.Unsafe.of_pair (exact_check c', sigma)
+ end }
(* Util *)
@@ -150,11 +151,12 @@ let conclPattern concl pat tac =
with Constr_matching.PatternMatchingFailure ->
Tacticals.New.tclZEROMSG (str "conclPattern")
in
- Proofview.Goal.enter (fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
constr_bindings env sigma >>= fun constr_bindings ->
- Hook.get forward_interp_tactic constr_bindings tac)
+ Hook.get forward_interp_tactic constr_bindings tac
+ end }
(***********************************************************)
(** A debugging / verbosity framework for trivial and auto *)
@@ -319,8 +321,8 @@ 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 begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ ( 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
@@ -328,15 +330,15 @@ let rec trivial_fail_db dbg mod_delta db_list local_db =
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)
+ end })
in
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let concl = Tacmach.New.pf_nf_concl gl in
Tacticals.New.tclFIRST
((dbg_assumption dbg)::intro_tac::
(List.map Tacticals.New.tclCOMPLETE
(trivial_resolve dbg mod_delta db_list local_db concl)))
- end
+ end }
and my_find_search_nodelta db_list local_db hdc concl =
List.map (fun hint -> (None,hint))
@@ -413,26 +415,26 @@ and trivial_resolve dbg mod_delta db_list local_db cl =
"nocore" amongst the databases. *)
let trivial ?(debug=Off) lems dbnames =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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
+ end }
let full_trivial ?(debug=Off) lems =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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
+ end }
let gen_trivial ?(debug=Off) lems = function
| None -> full_trivial ~debug lems
@@ -457,7 +459,7 @@ let possible_resolve dbg mod_delta db_list local_db cl =
let extend_local_db decl db gl =
let env = Tacmach.New.pf_env gl in
- let sigma = Proofview.Goal.sigma 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]
@@ -465,10 +467,10 @@ let extend_local_db decl db gl =
let intro_register dbg kont db =
Tacticals.New.tclTHEN (dbg_intro dbg)
- (Proofview.Goal.enter begin fun gl ->
+ (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)
+ end })
(* n is the max depth of search *)
(* local_db contains the local Hypotheses *)
@@ -481,14 +483,14 @@ let search d n mod_delta db_list local_db =
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 begin fun gl ->
+ ( Proofview.Goal.enter { enter = begin fun gl ->
let concl = Tacmach.New.pf_nf_concl 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 concl))
- end))
+ end }))
end []
in
search d n local_db
@@ -496,15 +498,15 @@ let search d n mod_delta db_list local_db =
let default_search_depth = ref 5
let delta_auto debug mod_delta n lems dbnames =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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
+ end }
let delta_auto =
if Flags.profile then
@@ -519,15 +521,15 @@ 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 begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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
+ 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
diff --git a/tactics/auto.mli b/tactics/auto.mli
index cae180ce7..215544a59 100644
--- a/tactics/auto.mli
+++ b/tactics/auto.mli
@@ -26,7 +26,7 @@ val default_search_depth : int ref
val auto_flags_of_state : transparent_state -> Unification.unify_flags
val connect_hint_clenv : polymorphic -> raw_hint -> clausenv ->
- [ `NF ] Proofview.Goal.t -> clausenv * constr
+ ([ `NF ], 'r) Proofview.Goal.t -> clausenv * constr
(** Try unification with the precompiled clause, then use registered Apply *)
val unify_resolve_nodelta : polymorphic -> (raw_hint * clausenv) -> unit Proofview.tactic
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index 3a9d40de0..43a8d7f06 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -18,6 +18,8 @@ open Util
open Tacexpr
open Mod_subst
open Locus
+open Sigma.Notations
+open Proofview.Notations
(* Rewriting rules *)
type rew_rule = { rew_lemma: constr;
@@ -91,14 +93,15 @@ type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tac
(* 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_enter (fun gl ->
+ let try_rewrite dir ctx c tc =
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma ->
let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in
let c' = Vars.subst_univs_level_constr subst c in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Sigma.to_evar_map sigma in
let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in
- Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma)
- (general_rewrite_maybe_in dir c' tc)
- ) 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 t -> Tacinterp.eval_tactic t in
(h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in
@@ -120,7 +123,7 @@ let autorewrite ?(conds=Naive) tac_main lbas =
(Proofview.tclUNIT()) lbas))
let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas =
- Proofview.Goal.nf_enter begin fun gl ->
+ 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 =
@@ -163,7 +166,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas =
(List.fold_left (fun tac bas ->
Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas)))
idl
- end
+ end }
let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id]
@@ -188,10 +191,10 @@ let gen_auto_multi_rewrite conds tac_main lbas cl =
| None ->
(* try to rewrite in all hypothesis
(except maybe the rewritten one) *)
- Proofview.Goal.nf_enter begin fun gl ->
+ 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)
+ end })
let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds (Proofview.tclUNIT())
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml
index f3a486344..8ee3ec928 100644
--- a/tactics/class_tactics.ml
+++ b/tactics/class_tactics.ml
@@ -39,6 +39,10 @@ let typeclasses_dependency_order = ref false
let set_typeclasses_dependency_order d = (:=) typeclasses_dependency_order d
let get_typeclasses_dependency_order () = !typeclasses_dependency_order
+let typeclasses_iterative_deepening = ref false
+let set_typeclasses_iterative_deepening d = (:=) typeclasses_iterative_deepening d
+let get_typeclasses_iterative_deepening () = !typeclasses_iterative_deepening
+
open Goptions
let _ =
@@ -59,6 +63,15 @@ let _ =
optread = get_typeclasses_dependency_order;
optwrite = set_typeclasses_dependency_order; }
+let _ =
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "use iterative deepening strategy";
+ optkey = ["Typeclasses";"Iterative";"Deepening"];
+ optread = get_typeclasses_iterative_deepening;
+ optwrite = set_typeclasses_iterative_deepening; }
+
(** We transform the evars that are concerned by this resolution
(according to predicate p) into goals.
Invariant: function p only manipulates and returns undefined evars *)
@@ -127,17 +140,17 @@ let rec eq_constr_mod_evars x y =
| _, _ -> compare_constr eq_constr_mod_evars x y
let progress_evars t =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let check =
- Proofview.Goal.nf_enter begin fun gl' ->
+ Proofview.Goal.nf_enter { enter = begin fun gl' ->
let newconcl = Proofview.Goal.concl gl' in
if eq_constr_mod_evars concl newconcl
then Tacticals.New.tclFAIL 0 (str"No progress made (modulo evars)")
else Proofview.tclUNIT ()
- end
+ end }
in t <*> check
- end
+ end }
let e_give_exact flags poly (c,clenv) gl =
@@ -153,15 +166,17 @@ let e_give_exact flags poly (c,clenv) gl =
let t1 = pf_unsafe_type_of gl c in
tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl
-let unify_e_resolve poly flags (c,clenv) gls =
+let unify_e_resolve poly flags = { enter = begin fun gls (c,clenv) ->
let clenv', c = connect_hint_clenv poly c clenv gls in
let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in
Clenvtac.clenv_refine true ~with_classes:false clenv'
+ end }
-let unify_resolve poly flags (c,clenv) gls =
+let unify_resolve poly flags = { enter = begin fun gls (c,clenv) ->
let clenv', _ = connect_hint_clenv poly c clenv gls in
let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in
Clenvtac.clenv_refine false ~with_classes:false clenv'
+ end }
let clenv_of_prods poly nprods (c, clenv) gl =
let (c, _, _) = c in
@@ -175,16 +190,17 @@ let clenv_of_prods poly nprods (c, clenv) gl =
else None
let with_prods nprods poly (c, clenv) f =
- Proofview.Goal.nf_enter (fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
match clenv_of_prods poly nprods (c, clenv) gl with
| None -> Tacticals.New.tclZEROMSG (str"Not enough premisses")
- | Some clenv' -> f (c, clenv') gl)
+ | Some clenv' -> f.enter gl (c, clenv')
+ end }
(** Hack to properly solve dependent evars that are typeclasses *)
let rec e_trivial_fail_db db_list local_db goal =
let tacl =
- Eauto.registered_e_assumption ::
+ Proofview.V82.of_tactic Eauto.registered_e_assumption ::
(tclTHEN (Proofview.V82.of_tactic Tactics.intro)
(function g'->
let d = pf_last_hyp g' in
@@ -267,7 +283,8 @@ type autoinfo = { hints : hint_db; is_evar: existential_key option;
auto_path : global_reference option list;
auto_cut : hints_path }
type autogoal = goal * autoinfo
-type 'ans fk = unit -> 'ans
+type failure = NotApplicable | ReachedLimit
+type 'ans fk = failure -> 'ans
type ('a,'ans) sk = 'a -> 'ans fk -> 'ans
type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans }
@@ -282,7 +299,7 @@ type 'a optionk =
| Somek of 'a * 'a optionk fk
type ('a,'b) optionk2 =
- | Nonek2
+ | Nonek2 of failure
| Somek2 of 'a * 'b * ('a,'b) optionk2 fk
let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
@@ -364,7 +381,7 @@ let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : '
with e when catchable e -> None in
match res with
| Some gls -> sk (f gls hints) fk
- | None -> fk () }
+ | None -> fk NotApplicable }
let intro_tac : atac =
lift_tactic (Proofview.V82.of_tactic Tactics.intro)
@@ -385,8 +402,19 @@ let normevars_tac : atac =
let info' = { info with auto_last_tac = lazy (str"normevars") } in
sk {it = [gl', info']; sigma = sigma';} fk }
+let merge_failures x y =
+ match x, y with
+ | _, ReachedLimit
+ | ReachedLimit, _ -> ReachedLimit
+ | NotApplicable, NotApplicable -> NotApplicable
+
let or_tac (x : 'a tac) (y : 'a tac) : 'a tac =
- { skft = fun sk fk gls -> x.skft sk (fun () -> y.skft sk fk gls) gls }
+ { skft = fun sk fk gls -> x.skft sk
+ (fun f -> y.skft sk (fun f' -> fk (merge_failures f f')) gls) gls }
+
+let or_else_tac (x : 'a tac) (y : failure -> 'a tac) : 'a tac =
+ { skft = fun sk fk gls -> x.skft sk
+ (fun f -> (y f).skft sk fk gls) gls }
let is_Prop env sigma concl =
let ty = Retyping.get_type_of env sigma concl in
@@ -463,7 +491,7 @@ let hints_tac hints =
in g, info) 1 newgls in
let glsv = {it = gls'; sigma = s';} in
let fk' =
- (fun () ->
+ (fun e ->
let do_backtrack =
if unique then occur_existential concl
else if info.unique then true
@@ -471,22 +499,25 @@ let hints_tac hints =
needs_backtrack env s' info.is_evar concl
else true
in
+ let e' = match foundone with None -> e | Some e' -> merge_failures e e' in
if !typeclasses_debug then
msg_debug
((if do_backtrack then str"Backtracking after "
else str "Not backtracking after ")
++ Lazy.force pp);
- if do_backtrack then aux (succ i) true tl
- else fk ())
+ if do_backtrack then aux (succ i) (Some e') tl
+ else fk e')
in
sk glsv fk')
| [] ->
- if not foundone && !typeclasses_debug then
+ if foundone == None && !typeclasses_debug then
msg_debug (pr_depth info.auto_depth ++ str": no match for " ++
Printer.pr_constr_env (Goal.V82.env s gl) s concl ++
spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities");
- fk ()
- in aux 1 false poss }
+ match foundone with
+ | Some e -> fk e
+ | None -> fk NotApplicable
+ in aux 1 None poss }
let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk =
let rec aux s (acc : autogoal list list) fk = function
@@ -509,11 +540,11 @@ let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk
| [] -> Somek2 (List.rev acc, s, fk)
in fun {it = gls; sigma = s; } fk ->
let rec aux' = function
- | Nonek2 -> fk ()
+ | Nonek2 e -> fk e
| Somek2 (res, s', fk') ->
let goals' = List.concat res in
- sk {it = goals'; sigma = s'; } (fun () -> aux' (fk' ()))
- in aux' (aux s [] (fun () -> Nonek2) gls)
+ sk {it = goals'; sigma = s'; } (fun e -> aux' (fk' e))
+ in aux' (aux s [] (fun e -> Nonek2 e) gls)
let then_tac (first : atac) (second : atac) : atac =
{ skft = fun sk fk -> first.skft (then_list second sk) fk }
@@ -528,16 +559,38 @@ let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res
gl
(fun _ -> Nonek)
-let fail_tac : atac =
- { skft = fun sk fk _ -> fk () }
+let fail_tac reason : atac =
+ { skft = fun sk fk _ -> fk reason }
let rec fix (t : 'a tac) : 'a tac =
then_tac t { skft = fun sk fk -> (fix t).skft sk fk }
let rec fix_limit limit (t : 'a tac) : 'a tac =
- if Int.equal limit 0 then fail_tac
+ if Int.equal limit 0 then fail_tac ReachedLimit
else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk }
+let fix_iterative' t =
+ let rec aux depth =
+ { skft = fun sk fk gls ->
+ (fix_limit depth t).skft sk
+ (function NotApplicable as e -> fk e
+ | ReachedLimit -> (aux (succ depth)).skft sk fk gls) gls }
+ in aux 1
+
+let fix_iterative t =
+ let rec aux depth =
+ or_else_tac (fix_limit depth t)
+ (function
+ | NotApplicable as e -> fail_tac e
+ | ReachedLimit -> aux (succ depth))
+ in aux 1
+
+let fix_iterative_limit limit (t : 'a tac) : 'a tac =
+ let rec aux depth =
+ if Int.equal depth limit then fail_tac ReachedLimit
+ else or_tac (fix_limit depth t) { skft = fun sk fk -> (aux (succ depth)).skft sk fk }
+ in aux 1
+
let make_autogoal ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) cut ev g =
let hints = make_autogoal_hints only_classes ~st g in
(g.it, { hints = hints ; is_evar = ev; unique = unique;
@@ -581,16 +634,14 @@ let eauto_tac hints =
then_tac normevars_tac (or_tac (hints_tac hints) intro_tac)
let eauto_tac ?limit hints =
- match limit with
- | None -> fix (eauto_tac hints)
- | Some limit -> fix_limit limit (eauto_tac hints)
-
-let eauto ?(only_classes=true) ?st ?limit hints g =
- let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g; } in
- match run_tac (eauto_tac ?limit hints) gl with
- | None -> raise Not_found
- | Some {it = goals; sigma = s; } ->
- {it = List.map fst goals; sigma = s;}
+ if get_typeclasses_iterative_deepening () then
+ match limit with
+ | None -> fix_iterative (eauto_tac hints)
+ | Some limit -> fix_iterative_limit limit (eauto_tac hints)
+ else
+ match limit with
+ | None -> fix (eauto_tac hints)
+ | Some limit -> fix_limit limit (eauto_tac hints)
let real_eauto ?limit unique st hints p evd =
let res =
@@ -600,7 +651,7 @@ let real_eauto ?limit unique st hints p evd =
| None -> evd
| Some (evd', fk) ->
if unique then
- (match get_result (fk ()) with
+ (match get_result (fk NotApplicable) with
| Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions"
| None -> evd')
else evd'
@@ -609,6 +660,13 @@ let resolve_all_evars_once debug limit unique p evd =
let db = searchtable_map typeclasses_db in
real_eauto ?limit unique (Hint_db.transparent_state db) [db] p evd
+let eauto ?(only_classes=true) ?st ?limit hints g =
+ let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g; } in
+ match run_tac (eauto_tac ?limit hints) gl with
+ | None -> raise Not_found
+ | Some {it = goals; sigma = s; } ->
+ {it = List.map fst goals; sigma = s;}
+
(** We compute dependencies via a union-find algorithm.
Beware of the imperative effects on the partition structure,
it should not be shared, but only used locally. *)
@@ -846,5 +904,5 @@ let autoapply c i gl =
(Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in
let cty = pf_unsafe_type_of gl c in
let ce = mk_clenv_from gl (c,cty) in
- let tac = unify_e_resolve false flags ((c,cty,Univ.ContextSet.empty),ce) in
+ let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),ce) } in
Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index 22f218b4f..0cc74ff44 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -13,6 +13,8 @@ open Tactics
open Coqlib
open Reductionops
open Misctypes
+open Sigma.Notations
+open Proofview.Notations
(* Absurd *)
@@ -22,18 +24,19 @@ let mk_absurd_proof t =
mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|])))
let absurd c =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Sigma.to_evar_map sigma in
let j = Retyping.get_judgment_of env sigma c in
let sigma, j = Coercion.inh_coerce_to_sort Loc.ghost env sigma j in
let t = j.Environ.utj_val in
+ let tac =
Tacticals.New.tclTHENLIST [
- Proofview.Unsafe.tclEVARS sigma;
elim_type (build_coq_False ());
Simple.apply (mk_absurd_proof t)
- ]
- end
+ ] in
+ Sigma.Unsafe.of_pair (tac, sigma)
+ end }
let absurd c = absurd c
@@ -45,14 +48,14 @@ let filter_hyp f tac =
| [] -> Proofview.tclZERO Not_found
| (id,_,t)::rest when f t -> tac id
| _::rest -> seek rest in
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
seek hyps
- end
+ end }
let contradiction_context =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
let rec seek_neg l = match l with
| [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction")
@@ -64,11 +67,11 @@ let contradiction_context =
else match kind_of_term typ with
| Prod (na,t,u) when is_empty_type u ->
(Proofview.tclORELSE
- (Proofview.Goal.enter begin fun gl ->
+ (Proofview.Goal.enter { enter = begin fun gl ->
let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in
filter_hyp (fun typ -> is_conv_leq typ t)
(fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|])))
- end)
+ end })
begin function (e, info) -> match e with
| Not_found -> seek_neg rest
| e -> Proofview.tclZERO ~info e
@@ -77,7 +80,7 @@ let contradiction_context =
in
let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
seek_neg hyps
- end
+ end }
let is_negation_of env sigma typ t =
match kind_of_term (whd_betadeltaiota env sigma t) with
@@ -87,8 +90,8 @@ let is_negation_of env sigma typ t =
| _ -> false
let contradiction_term (c,lbind as cl) =
- Proofview.Goal.nf_enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
let type_of = Tacmach.New.pf_unsafe_type_of gl in
let typ = type_of c in
@@ -110,7 +113,7 @@ let contradiction_term (c,lbind as cl) =
| Not_found -> Tacticals.New.tclZEROMSG (Pp.str"Not a contradiction.")
| e -> Proofview.tclZERO ~info e
end
- end
+ end }
let contradiction = function
| None -> Tacticals.New.tclTHEN intros contradiction_context
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
index ca430ec11..dbdfb3e92 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml4
@@ -28,32 +28,41 @@ open Misctypes
open Locus
open Locusops
open Hints
+open Proofview.Notations
DECLARE PLUGIN "eauto"
let eauto_unif_flags = auto_flags_of_state full_transparent_state
-let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_unsafe_type_of gl c) and t2 = pf_concl gl in
+let e_give_exact ?(flags=eauto_unif_flags) c =
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let t1 = Tacmach.New.pf_unsafe_type_of gl c in
+ let t2 = Tacmach.New.pf_concl gl in
if occur_existential t1 || occur_existential t2 then
- tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl
- else Proofview.V82.of_tactic (exact_check c) gl
+ Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (Proofview.V82.tactic (exact_no_check c))
+ else exact_check c
+ end }
let assumption id = e_give_exact (mkVar id)
-let e_assumption gl =
- tclFIRST (List.map assumption (pf_ids_of_hyps gl)) gl
+let e_assumption =
+ Proofview.Goal.enter { enter = begin fun gl ->
+ Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl))
+ end }
TACTIC EXTEND eassumption
-| [ "eassumption" ] -> [ Proofview.V82.tactic e_assumption ]
+| [ "eassumption" ] -> [ e_assumption ]
END
TACTIC EXTEND eexact
-| [ "eexact" constr(c) ] -> [ Proofview.V82.tactic (e_give_exact c) ]
+| [ "eexact" constr(c) ] -> [ e_give_exact c ]
END
-let registered_e_assumption gl =
- tclFIRST (List.map (fun id gl -> e_give_exact (mkVar id) gl)
- (pf_ids_of_hyps gl)) gl
+let registered_e_assumption =
+ Proofview.Goal.enter { enter = begin fun gl ->
+ Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id))
+ (Tacmach.New.pf_ids_of_hyps gl))
+ end }
(************************************************************************)
(* PROLOG tactic *)
@@ -82,7 +91,7 @@ let one_step l gl =
[Proofview.V82.of_tactic Tactics.intro]
@ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl)))
@ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l)
- @ (List.map assumption (pf_ids_of_hyps gl))
+ @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl))
let rec prolog l n gl =
if n <= 0 then error "prolog - failure";
@@ -118,15 +127,14 @@ open Unification
let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l)
let unify_e_resolve poly flags (c,clenv) =
- Proofview.Goal.nf_enter begin
- fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let clenv', c = connect_hint_clenv poly c clenv gl in
Proofview.V82.tactic
(fun gls ->
let clenv' = clenv_unique_resolver ~flags clenv' gls in
tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd))
(Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls)
- end
+ end }
let hintmap_of hdc concl =
match hdc with
@@ -142,19 +150,21 @@ let e_exact poly flags (c,clenv) =
if poly then Clenv.refresh_undefined_univs clenv
else clenv, Univ.empty_level_subst
in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c)
-
-let rec e_trivial_fail_db db_list local_db goal =
+
+let rec e_trivial_fail_db db_list local_db =
+ let next = Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let d = Tacmach.New.pf_last_hyp gl in
+ let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in
+ e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db)
+ end } in
+ Proofview.Goal.enter { enter = begin fun gl ->
let tacl =
registered_e_assumption ::
- (tclTHEN (Proofview.V82.of_tactic Tactics.intro)
- (function g'->
- let d = pf_last_hyp g' in
- let hintl = make_resolve_hyp (pf_env g') (project g') d in
- (e_trivial_fail_db db_list
- (Hint_db.add_list (pf_env g') (project g') hintl local_db) g'))) ::
- (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
+ (Tacticals.New.tclTHEN Tactics.intro next) ::
+ (List.map fst (e_trivial_resolve db_list local_db (Tacmach.New.pf_nf_concl gl)))
in
- tclFIRST (List.map tclCOMPLETE tacl) goal
+ Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl)
+ end }
and e_my_find_search db_list local_db hdc concl =
let hint_of_db = hintmap_of hdc concl in
@@ -169,14 +179,14 @@ and e_my_find_search db_list local_db hdc concl =
let tac = function
| Res_pf (term,cl) -> unify_resolve poly st (term,cl)
| ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl)
- | Give_exact (c,cl) -> Proofview.V82.tactic (e_exact poly st (c,cl))
+ | Give_exact (c,cl) -> e_exact poly st (c,cl)
| Res_pf_THEN_trivial_fail (term,cl) ->
- Proofview.V82.tactic (tclTHEN (Proofview.V82.of_tactic (unify_e_resolve poly st (term,cl)))
- (e_trivial_fail_db db_list local_db))
+ Tacticals.New.tclTHEN (unify_e_resolve poly st (term,cl))
+ (e_trivial_fail_db db_list local_db)
| Unfold_nth c -> Proofview.V82.tactic (reduce (Unfold [AllOccurrences,c]) onConcl)
| Extern tacast -> conclPattern concl p tacast
in
- let tac = Proofview.V82.of_tactic (run_hint t tac) in
+ let tac = run_hint t tac in
(tac, lazy (pr_hint t)))
in
List.map tac_of_hint hintl
@@ -228,7 +238,7 @@ module SearchProblem = struct
| [] -> []
| (tac, cost, pptac) :: tacl ->
try
- let lgls = apply_tac_list tac glls in
+ let lgls = apply_tac_list (Proofview.V82.of_tactic tac) glls in
(* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *)
(* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *)
(lgls, cost, pptac) :: aux tacl
@@ -266,7 +276,7 @@ module SearchProblem = struct
prev = ps}) l
in
let intro_tac =
- let l = filter_tactics s.tacres [Proofview.V82.of_tactic Tactics.intro, (-1), lazy (str "intro")] in
+ let l = filter_tactics s.tacres [Tactics.intro, (-1), lazy (str "intro")] in
List.map
(fun (lgls, cost, pp) ->
let g' = first_goal lgls in
@@ -557,7 +567,7 @@ let unfold_head env (ids, csts) c =
in aux c
let autounfold_one db cl =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
let concl = Proofview.Goal.concl gl in
let st =
@@ -576,7 +586,7 @@ let autounfold_one db cl =
| Some hyp -> change_in_hyp None (make_change_arg c') hyp
| None -> convert_concl_no_check c' DEFAULTcast
else Tacticals.New.tclFAIL 0 (str "Nothing to unfold")
- end
+ end }
(* Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts *)
(* (Id.Set.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *)
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
index 7073e8a2b..b55c70fa1 100644
--- a/tactics/eauto.mli
+++ b/tactics/eauto.mli
@@ -21,11 +21,11 @@ val wit_auto_using :
Genarg.genarg_type
-val e_assumption : tactic
+val e_assumption : unit Proofview.tactic
-val registered_e_assumption : tactic
+val registered_e_assumption : unit Proofview.tactic
-val e_give_exact : ?flags:Unification.unify_flags -> constr -> tactic
+val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic
val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> open_constr list ->
hint_db_name list option -> tactic
diff --git a/tactics/elim.ml b/tactics/elim.ml
index 4841d2c25..d3aa16092 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -84,7 +84,7 @@ let tmphyp_name = Id.of_string "_TmpHyp"
let up_to_delta = ref false (* true *)
let general_decompose recognizer c =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let type_of = pf_unsafe_type_of gl in
let typc = type_of c in
tclTHENS (cut typc)
@@ -93,11 +93,11 @@ let general_decompose recognizer c =
(ifOnHyp recognizer (general_decompose_aux recognizer)
(fun id -> Proofview.V82.tactic (clear [id]))));
Proofview.V82.tactic (exact_no_check c) ]
- end
+ end }
let head_in indl t gl =
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
try
let ity,_ =
if !up_to_delta
@@ -107,10 +107,10 @@ let head_in indl t gl =
with Not_found -> false
let decompose_these c l =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let indl = List.map (fun x -> x, Univ.Instance.empty) l in
general_decompose (fun (_,t) -> head_in indl t gl) c
- end
+ end }
let decompose_and c =
general_decompose
@@ -138,7 +138,7 @@ let induction_trailer abs_i abs_j bargs =
(tclDO (abs_j - abs_i) intro)
(onLastHypId
(fun id ->
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let idty = pf_unsafe_type_of gl (mkVar id) in
let fvty = global_vars (pf_env gl) idty in
let possible_bring_hyps =
@@ -156,11 +156,11 @@ let induction_trailer abs_i abs_j bargs =
(tclTHENLIST
[bring_hyps hyps; tclTRY (Proofview.V82.tactic (clear ids));
simple_elimination (mkVar id)])
- end
+ end }
))
let double_ind h1 h2 =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let abs_i = of_old (depth_of_quantified_hypothesis true h1) gl in
let abs_j = of_old (depth_of_quantified_hypothesis true h2) gl in
let abs =
@@ -173,7 +173,7 @@ let double_ind h1 h2 =
(fun id ->
elimination_then
(introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id))))
- end
+ end }
let h_double_induction = double_ind
diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml
index 4fb76bb82..74e5e036a 100644
--- a/tactics/eqdecide.ml
+++ b/tactics/eqdecide.ml
@@ -27,6 +27,7 @@ open Constr_matching
open Hipattern
open Tacmach.New
open Coqlib
+open Proofview.Notations
(* This file containts the implementation of the tactics ``Decide
Equality'' and ``Compare''. They can be used to decide the
@@ -146,7 +147,7 @@ let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with
intros_reflexivity;
]
| a1 :: largs, a2 :: rargs ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let rectype = pf_unsafe_type_of gl a1 in
let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in
let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in
@@ -154,13 +155,13 @@ let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with
if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto]
else [diseqCase hyps eqonleft;eqCase tac;default_auto] in
(tclTHENS (elim_type decide) subtacs)
- end
+ end }
| _ -> invalid_arg "List.fold_right2"
let solveEqBranch rectype =
Proofview.tclORELSE
begin
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let concl = pf_nf_concl gl in
match_eqdec concl >>= fun (eqonleft,op,lhs,rhs,_) ->
let (mib,mip) = Global.lookup_inductive rectype in
@@ -169,7 +170,7 @@ let solveEqBranch rectype =
let rargs = getargs rhs
and largs = getargs lhs in
solveArg [] eqonleft op largs rargs
- end
+ end }
end
begin function (e, info) -> match e with
| PatternMatchingFailure -> Tacticals.New.tclZEROMSG (Pp.str"Unexpected conclusion!")
@@ -185,7 +186,7 @@ let hd_app c = match kind_of_term c with
let decideGralEquality =
Proofview.tclORELSE
begin
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let concl = pf_nf_concl gl in
match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) ->
let headtyp = hd_app (pf_compute gl typ) in
@@ -196,7 +197,7 @@ let decideGralEquality =
(tclTHEN
(mkBranches c1 c2)
(tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype)))
- end
+ end }
end
begin function (e, info) -> match e with
| PatternMatchingFailure ->
@@ -207,20 +208,20 @@ let decideGralEquality =
let decideEqualityGoal = tclTHEN intros decideGralEquality
let decideEquality rectype =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let decide = mkGenDecideEqGoal rectype gl in
(tclTHENS (cut decide) [default_auto;decideEqualityGoal])
- end
+ end }
(* The tactic Compare *)
let compare c1 c2 =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let rectype = pf_unsafe_type_of gl c1 in
let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in
(tclTHENS (cut decide)
[(tclTHEN intro
(tclTHEN (onLastHyp simplest_case) clear_last));
decideEquality rectype])
- end
+ end }
diff --git a/tactics/equality.ml b/tactics/equality.ml
index 674c85af7..56878f112 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -40,6 +40,7 @@ open Eqschemes
open Locus
open Locusops
open Misctypes
+open Sigma.Notations
open Proofview.Notations
open Unification
@@ -158,7 +159,7 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl =
let try_occ (evd', c') =
Clenvtac.clenv_pose_dependent_evars true {eqclause with evd = evd'}
in
- let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_unif_flags eqclause 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)
@@ -206,10 +207,10 @@ let rewrite_conv_closed_unif_flags = {
}
let rewrite_elim with_evars frzevars cls c e =
- Proofview.Goal.enter begin fun gl ->
- let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_conv_closed_unif_flags c in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_conv_closed_unif_flags c in
general_elim_clause with_evars flags cls c e
- end
+ end }
(* Ad hoc asymmetric general_elim_clause *)
let general_elim_clause with_evars frzevars cls rew elim =
@@ -244,7 +245,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim =
(general_elim_clause with_evars frzevars cls c elim))
tac
in
- Proofview.Goal.enter begin fun gl ->
+ 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
@@ -256,7 +257,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim =
let cs = instantiate_lemma typ in
if firstonly then tclFIRST (List.map try_clause cs)
else tclMAP try_clause cs
- end
+ end }
(* The next function decides in particular whether to try a regular
rewrite or a generalized rewrite.
@@ -275,7 +276,7 @@ let jmeq_same_dom gl = function
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 (Proofview.Goal.sigma gl) dom1 dom2
+ | _, [dom1; _; dom2;_] -> is_conv env (Tacmach.New.project gl) dom1 dom2
| _ -> false
(* find_elim determines which elimination principle is necessary to
@@ -316,7 +317,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl =
Logic.eq or Jmeq just before *)
assert false
in
- let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in
+ let sigma, elim = Evd.fresh_global (Global.env ()) (Tacmach.New.project gl) (ConstRef c) in
sigma, elim, Safe_typing.empty_private_constants
else
let scheme_name = match dep, lft2rgt, inccl with
@@ -336,7 +337,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl =
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 =
- Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c)
+ Evd.fresh_global (Global.env ()) (Tacmach.New.project gl) (ConstRef c)
in
sigma, elim, eff
| _ -> assert false
@@ -346,17 +347,20 @@ let type_of_clause cls gl = match cls with
| 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_enter begin fun gl ->
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma ->
let isatomic = isProd (whd_zeta 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) = find_elim hdcncl lft2rgt dep cls (Some t) gl in
- Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS effs <*>
+ 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}
- end
+ in
+ Sigma.Unsafe.of_pair (tac, sigma)
+ end }
let adjust_rewriting_direction args lft2rgt =
match args with
@@ -379,8 +383,8 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac
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 begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ 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
@@ -407,7 +411,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac
| None -> Proofview.tclZERO ~info e
(* error "The provided term does not end with an equality or a declared rewrite relation." *)
end
- end
+ end }
let general_rewrite_ebindings =
general_rewrite_ebindings_clause None
@@ -469,9 +473,9 @@ let general_rewrite_clause l2r with_evars ?tac c cl =
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 begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
do_hyps_atleastonce (ids gl)
- end
+ end }
in
if cl.concl_occs == NoOccurrences then do_hyps else
tclIFTHENTRYELSEMUST
@@ -479,25 +483,25 @@ let general_rewrite_clause l2r with_evars ?tac c cl =
do_hyps
let apply_special_clear_request clear_flag f =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
try
- let sigma,(c,bl) = f env sigma in
+ 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
+ end }
let general_multi_rewrite with_evars l cl tac =
let do1 l2r f =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
- let sigma,c = f env sigma in
+ let (c, sigma) = run_delayed env sigma f in
tclWITHHOLES with_evars
(general_rewrite_clause l2r with_evars ?tac c cl) sigma
- end
+ end }
in
let rec doN l2r c = function
| Precisely n when n <= 0 -> Proofview.tclUNIT ()
@@ -560,14 +564,14 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt =
| None -> Proofview.tclUNIT ()
| Some tac -> tclCOMPLETE tac
in
- Proofview.Goal.enter begin fun gl ->
+ 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 (Proofview.Goal.sigma gl)
+ if unsafe then Some (Tacmach.New.project gl)
else
- try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Proofview.Goal.sigma gl))
+ try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Tacmach.New.project gl))
with Evarconv.UnableToUnify _ -> None
in
match evd with
@@ -586,7 +590,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt =
tclTHEN (apply sym) assumption;
try_prove_eq
])))
- end
+ end }
let replace c1 c2 =
replace_using_leibniz onConcl c2 c1 false false None
@@ -869,7 +873,7 @@ let rec build_discriminator env sigma dirn c sort = function
*)
let gen_absurdity id =
- Proofview.Goal.enter begin fun gl ->
+ 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
@@ -877,7 +881,7 @@ let gen_absurdity id =
simplest_elim (mkVar id)
else
tclZEROMSG (str "Not the negation of an equality.")
- end
+ end }
(* Precondition: eq is leibniz equality
@@ -933,7 +937,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort =
let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause =
let sigma = eq_clause.evd in
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
let concl = Proofview.Goal.concl gl in
match find_positions env sigma t1 t2 with
@@ -942,10 +946,10 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause =
| Inl (cpath, (_,dirn), _) ->
let sort = pf_apply get_type_of gl concl in
discr_positions env sigma u eq_clause cpath dirn sort
- end
+ end }
let onEquality with_evars tac (c,lbindc) =
- Proofview.Goal.nf_enter begin fun gl ->
+ 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
@@ -957,11 +961,11 @@ let onEquality with_evars tac (c,lbindc) =
tclTHEN
(Proofview.Unsafe.tclEVARS eq_clause'.evd)
(tac (eq,eqn,eq_args) eq_clause')
- end
+ end }
let onNegatedEquality with_evars tac =
- Proofview.Goal.nf_enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ 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
@@ -971,7 +975,7 @@ let onNegatedEquality with_evars tac =
onEquality with_evars tac (mkVar id,NoBindings)))
| _ ->
tclZEROMSG (str "Not a negated primitive equality.")
- end
+ end }
let discrSimpleClause with_evars = function
| None -> onNegatedEquality with_evars discrEq
@@ -1097,7 +1101,7 @@ let minimal_free_rels_rec env sigma =
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.create_goal_evar_defs sigma) 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 *)
@@ -1240,7 +1244,7 @@ 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 begin fun gl ->
+ 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 *)
@@ -1278,7 +1282,7 @@ let inject_if_homogenous_dependent_pair ty =
])]
with Exit ->
Proofview.tclUNIT ()
- end
+ 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
@@ -1370,7 +1374,7 @@ 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 begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let sort = pf_apply get_type_of gl (Proofview.Goal.concl gl) in
let sigma = clause.evd in
let env = Proofview.Goal.env gl in
@@ -1382,7 +1386,7 @@ let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause =
| Inr posns ->
inject_at_positions env sigma true u clause posns
(ntac (clenv_value clause))
- end
+ end }
let dEqThen with_evars ntac = function
| None -> onNegatedEquality with_evars (decompEqThen (ntac None))
@@ -1393,10 +1397,10 @@ let dEq with_evars =
(apply_clear_request clear_flag (use_clear_hyp_by_default ()) c))
let intro_decompe_eq tac data cl =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let cl = pf_apply make_clenv_binding gl cl NoBindings in
decompEqThen (fun _ -> tac) data cl
- end
+ end }
let _ = declare_intro_decomp_eq intro_decompe_eq
@@ -1479,22 +1483,24 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
(* on for further iterated sigma-tuples *)
let cutSubstInConcl l2r eqn =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma ->
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 = pf_apply subst_tuple_term gl e1 e2 typ in
+ let tac =
tclTHENFIRST
(tclTHENLIST [
- (Proofview.Unsafe.tclEVARS sigma);
(change_concl typ); (* Put in pattern form *)
(replace_core onConcl l2r eqn)
])
(change_concl expected) (* Put in normalized form *)
- end
+ in
+ Sigma.Unsafe.of_pair (tac, sigma)
+ end }
let cutSubstInHyp l2r eqn id =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
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
@@ -1506,7 +1512,7 @@ let cutSubstInHyp l2r eqn id =
(replace_core (onHyp id) l2r eqn)
])
(change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly))
- end
+ end }
let try_rewrite tac =
Proofview.tclORELSE tac begin function (e, info) -> match e with
@@ -1528,11 +1534,11 @@ 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 begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let eq = pf_apply get_type_of gl c in
tclTHENS (cutSubstClause l2r eq cls)
[Proofview.tclUNIT (); Proofview.V82.tactic (exact_no_check c)]
- end
+ end }
let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls)
let rewriteInHyp l2r c id = rewriteClause l2r c (Some id)
@@ -1558,7 +1564,7 @@ user = raise user error specific to rewrite
(* Substitutions tactics (JCF) *)
let unfold_body x =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
(** We normalize the given hypothesis immediately. *)
let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
let (_, xval, _) = Context.lookup_named x hyps in
@@ -1575,7 +1581,7 @@ let unfold_body x =
let reductc = Proofview.V82.tactic (fun gl -> reduct_in_concl (rfun, DEFAULTcast) gl) in
tclTHENLIST [tclMAP reducth hl; reductc]
end
- end
+ end }
let restrict_to_eq_and_identity eq = (* compatibility *)
if not (is_global glob_eq eq) &&
@@ -1598,7 +1604,7 @@ let is_eq_x gl x (id,_,c) =
erase hyp and x; proceed by generalizing all dep hyps *)
let subst_one dep_proof_ok x (hyp,rhs,dir) =
- Proofview.Goal.enter begin fun gl ->
+ 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
@@ -1624,13 +1630,13 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) =
else
[Proofview.tclUNIT ()]) @
[tclTRY (clear [x; hyp])])
- end
+ 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 begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let gl = Proofview.Goal.assume gl in
let (_,xval,_) = pf_get_hyp x gl in
(* If x has a body, simply replace x with body and clear x *)
@@ -1649,7 +1655,7 @@ let subst_one_var dep_proof_ok x =
str".")
with FoundHyp res -> res in
subst_one dep_proof_ok x res
- end
+ end }
let subst_gen dep_proof_ok ids =
tclTHEN Proofview.V82.nf_evar_goals (tclMAP (subst_one_var dep_proof_ok) ids)
@@ -1671,7 +1677,7 @@ let default_subst_tactic_flags () =
else
{ only_leibniz = true; rewrite_dependent_proof = false }
-let regular_subst_tactic = ref false
+let regular_subst_tactic = ref true
let _ =
declare_bool_option
@@ -1709,7 +1715,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () =
(* Second step: treat equations *)
let process hyp =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let gl = Proofview.Goal.assume gl in
let find_eq_data_decompose = find_eq_data_decompose gl in
let (_,_,c) = pf_get_hyp hyp gl in
@@ -1723,19 +1729,19 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () =
subst_one flags.rewrite_dependent_proof y' (hyp,x,false)
| _ ->
Proofview.tclUNIT ()
- end
+ end }
in
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let ids = find_equations gl in
tclMAP process ids
- end
+ 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 begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let find_eq_data_decompose = find_eq_data_decompose gl in
let test (_,c) =
try
@@ -1752,7 +1758,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () =
let ids = List.map_filter test hyps in
let ids = List.uniquize ids in
subst_gen flags.rewrite_dependent_proof ids
- end
+ end }
(* Rewrite the first assumption for which a condition holds
and gives the direction of the rewrite *)
@@ -1788,10 +1794,11 @@ let rewrite_assumption_cond cond_eq_term cl =
with | Failure _ | UserError _ -> arec rest gl
end
in
- Proofview.Goal.nf_enter begin fun gl ->
+ 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
+ end }
(* Generalize "subst x" to substitution of subterm appearing as an
equation in the context, but not clearing the hypothesis *)
diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml
index c3fe6b657..c9fc01088 100644
--- a/tactics/evar_tactics.ml
+++ b/tactics/evar_tactics.ml
@@ -14,6 +14,8 @@ open Tacexpr
open Refiner
open Evd
open Locus
+open Sigma.Notations
+open Proofview.Notations
(* The instantiate tactic *)
@@ -68,15 +70,17 @@ let instantiate_tac_by_name id c =
let let_evar name typ =
let src = (Loc.ghost,Evar_kinds.GoalEvar) in
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
let env = Proofview.Goal.env gl in
let id = match name with
| Names.Anonymous ->
let id = Namegen.id_of_name_using_hdchar env typ name in
Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env))
- | Names.Name id -> id in
- let sigma',evar = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in
- Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS sigma'))
+ | Names.Name id -> id
+ in
+ let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in
+ let tac =
(Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere)
- end
+ in
+ Sigma (tac, sigma, p)
+ end }
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index cab74968d..e1997c705 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -21,6 +21,8 @@ open Util
open Evd
open Equality
open Misctypes
+open Sigma.Notations
+open Proofview.Notations
DECLARE PLUGIN "extratactics"
@@ -268,7 +270,7 @@ let add_rewrite_hint bases ort t lcsr =
let f ce =
let c, ctx = Constrintern.interp_constr env sigma ce in
let ctx =
- let ctx = Evd.evar_universe_context_set Univ.UContext.empty ctx in
+ let ctx = UState.context_set ctx in
if poly then ctx
else (Global.push_context_set false ctx; Univ.ContextSet.empty)
in
@@ -345,7 +347,7 @@ END
(* Refine *)
let refine_tac {Glob_term.closure=closure;term=term} =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let env = Proofview.Goal.env gl in
let flags = Pretyping.all_no_fail_flags in
@@ -355,9 +357,13 @@ let refine_tac {Glob_term.closure=closure;term=term} =
Pretyping.ltac_uconstrs = closure.Glob_term.untyped;
Pretyping.ltac_idents = closure.Glob_term.idents;
} in
- let update evd = Pretyping.understand_ltac flags env evd lvar tycon term in
+ let update = { run = begin fun sigma ->
+ let sigma = Sigma.to_evar_map sigma in
+ let (sigma, c) = Pretyping.understand_ltac flags env sigma lvar tycon term in
+ Sigma.Unsafe.of_pair (c, sigma)
+ end } in
Tactics.New.refine ~unsafe:false update
- end
+ end }
TACTIC EXTEND refine
[ "refine" uconstr(c) ] -> [ refine_tac c ]
@@ -612,8 +618,8 @@ let out_arg = function
| ArgArg x -> x
let hResolve id c occ t =
- Proofview.Goal.nf_enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma ->
+ let sigma = Sigma.to_evar_map sigma in
let env = Termops.clear_named_body id (Proofview.Goal.env gl) in
let concl = Proofview.Goal.concl gl in
let env_ids = Termops.ids_of_context env in
@@ -631,10 +637,11 @@ let hResolve id c occ t =
let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in
let sigma = Evd.merge_universe_context sigma ctx in
let t_constr_type = Retyping.get_type_of env sigma t_constr in
- Tacticals.New.tclTHEN
- (Proofview.Unsafe.tclEVARS sigma)
+ let tac =
(change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl)))
- end
+ in
+ Sigma.Unsafe.of_pair (tac, sigma)
+ end }
let hResolve_auto id c t =
let rec resolve_auto n =
@@ -656,8 +663,8 @@ END
*)
let hget_evar n =
- Proofview.Goal.nf_enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let concl = Proofview.Goal.concl gl in
let evl = evar_list concl in
if List.length evl < n then
@@ -666,7 +673,7 @@ let hget_evar n =
let ev = List.nth evl (n-1) in
let ev_type = existential_type sigma ev in
change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl))
- end
+ end }
TACTIC EXTEND hget_evar
| [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ]
@@ -685,12 +692,12 @@ END
exception Found of unit Proofview.tactic
let rewrite_except h =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let hyps = Tacmach.New.pf_ids_of_hyps gl in
Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else
Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false))
hyps
- end
+ end }
let refl_equal =
@@ -704,27 +711,27 @@ let refl_equal =
should be replaced by a call to the tactic but I don't know how to
call it before it is defined. *)
let mkCaseEq a : unit Proofview.tactic =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g a) gl in
Tacticals.New.tclTHENLIST
[Proofview.V82.tactic (Tactics.Simple.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]);
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let env = Proofview.Goal.env gl in
change_concl
(snd (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl))
- end;
+ end };
simplest_case a]
- end
+ end }
let case_eq_intros_rewrite x =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let n = nb_prod (Proofview.Goal.concl gl) in
(* Pp.msgnl (Printer.pr_lconstr x); *)
Tacticals.New.tclTHENLIST [
mkCaseEq x;
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let hyps = Tacmach.New.pf_ids_of_hyps gl in
let n' = nb_prod concl in
@@ -733,9 +740,9 @@ let case_eq_intros_rewrite x =
Tacticals.New.tclDO (n'-n-1) intro;
introduction h;
rewrite_except h]
- end
+ end }
]
- end
+ end }
let rec find_a_destructable_match t =
match kind_of_term t with
@@ -755,15 +762,15 @@ let destauto t =
with Found tac -> tac
let destauto_in id =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g (mkVar id)) gl in
(* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *)
(* Pp.msgnl (Printer.pr_lconstr (ctype)); *)
destauto ctype
- end
+ end }
TACTIC EXTEND destauto
-| [ "destauto" ] -> [ Proofview.Goal.nf_enter (fun gl -> destauto (Proofview.Goal.concl gl)) ]
+| [ "destauto" ] -> [ Proofview.Goal.nf_enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ]
| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ]
END
@@ -771,10 +778,11 @@ END
(* ********************************************************************* *)
let eq_constr x y =
- Proofview.Goal.enter (fun gl ->
- let evd = Proofview.Goal.sigma gl in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let evd = Tacmach.New.project gl in
if Evarutil.eq_constr_univs_test evd evd x y then Proofview.tclUNIT ()
- else Tacticals.New.tclFAIL 0 (str "Not equal"))
+ else Tacticals.New.tclFAIL 0 (str "Not equal")
+ end }
TACTIC EXTEND constr_eq
| [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ]
@@ -975,14 +983,14 @@ TACTIC EXTEND guard
END
let decompose l c =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let to_ind c =
if isInd c then Univ.out_punivs (destInd c)
else error "not an inductive type"
in
let l = List.map to_ind l in
Elim.h_decompose l c
- end
+ end }
TACTIC EXTEND decompose
| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ]
diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli
index 483515674..449649922 100644
--- a/tactics/ftactic.mli
+++ b/tactics/ftactic.mli
@@ -37,12 +37,14 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic
(** {5 Focussing} *)
-val nf_enter : ([ `NF ] Proofview.Goal.t -> 'a t) -> 'a t
+val nf_enter : (([ `NF ], 'r) Proofview.Goal.t -> 'a t) -> 'a t
(** Enter a goal. The resulting tactic is focussed. *)
+(** FIXME: Should be polymorphic over the stage. *)
-val enter : ([ `LZ ] Proofview.Goal.t -> 'a t) -> 'a t
+val enter : (([ `LZ ], 'r) Proofview.Goal.t -> 'a t) -> 'a t
(** Enter a goal, without evar normalization. The resulting tactic is
focussed. *)
+(** FIXME: Should be polymorphic over the stage. *)
val with_env : 'a t -> (Environ.env*'a) t
(** [with_env t] returns, in addition to the return type of [t], an
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index 27d25056e..281e6b9bb 100644
--- a/tactics/hipattern.mli
+++ b/tactics/hipattern.mli
@@ -119,11 +119,11 @@ val match_with_equation:
(** Match terms [eq A t u], [identity A t u] or [JMeq A t A u]
Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *)
-val find_eq_data_decompose : [ `NF ] Proofview.Goal.t -> constr ->
+val find_eq_data_decompose : ([ `NF ], 'r) Proofview.Goal.t -> constr ->
coq_eq_data * Univ.universe_instance * (types * constr * constr)
(** Idem but fails with an error message instead of PatternMatchingFailure *)
-val find_this_eq_data_decompose : [ `NF ] Proofview.Goal.t -> constr ->
+val find_this_eq_data_decompose : ([ `NF ], 'r) Proofview.Goal.t -> constr ->
coq_eq_data * Univ.universe_instance * (types * constr * constr)
(** A variant that returns more informative structure on the equality found *)
@@ -144,7 +144,7 @@ val is_matching_sigma : constr -> bool
val match_eqdec : constr -> bool * constr * constr * constr * constr
(** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *)
-val dest_nf_eq : [ `NF ] Proofview.Goal.t -> constr -> (constr * constr * constr)
+val dest_nf_eq : ([ `NF ], 'r) Proofview.Goal.t -> constr -> (constr * constr * constr)
(** Match a negation *)
val is_matching_not : constr -> bool
diff --git a/tactics/inv.ml b/tactics/inv.ml
index ef115aea0..a9fa52e92 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -27,6 +27,7 @@ open Elim
open Equality
open Misctypes
open Tacexpr
+open Sigma.Notations
open Proofview.Notations
let clear hyps = Proofview.V82.tactic (clear hyps)
@@ -269,14 +270,14 @@ Nota: with Inversion_clear, only four useless hypotheses
let generalizeRewriteIntros as_mode tac depids id =
Proofview.tclENV >>= fun env ->
- Proofview.Goal.nf_enter begin fun gl ->
+ 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
+ end }
let error_too_many_names pats =
let loc = Loc.join_loc (fst (List.hd pats)) (fst (List.last pats)) in
@@ -284,10 +285,10 @@ let error_too_many_names pats =
tclZEROMSG ~loc (
str "Unexpected " ++
str (String.plural (List.length pats) "introduction pattern") ++
- str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (snd (c env Evd.empty)))) pats ++
+ str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (fst (run_delayed env Evd.empty c)))) pats ++
str ".")
-let rec get_names (allow_conj,issimple) (loc,pat as x) = match pat with
+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 _) ->
@@ -338,7 +339,7 @@ let projectAndApply as_mode thin avoid id eqname names depids =
(if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC))
in
let substHypIfVariable tac id =
- Proofview.Goal.nf_enter begin fun gl ->
+ 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
@@ -346,7 +347,7 @@ let projectAndApply as_mode thin avoid id eqname names depids =
| 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
+ end }
in
let deq_trailer id clear_flag _ neqns =
assert (clear_flag == None);
@@ -373,7 +374,7 @@ let projectAndApply as_mode thin avoid id eqname names depids =
id
let nLastDecls i tac =
- Proofview.Goal.nf_enter (fun gl -> tac (nLastDecls gl i))
+ 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
@@ -381,7 +382,7 @@ let nLastDecls i tac =
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 begin fun gl ->
+ 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 pi1 nodepids else [] in
@@ -414,7 +415,7 @@ let rewrite_equations as_mode othin neqns names ba =
[tclDO neqns intro;
bring_hyps nodepids;
clear (ids_of_named_context nodepids)])
- end
+ end }
let interp_inversion_kind = function
| SimpleInversion -> None
@@ -431,8 +432,8 @@ let rewrite_equations_tac as_mode othin id neqns names ba =
tac
let raw_inversion inv_kind id status names =
- Proofview.Goal.nf_enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma ->
+ 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
@@ -457,11 +458,11 @@ let raw_inversion inv_kind id status names =
in
let refined id =
let prf = mkApp (mkVar id, args) in
- Proofview.Refine.refine (fun h -> h, prf)
+ Proofview.Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) }
in
let neqns = List.length realargs in
let as_mode = names != None in
- tclTHEN (Proofview.Unsafe.tclEVARS sigma)
+ let tac =
(tclTHENS
(assert_before Anonymous cut_concl)
[case_tac names
@@ -469,7 +470,9 @@ let raw_inversion inv_kind id status names =
(rewrite_equations_tac as_mode inv_kind id neqns))
(Some elim_predicate) ind (c, t);
onLastHypId (fun id -> tclTHEN (refined id) reflexivity)])
- end
+ 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
@@ -511,12 +514,12 @@ let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id)
* back to their places in the hyp-list. *)
let invIn k names ids id =
- Proofview.Goal.nf_enter begin fun gl ->
+ 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 begin fun gl ->
+ 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)
@@ -525,7 +528,7 @@ let invIn k names ids id =
intros_replacing ids
else
tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)
- end
+ end }
in
Proofview.tclORELSE
(tclTHENLIST
@@ -533,7 +536,7 @@ let invIn k names ids id =
inversion k NoDep names id;
intros_replace_ids])
(wrap_inv_error id)
- end
+ end }
let invIn_gen k names idl = try_intros_until (invIn k names idl)
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index 8ca622171..75e69bc09 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -27,6 +27,7 @@ open Declare
open Tacticals.New
open Tactics
open Decl_kinds
+open Proofview.Notations
let no_inductive_inconstr env sigma constr =
(str "Cannot recognize an inductive predicate in " ++
@@ -269,7 +270,7 @@ let lemInv id c gls =
let lemInv_gen id c = try_intros_until (fun id -> Proofview.V82.tactic (lemInv id c)) id
let lemInvIn id c ids =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let hyps = List.map (fun id -> pf_get_hyp id gl) ids in
let intros_replace_ids =
let concl = Proofview.Goal.concl gl in
@@ -281,7 +282,7 @@ let lemInvIn id c ids =
in
((tclTHEN (tclTHEN (bring_hyps hyps) (Proofview.V82.tactic (lemInv id c)))
(intros_replace_ids)))
- end
+ end }
let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id
diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml
index e8a7c0f60..d1b14e3d9 100644
--- a/tactics/rewrite.ml
+++ b/tactics/rewrite.ml
@@ -34,6 +34,8 @@ open Elimschemes
open Environ
open Termops
open Libnames
+open Sigma.Notations
+open Proofview.Notations
(** Typeclass-based generalized rewriting. *)
@@ -84,7 +86,9 @@ let cstrevars evars = snd evars
let new_cstr_evar (evd,cstrs) env t =
let s = Typeclasses.set_resolvable Evd.Store.empty false in
- let evd', t = Evarutil.new_evar ~store:s env evd t in
+ let evd = Sigma.Unsafe.of_evar_map evd in
+ let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in
+ let evd' = Sigma.to_evar_map evd' in
let ev, _ = destEvar t in
(evd', Evar.Set.add ev cstrs), t
@@ -1498,7 +1502,7 @@ let rec insert_dependent env decl accu hyps = match hyps with
insert_dependent env decl (ndecl :: accu) rem
let assert_replacing id newt tac =
- let prf = Proofview.Goal.nf_enter begin fun gl ->
+ let prf = Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let env = Proofview.Goal.env gl in
let ctx = Environ.named_context env in
@@ -1508,14 +1512,14 @@ let assert_replacing id newt tac =
| (id, b, _) :: rem -> insert_dependent env (id, b, newt) [] after @ rem
in
let env' = Environ.reset_with_named_context (val_of_named_context nc) env in
- Proofview.Refine.refine ~unsafe:false begin fun sigma ->
- let sigma, ev = Evarutil.new_evar env' sigma concl in
- let sigma, ev' = Evarutil.new_evar env sigma newt in
+ Proofview.Refine.refine ~unsafe:false { run = begin fun sigma ->
+ let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in
+ let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in
let map (n, _, _) = if Id.equal n id then ev' else mkVar n in
let (e, _) = destEvar ev in
- sigma, mkEvar (e, Array.map_of_list map nc)
- end
- end in
+ Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q)
+ end }
+ end } in
Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac)
let newfail n s =
@@ -1533,7 +1537,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause =
let gls = List.rev (Evd.fold_undefined fold undef []) in
match clause, prf with
| Some id, Some p ->
- let tac = Proofview.Refine.refine ~unsafe:false (fun h -> (h, p)) <*> Proofview.Unsafe.tclNEWGOALS gls in
+ let tac = Proofview.Refine.refine ~unsafe:false { run = fun h -> Sigma (p, h, Sigma.refl) } <*> Proofview.Unsafe.tclNEWGOALS gls in
Proofview.Unsafe.tclEVARS undef <*>
assert_replacing id newt tac
| Some id, None ->
@@ -1541,14 +1545,14 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause =
convert_hyp_no_check (id, None, newt)
| None, Some p ->
Proofview.Unsafe.tclEVARS undef <*>
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let make sigma =
- let (sigma, ev) = Evarutil.new_evar env sigma newt in
- sigma, mkApp (p, [| ev |])
- in
+ let make = { run = begin fun sigma ->
+ let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in
+ Sigma (mkApp (p, [| ev |]), sigma, q)
+ end } in
Proofview.Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls
- end
+ end }
| None, None ->
Proofview.Unsafe.tclEVARS undef <*>
convert_concl_no_check newt DEFAULTcast
@@ -1559,10 +1563,10 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause =
| None -> Proofview.tclUNIT ()
| Some id -> Proofview.V82.tactic (Tactics.reduct_in_hyp beta_red (id, InHyp))
in
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let ty = match clause with
| None -> concl
| Some id -> Environ.named_type id env
@@ -1587,7 +1591,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause =
with
| PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) ->
raise (RewriteFailure (Himsg.explain_pretype_error env evd e))
- end
+ end }
let tactic_init_setoid () =
try init_setoid (); tclIDTAC
@@ -2034,9 +2038,9 @@ let not_declared env ty rel =
str ty ++ str" relation. Maybe you need to require the Setoid library")
let setoid_proof ty fn fallback =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let concl = Proofview.Goal.concl gl in
Proofview.tclORELSE
begin
@@ -2063,7 +2067,7 @@ let setoid_proof ty fn fallback =
| e' -> Proofview.tclZERO ~info e'
end
end
- end
+ end }
let tac_open ((evm,_), c) tac =
Proofview.V82.tactic
diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml
index 09a98bc8c..c1e4d72e3 100644
--- a/tactics/tacenv.ml
+++ b/tactics/tacenv.ml
@@ -49,7 +49,7 @@ let pr_tacname t =
let tac_tab = ref MLTacMap.empty
-let register_ml_tactic ?(overwrite = false) s (t : ml_tactic) =
+let register_ml_tactic ?(overwrite = false) s (t : ml_tactic array) =
let () =
if MLTacMap.mem s !tac_tab then
if overwrite then
@@ -60,9 +60,11 @@ let register_ml_tactic ?(overwrite = false) s (t : ml_tactic) =
in
tac_tab := MLTacMap.add s t !tac_tab
-let interp_ml_tactic s =
+let interp_ml_tactic { mltac_name = s; mltac_index = i } =
try
- MLTacMap.find s !tac_tab
+ let tacs = MLTacMap.find s !tac_tab in
+ let () = if Array.length tacs <= i then raise Not_found in
+ tacs.(i)
with Not_found ->
Errors.errorlabstrm ""
(str "The tactic " ++ pr_tacname s ++ str " is not installed.")
diff --git a/tactics/tacenv.mli b/tactics/tacenv.mli
index 2df6bb04a..47d9efda5 100644
--- a/tactics/tacenv.mli
+++ b/tactics/tacenv.mli
@@ -64,8 +64,8 @@ type ml_tactic =
typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic
(** Type of external tactics, used by [TacML]. *)
-val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic -> unit
+val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit
(** Register an external tactic. *)
-val interp_ml_tactic : ml_tactic_name -> ml_tactic
+val interp_ml_tactic : ml_tactic_entry -> ml_tactic
(** Get the named tactic. Raises a user error if it does not exist. *)
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index 6c125ed2d..1673aac0a 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -40,6 +40,7 @@ open Misctypes
open Locus
open Tacintern
open Taccoerce
+open Sigma.Notations
open Proofview.Notations
let safe_msgnl s =
@@ -633,10 +634,10 @@ let pf_interp_constr ist gl =
let new_interp_constr ist c k =
let open Proofview in
- Proofview.Goal.enter begin fun gl ->
- let (sigma, c) = interp_constr ist (Goal.env gl) (Goal.sigma gl) c in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let (sigma, c) = interp_constr ist (Goal.env gl) (Tacmach.New.project gl) c in
Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k c)
- end
+ end }
let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l =
let try_expand_ltac_var sigma x =
@@ -791,11 +792,11 @@ let rec message_of_value v =
Ftactic.return (str "<tactic>")
else if has_type v (topwit wit_constr) then
let v = out_gen (topwit wit_constr) v in
- Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Proofview.Goal.sigma gl) v) end
+ Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) v) end
else if has_type v (topwit wit_constr_under_binders) then
let c = out_gen (topwit wit_constr_under_binders) v in
Ftactic.nf_enter begin fun gl ->
- Ftactic.return (pr_constr_under_binders_env (pf_env gl) (Proofview.Goal.sigma gl) c)
+ Ftactic.return (pr_constr_under_binders_env (pf_env gl) (Tacmach.New.project gl) c)
end
else if has_type v (topwit wit_unit) then
Ftactic.return (str "()")
@@ -803,18 +804,18 @@ let rec message_of_value v =
Ftactic.return (int (out_gen (topwit wit_int) v))
else if has_type v (topwit wit_intro_pattern) then
let p = out_gen (topwit wit_intro_pattern) v in
- let print env sigma c = pr_constr_env env sigma (snd (c env Evd.empty)) in
+ let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in
Ftactic.nf_enter begin fun gl ->
- Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (Proofview.Goal.sigma gl) c) p)
+ Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (Tacmach.New.project gl) c) p)
end
else if has_type v (topwit wit_constr_context) then
let c = out_gen (topwit wit_constr_context) v in
- Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Proofview.Goal.sigma gl) c) end
+ Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) c) end
else if has_type v (topwit wit_uconstr) then
let c = out_gen (topwit wit_uconstr) v in
Ftactic.nf_enter begin fun gl ->
Ftactic.return (pr_closed_glob_env (pf_env gl)
- (Proofview.Goal.sigma gl) c)
+ (Tacmach.New.project gl) c)
end
else match Value.to_list v with
| Some l ->
@@ -866,7 +867,11 @@ and interp_intro_pattern_action ist env sigma = function
let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in
sigma, IntroInjection l
| IntroApplyOn (c,ipat) ->
- let c = fun env sigma -> interp_constr ist env sigma c in
+ let c = { delayed = fun env sigma ->
+ let sigma = Sigma.to_evar_map sigma in
+ let (sigma, c) = interp_constr ist env sigma c in
+ Sigma.Unsafe.of_pair (c, sigma)
+ } in
let sigma,ipat = interp_intro_pattern ist env sigma ipat in
sigma, IntroApplyOn (c,ipat)
| IntroWildcard | IntroRewrite _ as x -> sigma, x
@@ -969,13 +974,21 @@ let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) =
let loc1 = loc_of_glob_constr c in
let loc2 = loc_of_bindings bl in
let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in
- let f env sigma = interp_open_constr_with_bindings ist env sigma cb in
+ let f = { delayed = fun env sigma ->
+ let sigma = Sigma.to_evar_map sigma in
+ let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in
+ Sigma.Unsafe.of_pair (c, sigma)
+ } in
(loc,f)
let interp_induction_arg ist gl arg =
match arg with
| keep,ElimOnConstr c ->
- keep,ElimOnConstr (fun env sigma -> interp_constr_with_bindings ist env sigma c)
+ keep,ElimOnConstr { delayed = fun env sigma ->
+ let sigma = Sigma.to_evar_map sigma in
+ let (sigma, c) = interp_constr_with_bindings ist env sigma c in
+ Sigma.Unsafe.of_pair (c, sigma)
+ }
| keep,ElimOnAnonHyp n as x -> x
| keep,ElimOnIdent (loc,id) ->
let error () = user_err_loc (loc, "",
@@ -986,7 +999,7 @@ let interp_induction_arg ist gl arg =
if Tactics.is_quantified_hypothesis id' gl
then keep,ElimOnIdent (loc,id')
else
- (try keep,ElimOnConstr (fun env sigma -> sigma,(constr_of_id env id',NoBindings))
+ (try keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((constr_of_id env id',NoBindings), sigma, Sigma.refl) }
with Not_found ->
user_err_loc (loc,"",
pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis."))
@@ -1007,16 +1020,18 @@ let interp_induction_arg ist gl arg =
keep,ElimOnAnonHyp (out_gen (topwit wit_int) v)
else match Value.to_constr v with
| None -> error ()
- | Some c -> keep,ElimOnConstr (fun env sigma -> sigma,(c,NoBindings))
+ | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) }
with Not_found ->
(* We were in non strict (interactive) mode *)
if Tactics.is_quantified_hypothesis id gl then
keep,ElimOnIdent (loc,id)
else
let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in
- let f env sigma =
+ let f = { delayed = fun env sigma ->
+ let sigma = Sigma.to_evar_map sigma in
let (sigma,c) = interp_open_constr ist env sigma c in
- sigma,(c,NoBindings) in
+ Sigma.Unsafe.of_pair ((c,NoBindings), sigma)
+ } in
keep,ElimOnConstr f
(* Associates variables with values and gives the remaining variables and
@@ -1159,9 +1174,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac))
end
| TacAbstract (tac,ido) ->
- Proofview.Goal.nf_enter begin fun gl -> Tactics.tclABSTRACT
+ Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT
(Option.map (Tacmach.New.of_old (pf_interp_ident ist) gl) ido) (interp_tactic ist tac)
- end
+ end }
| TacThen (t1,t) ->
Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t)
| TacDispatch tl ->
@@ -1211,7 +1226,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
| BindingsArgType
| OptArgType _ | PairArgType _ -> (** generic handler *)
Ftactic.nf_enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
let concl = Proofview.Goal.concl gl in
let goal = Proofview.Goal.goal gl in
@@ -1220,7 +1235,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
end
| _ as tag -> (** Special treatment. TODO: use generic handler *)
Ftactic.nf_enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
match tag with
| IntOrVarArgType ->
@@ -1337,9 +1352,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
| TacML (loc,opn,l) ->
let trace = push_trace (loc,LtacMLCall tac) ist in
let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let goal_sigma = Proofview.Goal.sigma gl in
+ let goal_sigma = Tacmach.New.project gl in
let concl = Proofview.Goal.concl gl in
let goal = Proofview.Goal.goal gl in
let tac = Tacenv.interp_ml_tactic opn in
@@ -1351,7 +1366,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with
let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in
Proofview.Trace.name_tactic name
(catch_error_tac trace (tac args ist))
- end
+ end }
and force_vrec ist v : typed_generic_argument Ftactic.t =
let v = Value.normalize v in
@@ -1386,7 +1401,7 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t =
match arg with
| TacGeneric arg ->
Ftactic.nf_enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let goal = Proofview.Goal.goal gl in
let (sigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} arg in
Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v)
@@ -1394,7 +1409,7 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t =
| Reference r -> interp_ltac_reference dloc false ist r
| ConstrMayEval c ->
Ftactic.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in
Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp))
@@ -1414,12 +1429,12 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t =
interp_app loc ist fv largs
| TacFreshId l ->
Ftactic.enter begin fun gl ->
- let id = interp_fresh_id ist (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) l in
+ let id = interp_fresh_id ist (Tacmach.New.pf_env gl) (Tacmach.New.project gl) l in
Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id)))
end
| TacPretype c ->
Ftactic.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
let {closure;term} = interp_uconstr ist env c in
let vars = {
@@ -1598,7 +1613,7 @@ and interp_match ist lz constr lmr =
end
end >>= fun constr ->
Ftactic.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in
interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr)
@@ -1607,7 +1622,7 @@ and interp_match ist lz constr lmr =
(* Interprets the Match Context expressions *)
and interp_match_goal ist lz lr lmr =
Ftactic.nf_enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
let hyps = Proofview.Goal.hyps gl in
let hyps = if lr then List.rev hyps else hyps in
@@ -1754,7 +1769,7 @@ and interp_ltac_constr ist e : constr Ftactic.t =
end >>= fun result ->
Ftactic.enter begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let result = Value.normalize result in
try
let cresult = coerce_to_closed_constr env result in
@@ -1790,9 +1805,9 @@ and interp_atomic ist tac : unit Proofview.tactic =
match tac with
(* Basic tactics *)
| TacIntroPattern l ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in
Tacticals.New.tclWITHHOLES false
(name_atomic ~env
@@ -1800,17 +1815,17 @@ and interp_atomic ist tac : unit Proofview.tactic =
(* spiwack: print uninterpreted, not sure if it is the
expected behaviour. *)
(Tactics.intros_patterns l')) sigma
- end
+ end }
| TacIntroMove (ido,hto) ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let mloc = interp_move_location ist env sigma hto in
let ido = Option.map (interp_ident ist env sigma) ido in
name_atomic ~env
(TacIntroMove(ido,mloc))
(Tactics.intro_move ido mloc)
- end
+ end }
| TacExact c ->
(* spiwack: until the tactic is in the monad *)
Proofview.Trace.name_tactic (fun () -> Pp.str"<exact>") begin
@@ -1825,9 +1840,9 @@ and interp_atomic ist tac : unit Proofview.tactic =
| TacApply (a,ev,cb,cl) ->
(* spiwack: until the tactic is in the monad *)
Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let l = List.map (fun (k,c) ->
let loc, f = interp_open_constr_with_bindings_loc ist c in
(k,(loc,f))) cb
@@ -1838,12 +1853,12 @@ and interp_atomic ist tac : unit Proofview.tactic =
let sigma,(clear,id,cl) = interp_in_hyp_as ist env sigma cl in
sigma, Tactics.apply_delayed_in a ev clear id l cl in
Tacticals.New.tclWITHHOLES ev tac sigma
- end
+ end }
end
| TacElim (ev,(keep,cb),cbo) ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let sigma, cb = interp_constr_with_bindings ist env sigma cb in
let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
let named_tac =
@@ -1851,10 +1866,10 @@ and interp_atomic ist tac : unit Proofview.tactic =
name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac
in
Tacticals.New.tclWITHHOLES ev named_tac sigma
- end
+ end }
| TacCase (ev,(keep,cb)) ->
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
let sigma, cb = interp_constr_with_bindings ist env sigma cb in
let named_tac =
@@ -1862,16 +1877,16 @@ and interp_atomic ist tac : unit Proofview.tactic =
name_atomic ~env (TacCase(ev,(keep,cb))) tac
in
Tacticals.New.tclWITHHOLES ev named_tac sigma
- end
+ end }
| TacFix (idopt,n) ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let idopt = Option.map (interp_ident ist env sigma) idopt in
name_atomic ~env
(TacFix(idopt,n))
(Proofview.V82.tactic (Tactics.fix idopt n))
- end
+ end }
| TacMutualFix (id,n,l) ->
(* spiwack: until the tactic is in the monad *)
Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin
@@ -1890,14 +1905,14 @@ and interp_atomic ist tac : unit Proofview.tactic =
end
end
| TacCofix idopt ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let idopt = Option.map (interp_ident ist env sigma) idopt in
name_atomic ~env
(TacCofix (idopt))
(Proofview.V82.tactic (Tactics.cofix idopt))
- end
+ end }
| TacMutualCofix (id,l) ->
(* spiwack: until the tactic is in the monad *)
Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin
@@ -1916,9 +1931,9 @@ and interp_atomic ist tac : unit Proofview.tactic =
end
end
| TacAssert (b,t,ipat,c) ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let (sigma,c) =
(if Option.is_empty t then interp_constr else interp_type) ist env sigma c
in
@@ -1928,17 +1943,17 @@ and interp_atomic ist tac : unit Proofview.tactic =
(name_atomic ~env
(TacAssert(b,t,ipat,c))
(Tactics.forward b tac ipat' c)) sigma
- end
+ end }
| TacGeneralize cl ->
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in
Tacticals.New.tclWITHHOLES false
(name_atomic ~env
(TacGeneralize cl)
(Proofview.V82.tactic (Tactics.Simple.generalize_gen cl))) sigma
- end
+ end }
| TacGeneralizeDep c ->
(new_interp_constr ist c) (fun c ->
name_atomic (* spiwack: probably needs a goal environment *)
@@ -1947,9 +1962,9 @@ and interp_atomic ist tac : unit Proofview.tactic =
)
| TacLetTac (na,c,clp,b,eqpat) ->
Proofview.V82.nf_evar_goals <*>
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let clp = interp_clause ist env sigma clp in
let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in
if Locusops.is_nowhere clp then
@@ -1980,7 +1995,7 @@ and interp_atomic ist tac : unit Proofview.tactic =
(Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*)
(let_pat_tac b (interp_name ist env sigma na)
((sigma,sigma'),c) clp eqpat) sigma')
- end
+ end }
(* Automation tactics *)
| TacTrivial (debug,lems,l) ->
@@ -1990,16 +2005,16 @@ and interp_atomic ist tac : unit Proofview.tactic =
++strbrk"does not print traces anymore." ++ spc()
++strbrk"Use \"Info 1 trivial\", instead.")
end;
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let lems = interp_auto_lemmas ist env sigma lems in
name_atomic ~env
(TacTrivial(debug,List.map snd lems,l))
(Auto.h_trivial ~debug
lems
(Option.map (List.map (interp_hint_base ist)) l))
- end
+ end }
| TacAuto (debug,n,lems,l) ->
begin if debug == Tacexpr.Info then
msg_warning
@@ -2007,25 +2022,25 @@ and interp_atomic ist tac : unit Proofview.tactic =
++strbrk"does not print traces anymore." ++ spc()
++strbrk"Use \"Info 1 auto\", instead.")
end;
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let lems = interp_auto_lemmas ist env sigma lems in
name_atomic ~env
(TacAuto(debug,n,List.map snd lems,l))
(Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n)
lems
(Option.map (List.map (interp_hint_base ist)) l))
- end
+ end }
(* Derived basic tactics *)
| TacInductionDestruct (isrec,ev,(l,el)) ->
(* spiwack: some unknown part of destruct needs the goal to be
prenormalised. *)
Proofview.V82.nf_evar_goals <*>
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let sigma,l =
List.fold_map begin fun sigma (c,(ipato,ipats),cls) ->
(* TODO: move sigma as a side-effect *)
@@ -2047,7 +2062,7 @@ and interp_atomic ist tac : unit Proofview.tactic =
(Tacticals.New.tclTHEN
(Proofview.Unsafe.tclEVARS sigma)
(Tactics.induction_destruct isrec ev (l,el)))
- end
+ end }
| TacDoubleInduction (h1,h2) ->
let h1 = interp_quantified_hypothesis ist h1 in
let h2 = interp_quantified_hypothesis ist h2 in
@@ -2056,25 +2071,25 @@ and interp_atomic ist tac : unit Proofview.tactic =
(Elim.h_double_induction h1 h2)
(* Context management *)
| TacClear (b,l) ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Tacmach.New.pf_env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let l = interp_hyp_list ist env sigma l in
if b then name_atomic ~env (TacClear (b, l)) (Tactics.keep l)
else
(* spiwack: until the tactic is in the monad *)
let tac = Proofview.V82.tactic (fun gl -> Tactics.clear l gl) in
Proofview.Trace.name_tactic (fun () -> Pp.str"<clear>") tac
- end
+ end }
| TacClearBody l ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Tacmach.New.pf_env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let l = interp_hyp_list ist env sigma l in
name_atomic ~env
(TacClearBody l)
(Tactics.clear_body l)
- end
+ end }
| TacMove (id1,id2) ->
Proofview.V82.tactic begin fun gl ->
Tactics.move_hyp (interp_hyp ist (pf_env gl) (project gl) id1)
@@ -2082,9 +2097,9 @@ and interp_atomic ist tac : unit Proofview.tactic =
gl
end
| TacRename l ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Tacmach.New.pf_env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let l =
List.map (fun (id1,id2) ->
interp_hyp ist env sigma id1,
@@ -2093,20 +2108,20 @@ and interp_atomic ist tac : unit Proofview.tactic =
name_atomic ~env
(TacRename l)
(Tactics.rename_hyp l)
- end
+ end }
(* Constructors *)
| TacSplit (ev,bll) ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let sigma, bll = List.fold_map (interp_bindings ist env) sigma bll in
let named_tac =
let tac = Tactics.split_with_bindings ev bll in
name_atomic ~env (TacSplit (ev, bll)) tac
in
Tacticals.New.tclWITHHOLES ev named_tac sigma
- end
+ end }
(* Conversion *)
| TacReduce (r,cl) ->
(* spiwack: until the tactic is in the monad *)
@@ -2150,9 +2165,9 @@ and interp_atomic ist tac : unit Proofview.tactic =
(* spiwack: until the tactic is in the monad *)
Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin
Proofview.V82.nf_evar_goals <*>
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
Proofview.V82.tactic begin fun gl ->
let (sigma,sign,op) = interp_typed_pattern ist env sigma op in
let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in
@@ -2169,28 +2184,32 @@ and interp_atomic ist tac : unit Proofview.tactic =
(Tactics.change (Some op) c_interp (interp_clause ist env sigma cl))
{ gl with sigma = sigma }
end
- end
+ end }
end
(* Equivalence relations *)
| TacSymmetry c ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let cl = interp_clause ist env sigma c in
name_atomic ~env
(TacSymmetry cl)
(Tactics.intros_symmetry cl)
- end
+ end }
(* Equality and inversion *)
| TacRewrite (ev,l,cl,by) ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let l' = List.map (fun (b,m,(keep,c)) ->
- let f env sigma = interp_open_constr_with_bindings ist env sigma c in
+ let f = { delayed = fun env sigma ->
+ let sigma = Sigma.to_evar_map sigma in
+ let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in
+ Sigma.Unsafe.of_pair (c, sigma)
+ } in
(b,m,keep,f)) l in
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let cl = interp_clause ist env sigma cl in
name_atomic ~env
(TacRewrite (ev,l,cl,by))
@@ -2198,11 +2217,11 @@ and interp_atomic ist tac : unit Proofview.tactic =
(Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by),
Equality.Naive)
by))
- end
+ end }
| TacInversion (DepInversion (k,c,ids),hyp) ->
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let (sigma,c_interp) =
match c with
| None -> sigma , None
@@ -2218,11 +2237,11 @@ and interp_atomic ist tac : unit Proofview.tactic =
(name_atomic ~env
(TacInversion(DepInversion(k,c_interp,ids),dqhyps))
(Inv.dinv k c_interp ids_interp dqhyps)) sigma
- end
+ end }
| TacInversion (NonDepInversion (k,idl,ids),hyp) ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let hyps = interp_hyp_list ist env sigma idl in
let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in
@@ -2230,11 +2249,11 @@ and interp_atomic ist tac : unit Proofview.tactic =
(name_atomic ~env
(TacInversion (NonDepInversion (k,hyps,ids),dqhyps))
(Inv.inv_clause k ids_interp hyps dqhyps)) sigma
- end
+ end }
| TacInversion (InversionUsing (c,idl),hyp) ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let (sigma,c_interp) = interp_constr ist env sigma c in
let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
let hyps = interp_hyp_list ist env sigma idl in
@@ -2242,7 +2261,7 @@ and interp_atomic ist tac : unit Proofview.tactic =
name_atomic ~env
(TacInversion (InversionUsing (c_interp,hyps),dqhyps))
(Leminv.lemInv_clause dqhyps c_interp hyps)
- end
+ end }
(* Initial call for interpretation *)
@@ -2263,7 +2282,7 @@ let eval_tactic_ist ist t =
let interp_tac_gen lfun avoid_ids debug t =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
let extra = TacStore.set TacStore.empty f_debug debug in
let extra = TacStore.set extra f_avoid_ids avoid_ids in
@@ -2272,7 +2291,7 @@ let interp_tac_gen lfun avoid_ids debug t =
interp_tactic ist
(intern_pure_tactic {
ltacvars; genv = env } t)
- end
+ end }
let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t
let _ = Proof_global.set_interp_tac interp
@@ -2292,9 +2311,9 @@ let hide_interp global t ot =
Proofview.tclENV >>= fun env ->
hide_interp env
else
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
hide_interp (Proofview.Goal.env gl)
- end
+ end }
(***************************************************************************)
(** Register standard arguments *)
@@ -2394,9 +2413,9 @@ let _ = Hook.set Auto.extern_interp
let dummy_id = Id.of_string "_"
let lift_constr_tac_to_ml_tac vars tac =
- let tac _ ist = Proofview.Goal.enter begin fun gl ->
+ let tac _ ist = Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let map = function
| None -> None
| Some id ->
@@ -2407,5 +2426,5 @@ let lift_constr_tac_to_ml_tac vars tac =
in
let args = List.map_filter map vars in
tac args ist
- end in
+ end } in
tac
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index bc82e9ef4..bdbc0aa21 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -538,66 +538,65 @@ module New = struct
mkVar (nthHypId m gl)
let onNthHypId m tac =
- Proofview.Goal.enter begin fun gl -> tac (nthHypId m gl) end
+ Proofview.Goal.enter { enter = begin fun gl -> tac (nthHypId m gl) end }
let onNthHyp m tac =
- Proofview.Goal.enter begin fun gl -> tac (nthHyp m gl) end
+ Proofview.Goal.enter { enter = begin fun gl -> tac (nthHyp m gl) end }
let onLastHypId = onNthHypId 1
let onLastHyp = onNthHyp 1
let onNthDecl m tac =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
Proofview.tclUNIT (nthDecl m gl) >>= tac
- end
+ end }
let onLastDecl = onNthDecl 1
let ifOnHyp pred tac1 tac2 id =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let typ = Tacmach.New.pf_get_hyp_typ id gl in
if pred (id,typ) then
tac1 id
else
tac2 id
- end
+ end }
- let onHyps find tac = Proofview.Goal.nf_enter (fun gl -> tac (find gl))
+ let onHyps find tac = Proofview.Goal.nf_enter { enter = begin fun gl -> tac (find.enter gl) end }
let afterHyp id tac =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let hyps = Proofview.Goal.hyps gl in
let rem, _ = List.split_when (fun (hyp,_,_) -> Id.equal hyp id) hyps in
tac rem
- end
+ end }
let fullGoal gl =
let hyps = Tacmach.New.pf_ids_of_hyps gl in
None :: List.map Option.make hyps
let tryAllHyps tac =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let hyps = Tacmach.New.pf_ids_of_hyps gl in
tclFIRST_PROGRESS_ON tac hyps
- end
+ end }
let tryAllHypsAndConcl tac =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
tclFIRST_PROGRESS_ON tac (fullGoal gl)
- end
+ end }
let onClause tac cl =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let hyps = Tacmach.New.pf_ids_of_hyps gl in
tclMAP tac (Locusops.simple_clause_of (fun () -> hyps) cl)
- end
+ end }
(* Find the right elimination suffix corresponding to the sort of the goal *)
(* c should be of type A1->.. An->B with B an inductive definition *)
let general_elim_then_using mk_elim
isrec allnames tac predicate ind (c, t) =
- Proofview.Goal.nf_enter
- begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in
Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma)
- (Proofview.Goal.nf_enter begin fun gl ->
+ (Proofview.Goal.nf_enter { enter = begin fun gl ->
let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in
(* applying elimination_scheme just a little modified *)
let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_unsafe_type_of gl elim)) gl in
@@ -649,10 +648,10 @@ module New = struct
Proofview.tclTHEN
(Clenvtac.clenv_refine false clenv')
(Proofview.tclEXTEND [] tclIDTAC branchtacs)
- end) end
+ end }) end }
let elimination_then tac c =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let (ind,t) = pf_reduce_to_quantified_ind gl (pf_unsafe_type_of gl c) in
let isrec,mkelim =
match (Global.lookup_mind (fst (fst ind))).mind_record with
@@ -660,7 +659,7 @@ module New = struct
| Some _ -> false,gl_make_case_dep
in
general_elim_then_using mkelim isrec None tac None ind (c, t)
- end
+ end }
let case_then_using =
general_elim_then_using gl_make_case_dep false
@@ -669,16 +668,16 @@ module New = struct
general_elim_then_using gl_make_case_nodep false
let elim_on_ba tac ba =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let branches = Tacmach.New.of_old (make_elim_branch_assumptions ba) gl in
tac branches
- end
+ end }
let case_on_ba tac ba =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let branches = Tacmach.New.of_old (make_case_branch_assumptions ba) gl in
tac branches
- end
+ end }
let elimination_sort_of_goal gl =
(** Retyping will expand evars anyway. *)
@@ -695,11 +694,11 @@ module New = struct
| Some id -> elimination_sort_of_hyp id gl
let pf_constr_of_global ref tac =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let (sigma, c) = Evd.fresh_global env sigma ref in
Proofview.Unsafe.tclEVARS sigma <*> (tac c)
- end
+ end }
end
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index 4e860892d..80e01a8d0 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -223,7 +223,7 @@ module New : sig
val tclTIMEOUT : int -> unit tactic -> unit tactic
val tclTIME : string option -> 'a tactic -> 'a tactic
- val nLastDecls : [ `NF ] Proofview.Goal.t -> int -> named_context
+ val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> named_context
val ifOnHyp : (identifier * types -> bool) ->
(identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) ->
@@ -234,7 +234,7 @@ module New : sig
val onLastHyp : (constr -> unit tactic) -> unit tactic
val onLastDecl : (named_declaration -> unit tactic) -> unit tactic
- val onHyps : ([ `NF ] Proofview.Goal.t -> named_context) ->
+ val onHyps : ([ `NF ], named_context) Proofview.Goal.enter ->
(named_context -> unit tactic) -> unit tactic
val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic
@@ -242,9 +242,9 @@ module New : sig
val tryAllHypsAndConcl : (identifier option -> unit tactic) -> unit tactic
val onClause : (identifier option -> unit tactic) -> clause -> unit tactic
- val elimination_sort_of_goal : 'a Proofview.Goal.t -> sorts_family
- val elimination_sort_of_hyp : Id.t -> 'a Proofview.Goal.t -> sorts_family
- val elimination_sort_of_clause : Id.t option -> 'a Proofview.Goal.t -> sorts_family
+ val elimination_sort_of_goal : ('a, 'r) Proofview.Goal.t -> sorts_family
+ val elimination_sort_of_hyp : Id.t -> ('a, 'r) Proofview.Goal.t -> sorts_family
+ val elimination_sort_of_clause : Id.t option -> ('a, 'r) Proofview.Goal.t -> sorts_family
val elimination_then :
(branch_args -> unit Proofview.tactic) ->
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index 0b920066f..289d5109a 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -26,7 +26,7 @@ open Evd
open Pfedit
open Tacred
open Genredexpr
-open Tacmach
+open Tacmach.New
open Logic
open Clenv
open Refiner
@@ -43,6 +43,7 @@ open Locus
open Locusops
open Misctypes
open Proofview.Notations
+open Sigma.Notations
let nb_prod x =
let rec count n c =
@@ -57,7 +58,7 @@ let inj_with_occurrences e = (AllOccurrences,e)
let dloc = Loc.ghost
-let typ_of = Retyping.get_type_of
+let typ_of env sigma c = Retyping.get_type_of env (Sigma.to_evar_map sigma) c
open Goptions
@@ -126,6 +127,19 @@ let _ =
optread = (fun () -> !universal_lemma_under_conjunctions) ;
optwrite = (fun b -> universal_lemma_under_conjunctions := b) }
+(* Shrinking of abstract proofs. *)
+
+let shrink_abstract = ref false
+
+let _ =
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ 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.
@@ -144,7 +158,7 @@ let _ =
optdepr = false;
optname = "bracketing last or-and introduction pattern";
optkey = ["Bracketing";"Last";"Introduction";"Pattern"];
- optread = (fun () -> !bracketing_last_or_and_intro_pattern) ;
+ optread = (fun () -> !bracketing_last_or_and_intro_pattern);
optwrite = (fun b -> bracketing_last_or_and_intro_pattern := b) }
(*********************************************)
@@ -158,21 +172,22 @@ let _ =
(** This tactic creates a partial proof realizing the introduction rule, but
does not check anything. *)
let unsafe_intro env store (id, c, t) b =
- Proofview.Refine.refine ~unsafe:true begin fun sigma ->
+ Proofview.Refine.refine ~unsafe:true { run = begin fun sigma ->
+ let sigma = Sigma.to_evar_map sigma in
let ctx = named_context_val env in
let nctx = push_named_context_val (id, c, t) ctx in
let inst = List.map (fun (id, _, _) -> mkVar id) (named_context env) in
let ninst = mkRel 1 :: inst in
let nb = subst1 (mkVar id) b in
let sigma, ev = new_evar_instance nctx sigma nb ~store ninst in
- sigma, mkNamedLambda_or_LetIn (id, c, t) ev
- end
+ Sigma.Unsafe.of_pair (mkNamedLambda_or_LetIn (id, c, t) ev, sigma)
+ end }
let introduction ?(check=true) id =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let gl = Proofview.Goal.assume gl in
let concl = Proofview.Goal.concl gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let hyps = Proofview.Goal.hyps gl in
let store = Proofview.Goal.extra gl in
let env = Proofview.Goal.env gl in
@@ -184,51 +199,55 @@ let introduction ?(check=true) id =
| Prod (_, t, b) -> unsafe_intro env store (id, None, t) b
| LetIn (_, c, t, b) -> unsafe_intro env store (id, Some c, t) b
| _ -> raise (RefinerError IntroNeedsProduct)
- end
+ end }
let refine = Tacmach.refine
let convert_concl ?(check=true) ty k =
- Proofview.Goal.enter begin fun gl ->
+ 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
- Proofview.Refine.refine ~unsafe:true begin fun sigma ->
- let sigma =
+ Proofview.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
- end else sigma in
- let (sigma,x) = Evarutil.new_evar env sigma ~principal:true ~store ty in
- (sigma, if k == DEFAULTcast then x else mkCast(x,k,conclty))
- end
- end
+ 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 begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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
- Proofview.Refine.refine ~unsafe:true (fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty)
- end
+ Proofview.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 begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
try
let sigma = Tacmach.New.pf_apply Evd.conversion gl pb x y in
Proofview.Unsafe.tclEVARS sigma
with (* Reduction.NotConvertible *) _ ->
(** FIXME: Sometimes an anomaly is raised from conversion *)
Tacticals.New.tclFAIL 0 (str "Not convertible")
-end
+end }
let convert x y = convert_gen Reduction.CONV x y
let convert_leq x y = convert_gen Reduction.CUMUL x y
@@ -261,7 +280,7 @@ let error_replacing_dependency env sigma id err =
errorlabstrm "" (replacing_dependency_msg env sigma id err)
let thin l gl =
- try thin l gl
+ try Tacmach.thin l gl
with Evarutil.ClearDependencyError (id,err) ->
error_clear_dependency (pf_env gl) (project gl) id err
@@ -300,7 +319,7 @@ let rename_hyp repl =
match dom with
| None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping")
| Some (src, dst) ->
- Proofview.Goal.enter begin fun gl ->
+ 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
@@ -332,10 +351,12 @@ let rename_hyp repl =
let nconcl = subst concl in
let nctx = Environ.val_of_named_context nhyps in
let instance = List.map (fun (id, _, _) -> mkVar id) hyps in
- Proofview.Refine.refine ~unsafe:true begin fun sigma ->
- Evarutil.new_evar_instance nctx sigma nconcl ~store instance
- end
- end
+ Proofview.Refine.refine ~unsafe:true { run = begin fun sigma ->
+ let sigma = Sigma.to_evar_map sigma in
+ let (sigma, c) = Evarutil.new_evar_instance nctx sigma nconcl ~store instance in
+ Sigma.Unsafe.of_pair (c, sigma)
+ end }
+ end }
(**************************************************************)
(* Fresh names *)
@@ -380,7 +401,7 @@ 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 = Proofview.Goal.sigma 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) ->
@@ -396,16 +417,16 @@ let find_name mayrepl decl naming gl = match naming with
(**************************************************************)
let assert_before_then_gen b naming t tac =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let id = find_name b (Anonymous,None,t) naming gl in
Tacticals.New.tclTHENLAST
(Proofview.V82.tactic
(fun gl ->
- try internal_cut b id t 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
+ end }
let assert_before_gen b naming t =
assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ())
@@ -414,16 +435,16 @@ 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 =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let id = find_name b (Anonymous,None,t) naming gl in
Tacticals.New.tclTHENFIRST
(Proofview.V82.tactic
(fun gl ->
- try internal_cut_rev b id t 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
+ end }
let assert_after_gen b naming t =
assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ()))
@@ -460,7 +481,7 @@ let cofix ido gl = match ido with
type tactic_reduction = env -> evar_map -> constr -> constr
let pf_reduce_decl redfun where (id,c,ty) gl =
- let redfun' = pf_reduce redfun gl in
+ let redfun' = Tacmach.pf_reduce redfun gl in
match c with
| None ->
if where == InHypValueOnly then
@@ -540,11 +561,11 @@ let bind_red_expr_occurrences occs nbcl redexp =
certain hypothesis *)
let reduct_in_concl (redfun,sty) gl =
- Proofview.V82.of_tactic (convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty) gl
+ Proofview.V82.of_tactic (convert_concl_no_check (Tacmach.pf_reduce redfun gl (Tacmach.pf_concl gl)) sty) gl
let reduct_in_hyp ?(check=false) redfun (id,where) gl =
Proofview.V82.of_tactic (convert_hyp ~check
- (pf_reduce_decl redfun where (pf_get_hyp gl id) gl)) gl
+ (pf_reduce_decl redfun where (Tacmach.pf_get_hyp gl id) gl)) gl
let revert_cast (redfun,kind as r) =
if kind == DEFAULTcast then (redfun,REVERTcast) else r
@@ -571,13 +592,13 @@ let pf_e_reduce_decl redfun where (id,c,ty) gl =
let e_reduct_in_concl (redfun,sty) gl =
Proofview.V82.of_tactic
- (let sigma, c' = (pf_apply redfun gl (pf_concl gl)) in
+ (let sigma, c' = (Tacmach.pf_apply redfun gl (Tacmach.pf_concl gl)) in
Proofview.Unsafe.tclEVARS sigma <*>
convert_concl_no_check c' sty) gl
let e_reduct_in_hyp ?(check=false) redfun (id,where) gl =
Proofview.V82.of_tactic
- (let sigma, decl' = pf_e_reduce_decl redfun where (pf_get_hyp gl id) gl in
+ (let sigma, decl' = pf_e_reduce_decl redfun where (Tacmach.pf_get_hyp gl id) gl in
Proofview.Unsafe.tclEVARS sigma <*>
convert_hyp ~check decl') gl
@@ -588,17 +609,12 @@ let e_reduct_option ?(check=false) redfun = function
(** Versions with evars to maintain the unification of universes resulting
from conversions. *)
-let tclWITHEVARS f k =
- Proofview.Goal.enter begin fun gl ->
- let evm, c' = f gl in
- Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) (k c')
- end
-
let e_change_in_concl (redfun,sty) =
- tclWITHEVARS
- (fun gl -> redfun (Proofview.Goal.env gl) (Proofview.Goal.sigma gl)
- (Proofview.Goal.raw_concl gl))
- (fun c -> convert_concl_no_check c sty)
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
+ let sigma = Sigma.to_evar_map sigma in
+ let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in
+ Sigma.Unsafe.of_pair (convert_concl_no_check c sty, sigma)
+ end }
let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env sigma =
match c with
@@ -617,11 +633,12 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env
sigma', (id,Some b',ty')
let e_change_in_hyp redfun (id,where) =
- tclWITHEVARS
- (fun gl -> e_pf_change_decl redfun where
- (Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl))
- (Proofview.Goal.env gl) (Proofview.Goal.sigma gl))
- convert_hyp
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
+ let sigma = Sigma.to_evar_map sigma in
+ let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in
+ let sigma, c = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in
+ Sigma.Unsafe.of_pair (convert_hyp c, sigma)
+ end }
type change_arg = Pattern.patvar_map -> evar_map -> evar_map * constr
@@ -683,7 +700,7 @@ let change_option occl t = function
| None -> change_in_concl occl t
let change chg c cls gl =
- let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in
+ let cls = concrete_clause_of (fun () -> Tacmach.pf_ids_of_hyps gl) cls in
Proofview.V82.of_tactic (Tacticals.New.tclMAP (function
| OnHyp (id,occs,where) ->
change_option (bind_change_occurrences occs chg) c (Some (id,where))
@@ -724,12 +741,12 @@ let reduction_clause redexp cl =
(None, bind_red_expr_occurrences occs nbcl redexp)) cl
let reduce redexp cl goal =
- let cl = concrete_clause_of (fun () -> pf_ids_of_hyps goal) cl in
+ let cl = concrete_clause_of (fun () -> Tacmach.pf_ids_of_hyps goal) cl in
let redexps = reduction_clause redexp cl in
let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in
let tac = tclMAP (fun (where,redexp) ->
e_reduct_option ~check
- (Redexpr.reduction_of_red_expr (pf_env goal) redexp) where) redexps in
+ (Redexpr.reduction_of_red_expr (Tacmach.pf_env goal) redexp) where) redexps in
if check then with_check tac goal else tac goal
(* Unfolding occurrences of a constant *)
@@ -766,9 +783,9 @@ let build_intro_tac id dest tac = match dest with
Proofview.V82.tactic (move_hyp id dest); tac id]
let rec intro_then_gen name_flag move_flag force_flag dep_flag tac =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in
- let concl = nf_evar (Proofview.Goal.sigma gl) concl 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 (name,None,t) name_flag gl in
@@ -792,7 +809,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac =
Tacticals.New.tclZEROMSG (str "No product even after head-reduction.")
| e -> Proofview.tclZERO ~info e
end
- 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
@@ -856,14 +873,14 @@ let get_previous_hyp_position id gl =
aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl))
let intro_replacing id =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let next_hyp = get_next_hyp_position id gl in
Tacticals.New.tclTHENLIST [
Proofview.V82.tactic (thin_for_replacing [id]);
introduction id;
Proofview.V82.tactic (move_hyp id next_hyp);
]
- end
+ 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''
@@ -875,7 +892,7 @@ let intro_replacing id =
(* the behavior of inversion *)
let intros_possibly_replacing ids =
let suboptimal = true in
- Proofview.Goal.enter begin fun gl ->
+ 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 ->
@@ -884,16 +901,16 @@ let intros_possibly_replacing ids =
(Tacticals.New.tclMAP (fun (id,pos) ->
Tacticals.New.tclORELSE (intro_move (Some id) pos) (intro_using id))
posl)
- end
+ end }
(* This version assumes that replacement is actually possible *)
let intros_replacing ids =
- Proofview.Goal.enter begin fun gl ->
+ 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
(Proofview.V82.tactic (thin_for_replacing ids))
(Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl)
- end
+ end }
(* User-level introduction tactics *)
@@ -911,7 +928,7 @@ let pf_lookup_hypothesis_as_renamed_gen red h gl =
env (project gl) ccl))
| x -> x
in
- try aux (pf_concl gl)
+ try aux (Tacmach.pf_concl gl)
with Redelimination -> None
let is_quantified_hypothesis id g =
@@ -937,10 +954,10 @@ let depth_of_quantified_hypothesis red h gl =
str".")
let intros_until_gen red h =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let n = Tacmach.New.of_old (depth_of_quantified_hypothesis red h) gl in
Tacticals.New.tclDO n (if red then introf else intro)
- end
+ 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)
@@ -948,7 +965,7 @@ 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 gl = ignore (pf_get_hyp gl id); tclIDTAC gl
+let tclCHECKVAR id gl = ignore (Tacmach.pf_get_hyp gl id); tclIDTAC gl
let try_intros_until_id_check id =
Tacticals.New.tclORELSE (intros_until_id id) (Proofview.V82.tactic (tclCHECKVAR id))
@@ -963,12 +980,15 @@ let rec intros_move = function
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 onOpenInductionArg env sigma tac = function
| clear_flag,ElimOnConstr f ->
- let (sigma',cbl) = f env sigma in
+ let (cbl, sigma') = run_delayed env sigma f in
let pending = (sigma,sigma') in
Tacticals.New.tclTHEN
(Proofview.Unsafe.tclEVARS sigma')
@@ -978,20 +998,20 @@ let onOpenInductionArg env sigma tac = function
(intros_until_n n)
(Tacticals.New.onLastHyp
(fun c ->
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ 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))
+ end }))
| clear_flag,ElimOnIdent (_,id) ->
(* A quantified hypothesis *)
Tacticals.New.tclTHEN
(try_intros_until_id_check id)
- (Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ (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)
+ end })
let onInductionArg tac = function
| clear_flag,ElimOnConstr cbl ->
@@ -1016,9 +1036,9 @@ let map_induction_arg f = function
(****************************************)
let cut c =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let concl = Tacmach.New.pf_nf_concl gl in
let is_sort =
try
@@ -1034,15 +1054,15 @@ let cut c =
let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in
(** Backward compat: normalize [c]. *)
let c = local_strong whd_betaiota sigma c in
- Proofview.Refine.refine ~unsafe:true begin fun h ->
- let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in
- let (h, x) = Evarutil.new_evar env h c in
+ Proofview.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 = mkLambda (Name id, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in
- (h, mkApp (f, [|x|]))
- end
+ Sigma (mkApp (f, [|x|]), h, p +> q)
+ end }
else
Tacticals.New.tclZEROMSG (str "Not a proposition or a type.")
- end
+ end }
let error_uninstantiated_metas t clenv =
let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in
@@ -1086,7 +1106,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true)
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 (refine_no_check new_hyp_prf) 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
@@ -1151,12 +1171,12 @@ let enforce_prop_bound_names rename tac =
mkLetIn (na,c,t,aux (push_rel (na,Some c,t) env) sigma (i-1) t')
| _ -> print_int i; Pp.msg (print_constr t); assert false in
let rename_branch i =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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
+ end } in
(if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn)
tac
(Array.map rename_branch nn)
@@ -1171,9 +1191,9 @@ let rec contract_letin_in_lam_header c =
let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ())
rename i (elim, elimty, bindings) indclause =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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 =
@@ -1184,7 +1204,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags
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
+ end }
(*
* Elimination tactic with bindings and using an arbitrary
@@ -1201,20 +1221,20 @@ type eliminator = {
}
let general_elim_clause_gen elimtac indclause elim =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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
+ end }
let general_elim with_evars clear_flag (c, lbindc) elim =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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
@@ -1222,14 +1242,14 @@ let general_elim with_evars clear_flag (c, lbindc) elim =
Tacticals.New.tclTHEN
(general_elim_clause_gen elimtac indclause elim)
(apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)
- end
+ end }
(* Case analysis tactics *)
let general_case_analysis_in_context with_evars clear_flag (c,lbindc) =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Sigma.to_evar_map sigma in
let concl = Proofview.Goal.concl gl in
let t = Retyping.get_type_of env sigma c in
let (mind,_) = reduce_to_quantified_ind env sigma t in
@@ -1239,11 +1259,13 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) =
build_case_analysis_scheme env sigma mind true sort
else
build_case_analysis_scheme_default env sigma mind sort in
- Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma)
+ let tac =
(general_elim with_evars clear_flag (c,lbindc)
{elimindex = None; elimbody = (elim,NoBindings);
elimrename = Some (false, constructors_nrealdecls (fst mind))})
- end
+ in
+ Sigma.Unsafe.of_pair (tac, sigma)
+ end }
let general_case_analysis with_evars clear_flag (c,lbindc as cx) =
match kind_of_term c with
@@ -1276,11 +1298,13 @@ let find_eliminator c gl =
let default_elim with_evars clear_flag (c,_ as cx) =
Proofview.tclORELSE
- (Proofview.Goal.enter begin fun gl ->
- let evd, elim = find_eliminator c gl in
- Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd)
+ (Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
+ let sigma, elim = find_eliminator c gl in
+ let tac =
(general_elim with_evars clear_flag cx elim)
- end)
+ 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
@@ -1325,9 +1349,9 @@ let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause =
let elimination_in_clause_scheme with_evars ?(flags=elim_flags ())
id rename i (elim, elimty, bindings) indclause =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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
@@ -1348,7 +1372,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ())
(str "Nothing to rewrite in " ++ pr_id id ++ str".");
clenv_refine_in with_evars id id sigma elimclause''
(fun id -> Proofview.tclUNIT ())
- end
+ end }
let general_elim_clause with_evars flags id c e =
let elim = match id with
@@ -1403,9 +1427,9 @@ let make_projection env sigma params cstr sign elim i n c u =
in elim
let descend_in_conjunctions avoid tac (err, info) c =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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
@@ -1424,9 +1448,9 @@ let descend_in_conjunctions avoid tac (err, info) c =
NotADefinedRecordUseScheme (snd elim) in
Tacticals.New.tclFIRST
(List.init n (fun i ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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) ->
@@ -1435,31 +1459,32 @@ let descend_in_conjunctions avoid tac (err, info) c =
[Proofview.V82.tactic (refine p);
(* Might be ill-typed due to forbidden elimination. *)
Tacticals.New.onLastHypId (tac (not isrec))]
- end))
+ end }))
| None -> Proofview.tclZERO ~info err
with RefinerError _|UserError _ -> Proofview.tclZERO ~info err
- end
+ end }
(****************************************************)
(* Resolution tactics *)
(****************************************************)
let solve_remaining_apply_goals =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma ->
if !apply_solve_class_goals then
try
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let evd = Sigma.to_evar_map sigma in
let concl = Proofview.Goal.concl gl in
- if Typeclasses.is_class_type sigma concl then
- let evd', c' = Typeclasses.resolve_one_typeclass env sigma concl in
- Tacticals.New.tclTHEN
- (Proofview.Unsafe.tclEVARS evd')
- (Proofview.V82.tactic (refine_no_check c'))
- else Proofview.tclUNIT ()
- with Not_found -> Proofview.tclUNIT ()
- else Proofview.tclUNIT ()
- end
+ if Typeclasses.is_class_type evd concl then
+ let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in
+ let tac =
+ (Proofview.V82.tactic (Tacmach.refine_no_check c'))
+ 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
@@ -1470,7 +1495,7 @@ let tclORELSEOPT t k =
| Some tac -> tac)
let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) =
- Proofview.Goal.nf_enter begin fun gl ->
+ 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
@@ -1479,9 +1504,9 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind))
step. *)
let concl_nprod = nb_prod concl in
let rec try_main_apply with_destruct c =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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 =
@@ -1533,14 +1558,14 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind))
| PretypeError _|RefinerError _|UserError _|Failure _ ->
Some (try_red_apply thm_ty0 (e, info))
| _ -> None)
- end
+ 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
+ end }
let rec apply_with_bindings_gen b e = function
| [] -> Proofview.tclUNIT ()
@@ -1552,13 +1577,13 @@ let rec apply_with_bindings_gen b e = function
let apply_with_delayed_bindings_gen b e l =
let one k (loc, f) =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
- let sigma, cb = f env sigma in
+ let (cb, sigma) = run_delayed env sigma f in
Tacticals.New.tclWITHHOLES e
(general_apply b b e k (loc,cb)) sigma
- end
+ end }
in
let rec aux = function
| [] -> Proofview.tclUNIT ()
@@ -1621,18 +1646,18 @@ let apply_in_once_main flags innerclause env sigma (d,lbind) =
let apply_in_once sidecond_first with_delta with_destruct with_evars naming
id (clear_flag,(loc,(d,lbind))) tac =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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 (Anonymous,None,t') naming gl in
let rec aux idstoclear with_destruct c =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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
@@ -1647,22 +1672,22 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming
(descend_in_conjunctions [targetid]
(fun b id -> aux (id::idstoclear) b (mkVar id))
(e, info) c)
- end
+ end }
in
aux [] with_destruct d
- end
+ end }
let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming
id (clear_flag,(loc,f)) tac =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
- let sigma, c = f env sigma 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
+ end }
(* A useful resolution tactic which, if c:A->B, transforms |- C into
|- B -> C and |- A
@@ -1682,20 +1707,20 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam
*)
let cut_and_apply c =
- Proofview.Goal.nf_enter begin fun gl ->
+ 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
- Proofview.Refine.refine begin fun sigma ->
+ Proofview.Refine.refine { run = begin fun sigma ->
let typ = mkProd (Anonymous, c2, concl) in
- let (sigma, f) = Evarutil.new_evar env sigma typ in
- let (sigma, x) = Evarutil.new_evar env sigma c1 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)
- end
+ Sigma (ans, sigma, p +> q)
+ end }
| _ -> error "lapply needs a non-dependent product."
- end
+ end }
(********************************************************************)
(* Exact tactics *)
@@ -1708,29 +1733,31 @@ let cut_and_apply c =
(* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *)
let new_exact_no_check c =
- Proofview.Refine.refine ~unsafe:true (fun h -> (h, c))
+ Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h }
let exact_check c =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
(** 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 = Proofview.Goal.sigma gl in
+ let sigma = Sigma.to_evar_map sigma in
let sigma, ct = Typing.type_of env sigma c in
- Proofview.Unsafe.tclEVARS sigma <*>
+ let tac =
Tacticals.New.tclTHEN (convert_leq ct concl) (new_exact_no_check c)
- end
+ in
+ Sigma.Unsafe.of_pair (tac, sigma)
+ end }
-let exact_no_check = refine_no_check
+let exact_no_check = Tacmach.refine_no_check
let vm_cast_no_check c gl =
- let concl = pf_concl gl in
- refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl
+ let concl = Tacmach.pf_concl gl in
+ Tacmach.refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl
let exact_proof c gl =
- let c,ctx = Constrintern.interp_casted_constr (pf_env gl) (project gl) c (pf_concl gl)
- in tclTHEN (tclEVARUNIVCONTEXT ctx) (refine_no_check c) gl
+ let c,ctx = Constrintern.interp_casted_constr (Tacmach.pf_env gl) (Tacmach.project gl) c (Tacmach.pf_concl gl)
+ in tclTHEN (tclEVARUNIVCONTEXT ctx) (Tacmach.refine_no_check c) gl
let assumption =
let rec arec gl only_eq = function
@@ -1741,7 +1768,7 @@ let assumption =
else Tacticals.New.tclZEROMSG (str "No such assumption.")
| (id, c, t)::rest ->
let concl = Proofview.Goal.concl gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let (sigma, is_same_type) =
if only_eq then (sigma, Constr.equal t concl)
else
@@ -1750,13 +1777,13 @@ let assumption =
in
if is_same_type then
(Proofview.Unsafe.tclEVARS sigma) <*>
- Proofview.Refine.refine ~unsafe:true (fun h -> (h, mkVar id))
+ Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar id) h }
else arec gl only_eq rest
in
- let assumption_tac gl =
+ let assumption_tac = { enter = begin fun gl ->
let hyps = Proofview.Goal.hyps gl in
arec gl true hyps
- in
+ end } in
Proofview.Goal.nf_enter assumption_tac
(*****************************************************************)
@@ -1799,7 +1826,7 @@ let check_decl env (_, c, ty) msg =
msg e
let clear_body ids =
- Proofview.Goal.enter begin fun gl ->
+ 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 ctx = named_context env in
@@ -1832,10 +1859,10 @@ let clear_body ids =
check_is_type env concl msg
in
check_hyps <*> check_concl <*>
- Proofview.Refine.refine ~unsafe:true begin fun sigma ->
+ Proofview.Refine.refine ~unsafe:true { run = begin fun sigma ->
Evarutil.new_evar env sigma concl
- end
- end
+ end }
+ end }
let clear_wildcards ids =
Proofview.V82.tactic (tclMAP (fun (loc,id) gl ->
@@ -1865,7 +1892,7 @@ let specialize (c,lbind) g =
let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in
tclEVARS evd, nf_evar evd c
else
- let clause = pf_apply make_clenv_binding g (c,pf_unsafe_type_of g c) lbind in
+ let clause = Tacmach.pf_apply make_clenv_binding g (c,Tacmach.pf_unsafe_type_of g 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
@@ -1882,20 +1909,20 @@ let specialize (c,lbind) g =
tclEVARS clause.evd, term
in
match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with
- | Var id when Id.List.mem id (pf_ids_of_hyps g) ->
+ | Var id when Id.List.mem id (Tacmach.pf_ids_of_hyps g) ->
tclTHEN tac
(tclTHENFIRST
- (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (pf_unsafe_type_of g term)) g)
+ (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (Tacmach.pf_unsafe_type_of g term)) g)
(exact_no_check term)) g
| _ -> tclTHEN tac
(tclTHENLAST
- (fun g -> Proofview.V82.of_tactic (cut (pf_unsafe_type_of g term)) g)
+ (fun g -> Proofview.V82.of_tactic (cut (Tacmach.pf_unsafe_type_of g term)) g)
(exact_no_check term)) g
(* Keeping only a few hypotheses *)
let keep hyps =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
Proofview.tclENV >>= fun env ->
let ccl = Proofview.Goal.concl gl in
let cl,_ =
@@ -1908,7 +1935,7 @@ let keep hyps =
~init:([],[]) (Proofview.Goal.env gl)
in
Proofview.V82.tactic (fun gl -> thin cl gl)
- end
+ end }
(************************)
(* Introduction tactics *)
@@ -1925,7 +1952,7 @@ let check_number_of_constructors expctdnumopt i nconstr =
if i > nconstr then error "Not enough constructors."
let constructor_tac with_evars expctdnumopt i lbind =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
let cl = Tacmach.New.pf_nf_concl gl in
let reduce_to_quantified_ind =
Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl
@@ -1935,16 +1962,19 @@ let constructor_tac with_evars expctdnumopt i lbind =
Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in
check_number_of_constructors expctdnumopt i nconstr;
- let sigma, cons = Evd.fresh_constructor_instance
- (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (fst mind, i) in
+ 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
- [Proofview.Unsafe.tclEVARS sigma;
+ [
convert_concl_no_check redcl DEFAULTcast;
intros; apply_tac])
- end
+ in
+ Sigma (tac, sigma, p)
+ end }
let one_constructor i lbind = constructor_tac false None i lbind
@@ -1961,7 +1991,7 @@ let rec tclANY tac = function
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 begin fun gl ->
+ 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
@@ -1971,7 +2001,7 @@ let any_constructor with_evars tacopt =
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
+ 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
@@ -2022,7 +2052,7 @@ let my_find_eq_data_decompose gl t =
| Constr_matching.PatternMatchingFailure -> None
let intro_decomp_eq loc l thin tac id =
- Proofview.Goal.nf_enter begin fun gl ->
+ 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
@@ -2033,10 +2063,10 @@ let intro_decomp_eq loc l thin tac id =
(eq,t,eq_args) (c, t)
| None ->
Tacticals.New.tclZEROMSG (str "Not a primitive equality here.")
- end
+ end }
let intro_or_and_pattern loc bracketed ll thin tac id =
- Proofview.Goal.enter begin fun gl ->
+ 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,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in
@@ -2047,7 +2077,7 @@ let intro_or_and_pattern loc bracketed ll thin tac id =
(Tacticals.New.tclTHEN (simplest_case c) (Proofview.V82.tactic (clear [id])))
(Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l)
nv (Array.of_list ll))
- end
+ end }
let rewrite_hyp assert_style l2r id =
let rew_on l2r =
@@ -2055,7 +2085,7 @@ let rewrite_hyp assert_style l2r id =
let subst_on l2r x rhs =
Hook.get forward_subst_one true x (id,rhs,l2r) in
let clear_var_and_eq c = tclTHEN (clear [id]) (clear [destVar c]) in
- Proofview.Goal.enter begin fun gl ->
+ 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_betadeltaiota = Tacmach.New.pf_apply whd_betadeltaiota gl in
@@ -2077,7 +2107,7 @@ let rewrite_hyp assert_style l2r id =
Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id]))
| _ ->
Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id]))
- end
+ end }
let rec prepare_naming loc = function
| IntroIdentifier id -> NamingMustBe (loc,id)
@@ -2213,10 +2243,10 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with
Proofview.tclUNIT () (* apply_in_once do a replacement *)
else
Proofview.V82.tactic (clear [id]) in
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
- let sigma,c = f env sigma in
+ let (c, sigma) = run_delayed env sigma f in
Tacticals.New.tclWITHHOLES false
(Tacticals.New.tclTHENFIRST
(* Skip the side conditions of the apply *)
@@ -2225,7 +2255,7 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with
(fun id -> Tacticals.New.tclTHEN doclear (tac_ipat id)))
(tac thin None []))
sigma
- end
+ end }
and prepare_intros_loc loc dft destopt = function
| IntroNaming ipat ->
@@ -2288,7 +2318,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars
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 begin fun gl ->
+ 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
@@ -2299,7 +2329,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars
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
+ end }
(*
if sidecond_first then
@@ -2310,7 +2340,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars
*)
let apply_in simple with_evars clear_flag id lemmas ipat =
- let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, fun _ sigma -> sigma, l)) lemmas in
+ 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 clear_flag id lemmas ipat
let apply_delayed_in simple with_evars clear_flag id lemmas ipat =
@@ -2341,11 +2371,10 @@ let decode_hyp = function
*)
let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
let t = match ty with Some t -> t | _ -> typ_of env sigma c in
- let eq_tac gl = match with_eq with
+ let Sigma ((newcl, eq_tac), sigma, p) = match with_eq with
| Some (lr,(loc,ido)) ->
let heq = match ido with
| IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl
@@ -2353,26 +2382,31 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty =
| 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 = Evd.fresh_global env sigma eqdata.eq in
- let sigma, refl = Evd.fresh_global env sigma eqdata.refl 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
- sigma, term,
+ 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, mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in
- let (sigma,newcl,eq_tac) = eq_tac gl in
- Tacticals.New.tclTHENLIST
- [ Proofview.Unsafe.tclEVARS sigma;
- convert_concl_no_check newcl DEFAULTcast;
+ 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 ]
- end
+ in
+ Sigma (tac, sigma, p)
+ end }
let insert_before decls lasthyp env =
match lasthyp with
@@ -2400,55 +2434,55 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty =
id in
let eqdata = build_coq_eq_data () in
let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in
- let sigma, eq = Evd.fresh_global env sigma eqdata.eq in
- let sigma, refl = Evd.fresh_global env sigma eqdata.refl 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 [heq,None,eq;id,body,t] lastlhyp env in
- let (sigma,x) = new_evar newenv sigma ~principal:true ~store ccl in
- (sigma,mkNamedLetIn id c t (mkNamedLetIn heq refl eq x))
+ 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 [id,body,t] lastlhyp env in
- let (sigma,x) = new_evar newenv sigma ~principal:true ~store ccl in
- (sigma,mkNamedLetIn id c t x)
+ 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_enter begin fun gl ->
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
let ccl = Proofview.Goal.concl gl in
let abs = AbstractExact (id,c,ty,occs,true) in
let (id,_,depdecls,lastlhyp,ccl,_) = make_abstraction env sigma ccl abs in
(* We keep the original term to match *)
- letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty
- end
+ let tac = letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty in
+ Sigma.here tac sigma
+ end }
let letin_pat_tac with_eq id c occs =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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 = match res with
+ let Sigma (c, sigma, p) = match res with
| None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c
- | Some (sigma,c) -> (sigma,c) in
- Tacticals.New.tclTHEN
- (Proofview.Unsafe.tclEVARS sigma)
+ | Some res -> res in
+ let tac =
(letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None)
- end
+ 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 begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let t = Tacmach.New.pf_unsafe_type_of gl c in
let hd = head_ident c in
Tacticals.New.tclTHENFIRST (assert_as true hd ipat t)
(Proofview.V82.tactic (exact_no_check c))
- end
+ end }
| Some tac ->
if b then
Tacticals.New.tclTHENFIRST (assert_as b None ipat c) tac
@@ -2478,25 +2512,25 @@ let apply_type hdcty argl gl =
let bring_hyps hyps =
if List.is_empty hyps then Tacticals.New.tclIDTAC
else
- Proofview.Goal.enter begin fun gl ->
+ 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 (instance_from_named_context hyps) in
- Proofview.Refine.refine begin fun sigma ->
- let (sigma, ev) =
+ Proofview.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)))
- end
- end
+ Sigma (mkApp (ev, args), sigma, p)
+ end }
+ end }
let revert hyps =
- Proofview.Goal.enter begin fun gl ->
+ 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) <*> (Proofview.V82.tactic (clear hyps))
- end
+ end }
(* Compute a name for a generalization *)
@@ -2530,9 +2564,9 @@ let generalize_goal_gen env ids i ((occs,c,b),na) t (cl,evd) =
mkProd_or_LetIn (na,b,t) cl', evd'
let generalize_goal gl i ((occs,c,b),na as o) cl =
- let t = pf_unsafe_type_of gl c in
- let env = pf_env gl in
- generalize_goal_gen env (pf_ids_of_hyps gl) i o t cl
+ let t = Tacmach.pf_unsafe_type_of gl c in
+ let env = Tacmach.pf_env gl in
+ generalize_goal_gen env (Tacmach.pf_ids_of_hyps gl) i o t cl
let generalize_dep ?(with_let=false) c gl =
let env = pf_env gl in
@@ -2554,11 +2588,11 @@ let generalize_dep ?(with_let=false) c gl =
-> id::tothin
| _ -> tothin
in
- let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify 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 -> pi2 (pf_get_hyp gl id)
+ | Var id -> pi2 (Tacmach.pf_get_hyp gl id)
| _ -> None
else None
in
@@ -2575,17 +2609,17 @@ let generalize_dep ?(with_let=false) c gl =
let generalize_gen_let lconstr gl =
let newcl, evd =
List.fold_right_i (generalize_goal gl) 0 lconstr
- (pf_concl gl,project gl)
+ (Tacmach.pf_concl gl,Tacmach.project gl)
in
tclTHEN (tclEVARS evd)
(apply_type newcl (List.map_filter (fun ((_,c,b),_) ->
if Option.is_empty b then Some c else None) lconstr)) gl
let new_generalize_gen_let lconstr =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
let gl = Proofview.Goal.assume gl in
let concl = Proofview.Goal.concl gl in
- let sigma = Proofview.Goal.sigma 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 =
@@ -2596,12 +2630,14 @@ let new_generalize_gen_let lconstr =
generalize_goal_gen env ids i o t cl, args)
0 lconstr ((concl, sigma), [])
in
- Proofview.Unsafe.tclEVARS sigma <*>
- Proofview.Refine.refine begin fun sigma ->
- let (sigma, ev) = Evarutil.new_evar env sigma newcl in
- (sigma, (applist (ev, args)))
- end
- end
+ let tac =
+ Proofview.Refine.refine { run = begin fun sigma ->
+ let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma 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) ->
@@ -2695,7 +2731,7 @@ let check_unused_names names =
(str"Unused introduction " ++ str (String.plural (List.length names) "pattern")
++ str": " ++ prlist_with_sep spc
(Miscprint.pr_intro_pattern
- (fun c -> Printer.pr_constr (snd (c (Global.env()) Evd.empty)))) names)
+ (fun c -> Printer.pr_constr (fst (run_delayed (Global.env()) Evd.empty c)))) names)
let intropattern_of_name gl avoid = function
| Anonymous -> IntroNaming IntroAnonymous
@@ -2775,7 +2811,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names =
match ra with
| (RecArg,deprec,recvarname) ::
(IndArg,depind,hyprecname) :: ra' ->
- Proofview.Goal.enter begin fun gl ->
+ 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
@@ -2783,37 +2819,37 @@ let induct_discharge dests avoid' tac (avoid,ra) names =
| _ -> consume_pattern avoid (Name recvarname) deprec gl names in
let dest = get_recarg_dest dests in
dest_intro_patterns avoid thin dest [recpat] (fun ids thin ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let (hyprec,names) =
consume_pattern avoid (Name hyprecname) depind gl names
in
dest_intro_patterns avoid thin MoveLast [hyprec] (fun ids' thin ->
peel_tac ra' (update_dest dests ids') names thin)
- end)
- end
+ end })
+ end }
| (IndArg,dep,hyprecname) :: ra' ->
- Proofview.Goal.enter begin fun gl ->
+ 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 avoid thin MoveLast [pat] (fun ids thin ->
peel_tac ra' (update_dest dests ids) names thin)
- end
+ end }
| (RecArg,dep,recvarname) :: ra' ->
- Proofview.Goal.enter begin fun gl ->
+ 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 avoid thin dest [pat] (fun ids thin ->
peel_tac ra' dests names thin)
- end
+ end }
| (OtherArg,dep,_) :: ra' ->
- Proofview.Goal.enter begin fun gl ->
+ 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 avoid thin dest [pat] (fun ids thin ->
peel_tac ra' dests names thin)
- end
+ end }
| [] ->
check_unused_names names;
Tacticals.New.tclTHEN (clear_wildcards thin) (tac dests)
@@ -2827,7 +2863,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names =
(* Marche pas... faut prendre en compte l'occurrence précise... *)
let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac =
- Proofview.Goal.enter begin fun gl ->
+ 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
@@ -2876,7 +2912,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac =
(atomize_one (i-1) (mkVar x::args) (x::avoid))
in
atomize_one (List.length argl) [] []
- end
+ end }
(* [cook_sign] builds the lists [beforetoclear] (preceding the
ind. var.) and [aftertoclear] (coming after the ind. var.) of hyps
@@ -3187,11 +3223,11 @@ let mk_term_eq env sigma ty t ty' t' =
let make_abstract_generalize gl id concl dep ctx body c eqs args refls =
let meta = Evarutil.new_meta() in
let eqslen = List.length eqs in
- let term, typ = mkVar id, pf_get_hyp_typ gl id in
+ let term, typ = mkVar id, Tacmach.pf_get_hyp_typ gl id 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 (pf_env gl)) (project gl) (lift 1 c) (mkRel 1) typ term in
+ let eq, refl = mk_term_eq (push_rel_context ctx (Tacmach.pf_env gl)) (Tacmach.project gl) (lift 1 c) (mkRel 1) typ term in
mkProd (Anonymous, eq, lift 1 concl), [| refl |]
else concl, [||]
in
@@ -3252,9 +3288,9 @@ let is_defined_variable env id = match lookup_named id env with
| (_, Some _, _) -> true
let abstract_args gl generalize_vars dep id defined f args =
- let sigma = project gl in
- let env = pf_env gl in
- let concl = pf_concl gl in
+ let sigma = 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 =
@@ -3272,7 +3308,7 @@ let abstract_args gl generalize_vars dep id defined f args =
let rel, c = Reductionops.splay_prod_n env sigma 1 prod in
List.hd rel, c
in
- let argty = pf_unsafe_type_of gl arg in
+ let argty = Tacmach.pf_unsafe_type_of gl arg in
let ty = (* refresh_universes_strict *) ty in
let lenctx = List.length ctx in
let liftargty = lift lenctx argty in
@@ -3313,7 +3349,7 @@ let abstract_args gl generalize_vars dep id defined f args =
in
if dogen then
let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env =
- Array.fold_left aux (pf_unsafe_type_of gl f',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args'
+ Array.fold_left aux (Tacmach.pf_unsafe_type_of gl f',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args'
in
let args, refls = List.rev args, List.rev refls in
let vars =
@@ -3322,13 +3358,13 @@ let abstract_args gl generalize_vars dep id defined f args =
hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars
else []
in
- let body, c' = if defined then Some c', typ_of ctxenv Evd.empty c' else None, c' in
+ let body, c' = if defined then Some c', Retyping.get_type_of ctxenv Evd.empty c' else None, c' in
Some (make_abstract_generalize gl id concl dep ctx body c' eqs args refls,
dep, succ (List.length ctx), vars)
else None
let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id =
- Proofview.Goal.nf_enter begin fun gl ->
+ 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
@@ -3360,15 +3396,15 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id =
[revert vars ;
Proofview.V82.tactic (fun gl -> tclMAP (fun id ->
tclTRY (generalize_dep ~with_let:true (mkVar id))) vars gl)])
- end
+ 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 env = pf_env gl in
- let ty = pf_get_hyp_typ gl id 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
@@ -3643,7 +3679,7 @@ let guess_elim isrec dep s hyp0 gl =
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
- Proofview.Goal.sigma gl, (e, Tacmach.New.pf_unsafe_type_of gl elimc), ind_type_guess
+ 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 * Id.t) list) array
@@ -3688,7 +3724,7 @@ let is_functional_induction elimc gl =
let get_eliminator elim dep s gl = match elim with
| ElimUsing (elim,indsign) ->
- Proofview.Goal.sigma gl, (* bugged, should be computed *) true, 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
@@ -3711,10 +3747,10 @@ let recolle_clenv i params args elimclause gl =
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 gl id , lindmv.(i))
+ List.map_i (fun i id -> mkVar id , Tacmach.pf_get_hyp_typ gl id , lindmv.(i))
0 params in
let clauses_args =
- List.map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(k+i))
+ List.map_i (fun i id -> mkVar id , Tacmach.pf_get_hyp_typ gl id , lindmv.(k+i))
0 args in
let clauses = clauses_params@clauses_args in
(* iteration of clenv_fchain with all infos we have. *)
@@ -3741,7 +3777,7 @@ let induction_tac with_evars params indvars elim gl =
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
+ Tacmach.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?) *)
@@ -3753,9 +3789,9 @@ let induction_tac with_evars params indvars elim gl =
induction applies with the induction hypotheses *)
let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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 = cook_sign hyp0 inhyps indvars env in
let dep = dep || Option.cata (fun id -> occur_var env id concl) false hyp0 in
@@ -3766,9 +3802,9 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac =
(fun a (id,b,_) -> if Option.is_empty b then (mkVar id)::a else a) [] deps in
let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in
let names = compute_induction_names (Array.length indsign) names in
+ let tac =
(if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn)
(Tacticals.New.tclTHENLIST [
- Proofview.Unsafe.tclEVARS sigma;
(* Generalize dependent hyps (but not args) *)
if deps = [] then Proofview.tclUNIT () else Proofview.V82.tactic (apply_type tmpcl deps_cstr);
(* side-conditions in elim (resp case) schemes come last (resp first) *)
@@ -3778,15 +3814,17 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac =
(Array.map2
(induct_discharge lhyp0 avoid (re_intro_dependent_hypotheses statuslists))
indsign names)
- end
+ 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 begin fun gl ->
+ 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 (Some hyp0) inhyps (pi3 elim_info) indvars names
(fun elim -> Proofview.V82.tactic (induction_tac with_evars [] [hyp0] elim)))
- end
+ end }
let msg_not_right_number_induction_arguments scheme =
str"Not the right number of induction arguments (expected " ++
@@ -3803,7 +3841,7 @@ let msg_not_right_number_induction_arguments scheme =
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 begin fun gl ->
+ 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
@@ -3834,11 +3872,11 @@ let induction_without_atomization isrec with_evars elim names lid =
]) in
let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in
apply_induction_in_context None [] elim indvars names induct_tac
- end
+ end }
(* assume that no occurrences are selected *)
let clear_unselected_context id inhyps cls gl =
- if occur_var (pf_env gl) id (pf_concl gl) &&
+ if occur_var (Tacmach.pf_env gl) id (Tacmach.pf_concl gl) &&
cls.concl_occs == NoOccurrences
then errorlabstrm ""
(str "Conclusion must be mentioned: it depends on " ++ pr_id id
@@ -3856,6 +3894,7 @@ let clear_unselected_context id inhyps cls gl =
| None -> tclIDTAC gl
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
@@ -3877,7 +3916,8 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ =
if must_be_closed && occur_meta (clenv_value indclause) then
error "Need a fully applied argument.";
(* We lose the possibility of coercions in with-bindings *)
- pose_all_metas_as_evars env indclause.evd (clenv_value indclause)
+ 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
@@ -3895,6 +3935,7 @@ let check_expected_type env sigma (elimc,bl) elimt =
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 ->
@@ -3902,7 +3943,7 @@ let check_enough_applied env sigma elim =
fun u ->
let t,_ = decompose_app (whd_betadeltaiota env sigma u) in isInd t
| Some elimc ->
- let elimt = typ_of env sigma (fst elimc) in
+ let elimt = Retyping.get_type_of env sigma (fst elimc) in
let scheme = compute_elim_sig ~elimc elimt in
match scheme.indref with
| None ->
@@ -3915,13 +3956,12 @@ let check_enough_applied env sigma elim =
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.enter begin fun gl ->
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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) = use_bindings env sigma elim false (c0,lbind) t0 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
@@ -3931,7 +3971,8 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim
(* 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) = finish_evar_resolution ~flags env sigma (pending,c0) 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
@@ -3939,12 +3980,13 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim
(* and destruct has side conditions first *)
Tacticals.New.tclTHENLAST)
(Tacticals.New.tclTHENLIST [
- Proofview.Unsafe.tclEVARS sigma;
- Proofview.Refine.refine ~unsafe:true (fun sigma ->
+ Proofview.Refine.refine ~unsafe:true { run = begin fun sigma ->
let b = not with_evars && with_eq != None in
- let (sigma,c) = use_bindings env sigma elim b (c0,lbind) t0 in
- let t = Retyping.get_type_of env sigma c in
- mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t));
+ 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 };
Proofview.(if with_evars then shelve_unifiable else guard_no_unifiable);
if is_arg_pure_hyp
then Tacticals.New.tclTRY (Proofview.V82.tactic (thin [destVar c0]))
@@ -3952,19 +3994,24 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim
if isrec then Proofview.cycle (-1) else Proofview.tclUNIT ()
])
tac
+ in
+ Sigma (tac, sigma, q)
- | Some (sigma',c) ->
+ | 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 [
- Proofview.Unsafe.tclEVARS sigma';
- Proofview.Refine.refine ~unsafe:true (fun sigma ->
- mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None);
+ Proofview.Refine.refine ~unsafe:true { run = begin fun sigma ->
+ mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None
+ end };
tac
]
- end
+ in
+ Sigma (tac, sigma', p +> q)
+ end }
let has_generic_occurrences_but_goal cls id env ccl =
clause_with_generic_context_selection cls &&
@@ -3976,11 +4023,12 @@ let induction_gen clear_flag isrec with_evars elim
let inhyps = match cls with
| Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps
| _ -> [] in
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let ccl = Proofview.Goal.raw_concl gl in
let cls = Option.default allHypsAndConcl cls in
+ let sigma = Sigma.Unsafe.of_evar_map sigma in
let t = typ_of env sigma c in
let is_arg_pure_hyp =
isVar c && not (mem_named_context (destVar c) (Global.named_context()))
@@ -4011,7 +4059,7 @@ let induction_gen clear_flag isrec with_evars elim
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
+ end }
(* Induction on a list of arguments. First make induction arguments
atomic (using letins), then do induction. The specificity here is
@@ -4036,7 +4084,7 @@ let induction_gen_l isrec with_evars elim names lc =
atomize_list l'
| _ ->
- Proofview.Goal.enter begin fun gl ->
+ 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
@@ -4047,7 +4095,7 @@ let induction_gen_l isrec with_evars elim names lc =
Tacticals.New.tclTHEN
(letin_tac None (Name id) c None allHypsAndConcl)
(atomize_list newl')
- end in
+ end } in
Tacticals.New.tclTHENLIST
[
(atomize_list lc);
@@ -4064,18 +4112,21 @@ 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 begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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 finish_evar_resolution f =
- let (sigma',(c,lbind)) = f env sigma in
+ let ((c, lbind), sigma') = run_delayed env sigma f in
let pending = (sigma,sigma') in
- snd (finish_evar_resolution env sigma' (pending,c)),lbind in
+ let sigma' = Sigma.Unsafe.of_evar_map sigma' in
+ let Sigma (c, _, _) = finish_evar_resolution env sigma' (pending,c) in
+ (c, lbind)
+ in
let c = map_induction_arg finish_evar_resolution c in
onInductionArg
(fun _clear_flag (c,lbind) ->
@@ -4086,11 +4137,11 @@ let induction_destruct isrec with_evars (lc,elim) =
(* standard induction *)
onOpenInductionArg env sigma
(fun clear_flag c -> induction_gen clear_flag isrec with_evars elim (c,allnames) cls) c
- end
+ end }
| _ ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
match elim with
| None ->
(* Several arguments, without "using" clause *)
@@ -4104,20 +4155,23 @@ let induction_destruct isrec with_evars (lc,elim) =
(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 begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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)
+ end }) l)
| Some elim ->
(* Several induction hyps with induction scheme *)
let finish_evar_resolution f =
- let (sigma',(c,lbind)) = f env sigma in
+ let ((c, lbind), sigma') = run_delayed env sigma f in
let pending = (sigma,sigma') in
if lbind != NoBindings then
error "'with' clause not supported here.";
- snd (finish_evar_resolution env sigma' (pending,c)) in
+ let sigma' = Sigma.Unsafe.of_evar_map sigma' in
+ let Sigma (c, _, _) = finish_evar_resolution env sigma' (pending,c) in
+ c
+ in
let lc = List.map (on_pi1 (map_induction_arg finish_evar_resolution)) lc in
let newlc =
List.map (fun (x,(eqn,names),cls) ->
@@ -4134,7 +4188,7 @@ let induction_destruct isrec with_evars (lc,elim) =
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
+ end }
let induction ev clr c l e =
induction_gen clr true ev e
@@ -4176,7 +4230,7 @@ let simple_destruct = function
*)
let elim_scheme_type elim t =
- Proofview.Goal.nf_enter begin fun gl ->
+ 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 ->
@@ -4186,23 +4240,23 @@ let elim_scheme_type elim 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
+ end }
let elim_type t =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
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
- Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t)
- end
+ Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd)
+ end }
let case_type t =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.s_enter { s_enter = begin fun gl sigma ->
let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in
let evd, elimc =
Tacmach.New.pf_apply build_case_analysis_scheme_default gl ind (Tacticals.New.elimination_sort_of_goal gl)
in
- Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t)
- end
+ Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd)
+ end }
(************************************************)
@@ -4215,14 +4269,14 @@ 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 = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
if not allowred then concl
else
let env = Proofview.Goal.env gl in
whd_betadeltaiota env sigma concl
let reflexivity_red allowred =
- Proofview.Goal.enter begin fun gl ->
+ 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). *)
@@ -4230,7 +4284,7 @@ let reflexivity_red allowred =
match match_with_equality_type concl with
| None -> Proofview.tclZERO NoEquationFound
| Some _ -> one_constructor 1 NoBindings
- end
+ end }
let reflexivity =
Proofview.tclORELSE
@@ -4272,7 +4326,7 @@ let match_with_equation c =
Proofview.tclZERO NoEquationFound
let symmetry_red allowred =
- Proofview.Goal.enter begin fun gl ->
+ 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). *)
@@ -4284,7 +4338,7 @@ let symmetry_red allowred =
(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
+ end }
let symmetry =
Proofview.tclORELSE
@@ -4298,7 +4352,7 @@ let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make ()
let symmetry_in id =
- Proofview.Goal.enter begin fun gl ->
+ 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
@@ -4316,7 +4370,7 @@ let symmetry_in id =
| NoEquationFound -> Hook.get forward_setoid_symmetry_in id
| e -> Proofview.tclZERO ~info e
end
- end
+ end }
let intros_symmetry =
Tacticals.New.onClause
@@ -4341,7 +4395,7 @@ 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 begin fun gl ->
+ 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 |])
@@ -4349,7 +4403,7 @@ let prove_transitivity hdcncl eq_kind t =
mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |])
| HeterogenousEq (typ1,c1,typ2,c2) ->
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma 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 |]),
@@ -4361,10 +4415,10 @@ let prove_transitivity hdcncl eq_kind t =
[ Tacticals.New.tclDO 2 intro;
Tacticals.New.onLastHyp simplest_case;
assumption ]))
- end
+ end }
let transitivity_red allowred t =
- Proofview.Goal.enter begin fun gl ->
+ 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). *)
@@ -4381,7 +4435,7 @@ let transitivity_red allowred t =
match t with
| None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.")
| Some t -> prove_transitivity eq eq_kind t
- end
+ end }
let transitivity_gen t =
Proofview.tclORELSE
@@ -4407,14 +4461,58 @@ let interpretable_as_section_decl evd d1 d2 = match d2,d1 with
e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2
| (_,None,t1), (_,_,t2) -> e_eq_constr_univs evd t1 t2
+let rec decompose len c t accu =
+ 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 ((na, None, u) :: accu)
+ | LetIn (na, b, u, c), LetIn (_, _, _, t) ->
+ decompose (pred len) c t ((na, Some b, u) :: accu)
+ | _ -> assert false
+
+let rec shrink ctx sign c t accu = match ctx, sign with
+| [], [] -> (c, t, accu)
+| p :: ctx, (id, _, _) :: sign ->
+ if noccurn 1 c 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 = match p with
+ | (_, None, _) -> mkVar id :: accu
+ | (_, Some _, _) -> 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
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma ->
let current_sign = Global.named_context()
and global_sign = Proofview.Goal.hyps gl in
- let evdref = ref (Proofview.Goal.sigma gl) in
+ let sigma = Sigma.to_evar_map sigma in
+ let evdref = ref sigma in
let sign,secsign =
List.fold_right
(fun (id,_,_ as d) (s1,s2) ->
@@ -4448,6 +4546,10 @@ let abstract_subproof id gk tac =
let (_, info) = Errors.push src in
iraise (e, info)
in
+ let const, args =
+ if !shrink_abstract then shrink_entry sign const
+ else (const, List.rev (instance_from_named_context sign))
+ in
let cd = Entries.DefinitionEntry const in
let decl = (cd, IsProof Lemma) in
(** ppedrot: seems legit to have abstracted subproofs as local*)
@@ -4459,14 +4561,13 @@ let abstract_subproof id gk tac =
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 args = List.rev (instance_from_named_context sign) in
let solve =
- Proofview.Unsafe.tclEVARS evd <*>
Proofview.tclEFFECTS effs <*>
new_exact_no_check (applist (lem, args))
in
- if not safe then Proofview.mark_as_unsafe <*> solve else solve
- end
+ 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"
@@ -4486,7 +4587,7 @@ let tclABSTRACT name_op tac =
abstract_subproof s gk tac
let unify ?(state=full_transparent_state) x y =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma ->
try
let core_flags =
{ (default_unify_flags ()).core_unify_flags with
@@ -4498,10 +4599,12 @@ let unify ?(state=full_transparent_state) x y =
merge_unify_flags = core_flags;
subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } }
in
- let evd = w_unify (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) Reduction.CONV ~flags x y
- in Proofview.Unsafe.tclEVARS evd
- with e when Errors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Not unifiable")
- end
+ 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 Errors.noncritical e ->
+ Sigma.here (Tacticals.New.tclFAIL 0 (str"Not unifiable")) sigma
+ end }
module Simple = struct
(** Simplified version of some of the above tactics *)
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index ade89fc98..d62d27ca3 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -205,6 +205,8 @@ val apply_delayed_in :
(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. } *)
(*
@@ -430,7 +432,7 @@ end
module New : sig
- val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map*constr) -> unit Proofview.tactic
+ val refine : ?unsafe:bool -> constr Sigma.run -> unit Proofview.tactic
(** [refine ?unsafe c] is [Proofview.Refine.refine ?unsafe c]
followed by beta-iota-reduction of the conclusion. *)
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index b4c7bffa9..9bee7ab3e 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -18,6 +18,7 @@ open Tacinterp
open Tactics
open Errors
open Util
+open Proofview.Notations
DECLARE PLUGIN "tauto"
@@ -159,6 +160,8 @@ let flatten_contravariant_conj flags ist =
let constructor i =
let name = { Tacexpr.mltac_plugin = "coretactics"; mltac_tactic = "constructor" } in
+ (** Take care of the index: this is the second entry in constructor. *)
+ let name = { Tacexpr.mltac_name = name; mltac_index = 1 } in
let i = in_gen (rawwit Constrarg.wit_int_or_var) (Misctypes.ArgArg i) in
Tacexpr.TacML (Loc.ghost, name, [i])
@@ -303,13 +306,13 @@ let reduction_not_iff _ist =
let t_reduction_not_iff = tacticIn reduction_not_iff
let intuition_gen ist flags tac =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let tac = Value.of_closure ist tac in
let env = Proofview.Goal.env gl in
let vars, ist, intuition = tauto_intuit flags t_reduction_not_iff tac in
let glb_intuition = Tacintern.glob_tactic_env vars env intuition in
eval_tactic_ist ist glb_intuition
- end
+ end }
let tauto_intuitionistic flags =
Proofview.tclORELSE
diff --git a/test-suite/bugs/closed/3911.v b/test-suite/bugs/closed/3911.v
new file mode 100644
index 000000000..b289eafbf
--- /dev/null
+++ b/test-suite/bugs/closed/3911.v
@@ -0,0 +1,26 @@
+(* Tested against coq ee596bc *)
+
+Set Nonrecursive Elimination Schemes.
+Set Primitive Projections.
+Set Universe Polymorphism.
+
+Record setoid := { base : Type }.
+
+Definition catdata (Obj Arr : Type) : Type := nat.
+ (* [nat] can be replaced by any other type, it seems,
+ without changing the error *)
+
+Record cat : Type :=
+ {
+ obj : setoid;
+ arr : Type;
+ dta : catdata (base obj) arr
+ }.
+
+Definition bcwa (C:cat) (B:setoid) :Type := nat.
+ (* As above, nothing special about [nat] here. *)
+
+Record temp {C}{B} (e:bcwa C B) :=
+ { fld : base (obj C) }.
+
+Print temp_rect.
diff --git a/test-suite/bugs/closed/3929.v b/test-suite/bugs/closed/3929.v
new file mode 100644
index 000000000..4031dcc45
--- /dev/null
+++ b/test-suite/bugs/closed/3929.v
@@ -0,0 +1,12 @@
+Goal True.
+evar (T:Type).
+pose (Z:=nat).
+let Tv:=eval cbv [T] in T in
+pose (x:=Tv).
+revert x.
+refine (_ : let x:=Z in True).
+let Zv:=eval cbv [Z] in Z in
+let Tv:=eval cbv [T] in T in
+constr_eq Zv Tv.
+Abort.
+
diff --git a/test-suite/bugs/closed/3957.v b/test-suite/bugs/closed/3957.v
new file mode 100644
index 000000000..e20a6e97f
--- /dev/null
+++ b/test-suite/bugs/closed/3957.v
@@ -0,0 +1,6 @@
+Ltac foo tac := tac.
+
+Goal True.
+Proof.
+foo subst.
+Admitted.
diff --git a/test-suite/bugs/opened/4214.v b/test-suite/bugs/closed/4214.v
index 3daf45213..d684e8cf4 100644
--- a/test-suite/bugs/opened/4214.v
+++ b/test-suite/bugs/closed/4214.v
@@ -2,4 +2,5 @@
Goal forall A (a b c : A), b = a -> b = c -> a = c.
intros.
subst.
-Fail reflexivity.
+reflexivity.
+Qed. \ No newline at end of file
diff --git a/test-suite/bugs/opened/3889.v b/test-suite/bugs/opened/3889.v
new file mode 100644
index 000000000..6b287324c
--- /dev/null
+++ b/test-suite/bugs/opened/3889.v
@@ -0,0 +1,11 @@
+Require Import Program.
+
+Inductive Even : nat -> Prop :=
+| evenO : Even O
+| evenS : forall n, Odd n -> Even (S n)
+with Odd : nat -> Prop :=
+| oddS : forall n, Even n -> Odd (S n).
+Axiom admit : forall {T}, T.
+Program Fixpoint doubleE {n} (e : Even n) : Even (2 * n) := admit
+with doubleO {n} (o : Odd n) : Odd (S (2 * n)) := _.
+Next Obligation of doubleE.
diff --git a/test-suite/bugs/opened/3890.v b/test-suite/bugs/opened/3890.v
new file mode 100644
index 000000000..f9ac9be2c
--- /dev/null
+++ b/test-suite/bugs/opened/3890.v
@@ -0,0 +1,18 @@
+Class Foo.
+Class Bar := b : Type.
+
+Instance foo : Foo := _.
+(* 1 subgoals, subgoal 1 (ID 4)
+
+ ============================
+ Foo *)
+
+Instance bar : Bar.
+exact Type.
+Defined.
+(* bar is defined *)
+
+About foo.
+(* foo not a defined object. *)
+
+Fail Defined.
diff --git a/test-suite/bugs/opened/3916.v b/test-suite/bugs/opened/3916.v
new file mode 100644
index 000000000..fd95503e6
--- /dev/null
+++ b/test-suite/bugs/opened/3916.v
@@ -0,0 +1,3 @@
+Require Import List.
+
+Fail Hint Resolve -> in_map. (* Also happens when using <- instead of -> *)
diff --git a/test-suite/bugs/opened/3919.v-disabled b/test-suite/bugs/opened/3919.v-disabled
new file mode 100644
index 000000000..0d661de9c
--- /dev/null
+++ b/test-suite/bugs/opened/3919.v-disabled
@@ -0,0 +1,13 @@
+Require Import MSets.
+Require Import Orders.
+
+Declare Module Signal : OrderedType.
+
+Module S := MSetAVL.Make(Signal).
+Module Sdec := Decide(S).
+Export Sdec.
+
+Hint Extern 0 (Signal.eq ?x ?y) => now symmetry.
+
+Goal forall o s, Signal.eq o s.
+Proof. fsetdec. Qed.
diff --git a/test-suite/bugs/opened/3922.v-disabled b/test-suite/bugs/opened/3922.v-disabled
new file mode 100644
index 000000000..ce4f509ca
--- /dev/null
+++ b/test-suite/bugs/opened/3922.v-disabled
@@ -0,0 +1,83 @@
+Set Universe Polymorphism.
+Notation Type0 := Set.
+
+Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}.
+
+Notation compose := (fun g f x => g (f x)).
+
+Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
+Open Scope function_scope.
+
+Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x)
+ := forall x:A, f x = g x.
+
+Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.
+
+Class Contr_internal (A : Type) := BuildContr {
+ center : A ;
+ contr : (forall y : A, center = y)
+}.
+
+Inductive trunc_index : Type :=
+| minus_two : trunc_index
+| trunc_S : trunc_index -> trunc_index.
+
+Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope.
+Local Open Scope trunc_scope.
+Notation "-2" := minus_two (at level 0) : trunc_scope.
+Notation "-1" := (-2.+1) (at level 0) : trunc_scope.
+
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+ match n with
+ | -2 => Contr_internal A
+ | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y)
+ end.
+
+Class IsTrunc (n : trunc_index) (A : Type) : Type :=
+ Trunc_is_trunc : IsTrunc_internal n A.
+
+Notation Contr := (IsTrunc -2).
+Notation IsHProp := (IsTrunc -1).
+
+Monomorphic Axiom dummy_funext_type : Type0.
+Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }.
+
+Inductive Unit : Type1 :=
+ tt : Unit.
+
+Record TruncType (n : trunc_index) := BuildTruncType {
+ trunctype_type : Type ;
+ istrunc_trunctype_type : IsTrunc n trunctype_type
+}.
+
+Arguments BuildTruncType _ _ {_}.
+
+Coercion trunctype_type : TruncType >-> Sortclass.
+
+Notation "n -Type" := (TruncType n) (at level 1) : type_scope.
+Notation hProp := (-1)-Type.
+
+Notation BuildhProp := (BuildTruncType -1).
+
+Private Inductive Trunc (n : trunc_index) (A :Type) : Type :=
+ tr : A -> Trunc n A.
+Arguments tr {n A} a.
+
+Global Instance istrunc_truncation (n : trunc_index) (A : Type@{i})
+: IsTrunc@{j} n (Trunc@{i} n A).
+Admitted.
+
+Definition Trunc_ind {n A}
+ (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)}
+ : (forall a, P (tr a)) -> (forall aa, P aa)
+:= (fun f aa => match aa with tr a => fun _ => f a end Pt).
+Definition merely (A : Type@{i}) : hProp@{i} := BuildhProp (Trunc -1 A).
+Definition cconst_factors_contr `{Funext} {X Y : Type} (f : X -> Y)
+ (P : Type) `{Pc : X -> Contr P}
+ (g : X -> P) (h : P -> Y) (p : h o g == f)
+: Unit.
+Proof.
+ assert (merely X -> IsHProp P) by admit.
+ refine (let g' := Trunc_ind (fun _ => P) g : merely X -> P in _);
+ [ assumption.. | ].
+ Fail pose (g' := Trunc_ind (fun _ => P) g : merely X -> P).
diff --git a/test-suite/bugs/opened/3923.v b/test-suite/bugs/opened/3923.v
new file mode 100644
index 000000000..6aa6b4932
--- /dev/null
+++ b/test-suite/bugs/opened/3923.v
@@ -0,0 +1,33 @@
+Module Type TRIVIAL.
+Parameter t:Type.
+End TRIVIAL.
+
+Module MkStore (Key : TRIVIAL).
+
+Module St : TRIVIAL.
+Definition t := unit.
+End St.
+
+End MkStore.
+
+
+
+Module Type CERTRUNTIMETYPES (B : TRIVIAL).
+
+Parameter cert_fieldstore : Type.
+Parameter empty_fieldstore : cert_fieldstore.
+
+End CERTRUNTIMETYPES.
+
+
+
+Module MkCertRuntimeTypes (B : TRIVIAL) : CERTRUNTIMETYPES B.
+
+Module FieldStore := MkStore B.
+
+Definition cert_fieldstore := FieldStore.St.t.
+Axiom empty_fieldstore : cert_fieldstore.
+
+End MkCertRuntimeTypes.
+
+Fail Extraction MkCertRuntimeTypes.
diff --git a/test-suite/bugs/opened/3926.v b/test-suite/bugs/opened/3926.v
new file mode 100644
index 000000000..cfad76357
--- /dev/null
+++ b/test-suite/bugs/opened/3926.v
@@ -0,0 +1,30 @@
+Notation compose := (fun g f x => g (f x)).
+Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
+Open Scope function_scope.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end.
+Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope.
+Local Open Scope equiv_scope.
+Axiom eisretr : forall {A B} (f : A -> B) `{IsEquiv A B f} x, f (f^-1 x) = x.
+Generalizable Variables A B C f g.
+Global Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} : IsEquiv (compose g f) | 1000
+ := Build_IsEquiv A C (compose g f) (compose f^-1 g^-1).
+Definition isequiv_homotopic {A B} (f : A -> B) {g : A -> B} `{IsEquiv A B f} (h : forall x, f x = g x) : IsEquiv g
+ := Build_IsEquiv _ _ g (f ^-1).
+Global Instance isequiv_inverse {A B} (f : A -> B) `{IsEquiv A B f} : IsEquiv f^-1 | 10000
+ := Build_IsEquiv B A f^-1 f.
+Definition cancelR_isequiv {A B C} (f : A -> B) {g : B -> C}
+ `{IsEquiv A B f} `{IsEquiv A C (g o f)}
+ : IsEquiv g.
+Proof.
+ Unset Typeclasses Modulo Eta.
+ exact (isequiv_homotopic (compose (compose g f) f^-1)
+ (fun b => ap g (eisretr f b))) || fail "too early".
+ Undo.
+ Set Typeclasses Modulo Eta.
+ Set Typeclasses Dependency Order.
+ Set Typeclasses Debug.
+ Fail exact (isequiv_homotopic (compose (compose g f) f^-1)
+ (fun b => ap g (eisretr f b))).
diff --git a/test-suite/bugs/opened/3928.v-disabled b/test-suite/bugs/opened/3928.v-disabled
new file mode 100644
index 000000000..b470eb229
--- /dev/null
+++ b/test-suite/bugs/opened/3928.v-disabled
@@ -0,0 +1,12 @@
+Typeclasses eauto := bfs.
+
+Class Foo := {}.
+Class Bar := {}.
+
+Instance: Bar.
+Instance: Foo -> Bar -> Foo -> Foo | 1.
+Instance: Bar -> Foo | 100.
+Instance: Foo -> Bar -> Foo -> Foo | 1.
+
+Set Typeclasses Debug.
+Timeout 1 Check (_ : Foo). (* timeout *)
diff --git a/test-suite/bugs/opened/3938.v b/test-suite/bugs/opened/3938.v
new file mode 100644
index 000000000..2d0d1930f
--- /dev/null
+++ b/test-suite/bugs/opened/3938.v
@@ -0,0 +1,6 @@
+Require Import Coq.Arith.PeanoNat.
+Hint Extern 1 => admit : typeclass_instances.
+Goal forall a b (f : nat -> Set), Nat.eq a b -> f a = f b.
+ intros a b f H.
+ rewrite H. (* Toplevel input, characters 15-25:
+Anomaly: Evar ?X11 was not declared. Please report. *)
diff --git a/test-suite/bugs/opened/3946.v b/test-suite/bugs/opened/3946.v
new file mode 100644
index 000000000..e77bdbc65
--- /dev/null
+++ b/test-suite/bugs/opened/3946.v
@@ -0,0 +1,11 @@
+Require Import ZArith.
+
+Inductive foo := Foo : Z.le 0 1 -> foo.
+
+Definition bar (f : foo) := let (f) := f in f.
+
+(* Doesn't work: *)
+(* Arguments bar f.*)
+
+(* Does work *)
+Arguments bar f _.
diff --git a/test-suite/bugs/opened/3948.v b/test-suite/bugs/opened/3948.v
new file mode 100644
index 000000000..165813084
--- /dev/null
+++ b/test-suite/bugs/opened/3948.v
@@ -0,0 +1,25 @@
+Module Type S.
+Parameter t : Type.
+End S.
+
+Module Bar(X : S).
+Proof.
+ Definition elt := X.t.
+ Axiom fold : elt.
+End Bar.
+
+Module Make (X: S) := Bar(X).
+
+Declare Module X : S.
+
+Module Type Interface.
+ Parameter constant : unit.
+End Interface.
+
+Module DepMap : Interface.
+ Module Dom := Make(X).
+ Definition constant : unit :=
+ let _ := @Dom.fold in tt.
+End DepMap.
+
+Print Assumptions DepMap.constant. \ No newline at end of file
diff --git a/test-suite/failure/positivity.v b/test-suite/failure/positivity.v
index d44bccdfa..30762a77f 100644
--- a/test-suite/failure/positivity.v
+++ b/test-suite/failure/positivity.v
@@ -5,5 +5,47 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-Fail Inductive t : Set :=
- c : (t -> nat) -> t.
+
+(* Negative occurrence *)
+Fail Inductive t : Type :=
+ c : (t -> nat) -> t.
+
+(* Non-strictely positive occurrence *)
+Fail Inductive t : Type :=
+ c : ((t -> nat) -> nat) -> t.
+
+(* Self-nested type (no proof of
+ soundness yet *)
+Fail Inductive t (A:Type) : Type :=
+ c : t (t A) -> t A.
+
+(* Nested inductive types *)
+
+Inductive pos (A:Type) :=
+ p : pos A -> pos A.
+
+Inductive nnpos (A:Type) :=
+ nnp : ((A -> nat) -> nat) -> nnpos A.
+
+Inductive neg (A:Type) :=
+ n : (A->neg A) -> neg A.
+
+Inductive arg : Type -> Prop :=
+ a : forall A, arg A -> arg A.
+
+(* Strictly covariant parameter: accepted. *)
+Fail Fail Inductive t :=
+ c : pos t -> t.
+
+(* Non-strictly covariant parameter: not
+ strictly positive. *)
+Fail Inductive t :=
+ c : nnpos t -> t.
+
+(* Contravariant parameter: not positive. *)
+Fail Inductive t :=
+ c : neg t -> t.
+
+(* Strict index: not positive. *)
+Fail Inductive t :=
+ c : arg t -> t.
diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v
index 30a2a7429..d6e590af3 100644
--- a/test-suite/success/Typeclasses.v
+++ b/test-suite/success/Typeclasses.v
@@ -57,4 +57,25 @@ Section sec.
let's try to get rid of the intermediate constant foo.
Surely we can just expand it inline, right? Wrong!: *)
Check U (fun x => e x) _.
-End sec. \ No newline at end of file
+End sec.
+
+Module IterativeDeepening.
+
+ Class A.
+ Class B.
+ Class C.
+
+ Instance: B -> A | 0.
+ Instance: C -> A | 0.
+ Instance: C -> B -> A | 0.
+ Instance: A -> A | 0.
+
+ Goal C -> A.
+ intros.
+ Set Typeclasses Debug.
+ Fail Timeout 1 typeclasses eauto.
+ Set Typeclasses Iterative Deepening.
+ typeclasses eauto.
+ Qed.
+
+End IterativeDeepening.
diff --git a/test-suite/success/decl_mode2.v b/test-suite/success/decl_mode2.v
new file mode 100644
index 000000000..46174e481
--- /dev/null
+++ b/test-suite/success/decl_mode2.v
@@ -0,0 +1,249 @@
+Theorem this_is_trivial: True.
+proof.
+ thus thesis.
+end proof.
+Qed.
+
+Theorem T: (True /\ True) /\ True.
+ split. split.
+proof. (* first subgoal *)
+ thus thesis.
+end proof.
+trivial. (* second subgoal *)
+proof. (* third subgoal *)
+ thus thesis.
+end proof.
+Abort.
+
+Theorem this_is_not_so_trivial: False.
+proof.
+end proof. (* here a warning is issued *)
+Fail Qed. (* fails: the proof in incomplete *)
+Admitted. (* Oops! *)
+
+Theorem T: True.
+proof.
+escape.
+auto.
+return.
+Abort.
+
+Theorem T: let a:=false in let b:= true in ( if a then True else False -> if b then True else False).
+intros a b.
+proof.
+assume H:(if a then True else False).
+reconsider H as False.
+reconsider thesis as True.
+Abort.
+
+Theorem T: forall x, x=2 -> 2+x=4.
+proof.
+let x be such that H:(x=2).
+have H':(2+x=2+2) by H.
+Abort.
+
+Theorem T: forall x, x=2 -> 2+x=4.
+proof.
+let x be such that H:(x=2).
+then (2+x=2+2).
+Abort.
+
+Theorem T: forall x, x=2 -> x + x = x * x.
+proof.
+let x be such that H:(x=2).
+have (4 = 4).
+ ~= (2 * 2).
+ ~= (x * x) by H.
+ =~ (2 + 2).
+ =~ H':(x + x) by H.
+Abort.
+
+Theorem T: forall x, x + x = x * x -> x = 0 \/ x = 2.
+proof.
+let x be such that H:(x + x = x * x).
+claim H':((x - 2) * x = 0).
+thus thesis.
+end claim.
+Abort.
+
+Theorem T: forall (A B:Prop), A -> B -> A /\ B.
+intros A B HA HB.
+proof.
+hence B.
+Abort.
+
+Theorem T: forall (A B C:Prop), A -> B -> C -> A /\ B /\ C.
+intros A B C HA HB HC.
+proof.
+thus B by HB.
+Abort.
+
+Theorem T: forall (A B C:Prop), A -> B -> C -> A /\ B.
+intros A B C HA HB HC.
+proof.
+Fail hence C. (* fails *)
+Abort.
+
+Theorem T: forall (A B:Prop), B -> A \/ B.
+intros A B HB.
+proof.
+hence B.
+Abort.
+
+Theorem T: forall (A B C D:Prop), C -> D -> (A /\ B) \/ (C /\ D).
+intros A B C D HC HD.
+proof.
+thus C by HC.
+Abort.
+
+Theorem T: forall (P:nat -> Prop), P 2 -> exists x,P x.
+intros P HP.
+proof.
+take 2.
+Abort.
+
+Theorem T: forall (P:nat -> Prop), P 2 -> exists x,P x.
+intros P HP.
+proof.
+hence (P 2).
+Abort.
+
+Theorem T: forall (P:nat -> Prop) (R:nat -> nat -> Prop), P 2 -> R 0 2 -> exists x, exists y, P y /\ R x y.
+intros P R HP HR.
+proof.
+thus (P 2) by HP.
+Abort.
+
+Theorem T: forall (A B:Prop) (P:nat -> Prop), (forall x, P x -> B) -> A -> A /\ B.
+intros A B P HP HA.
+proof.
+suffices to have x such that HP':(P x) to show B by HP,HP'.
+Abort.
+
+Theorem T: forall (A:Prop) (P:nat -> Prop), P 2 -> A -> A /\ (forall x, x = 2 -> P x).
+intros A P HP HA.
+proof.
+(* BUG: the next line fails when it should succeed.
+Waiting for someone to investigate the bug.
+focus on (forall x, x = 2 -> P x).
+let x be such that (x = 2).
+hence thesis by HP.
+end focus.
+*)
+Abort.
+
+Theorem T: forall x, x = 0 -> x + x = x * x.
+proof.
+let x be such that H:(x = 0).
+define sqr x as (x * x).
+reconsider thesis as (x + x = sqr x).
+Abort.
+
+Theorem T: forall (P:nat -> Prop), forall x, P x -> P x.
+proof.
+let P:(nat -> Prop).
+let x:nat.
+assume HP:(P x).
+Abort.
+
+Theorem T: forall (P:nat -> Prop), forall x, P x -> P x.
+proof.
+let P:(nat -> Prop).
+Fail let x. (* fails because x's type is not clear *)
+let x be such that HP:(P x). (* here x's type is inferred from (P x) *)
+Abort.
+
+Theorem T: forall (P:nat -> Prop), forall x, P x -> P x -> P x.
+proof.
+let P:(nat -> Prop).
+let x:nat.
+assume (P x). (* temporary name created *)
+Abort.
+
+Theorem T: forall (P:nat -> Prop), forall x, P x -> P x.
+proof.
+let P:(nat -> Prop).
+let x be such that (P x). (* temporary name created *)
+Abort.
+
+Theorem T: forall (P:nat -> Prop) (A:Prop), (exists x, (P x /\ A)) -> A.
+proof.
+let P:(nat -> Prop),A:Prop be such that H:(exists x, P x /\ A).
+consider x such that HP:(P x) and HA:A from H.
+Abort.
+
+(* Here is an example with pairs: *)
+
+Theorem T: forall p:(nat * nat)%type, (fst p >= snd p) \/ (fst p < snd p).
+proof.
+let p:(nat * nat)%type.
+consider x:nat,y:nat from p.
+reconsider thesis as (x >= y \/ x < y).
+Abort.
+
+Theorem T: forall P:(nat -> Prop), (forall n, P n -> P (n - 1)) ->
+(exists m, P m) -> P 0.
+proof.
+let P:(nat -> Prop) be such that HP:(forall n, P n -> P (n - 1)).
+given m such that Hm:(P m).
+Abort.
+
+Theorem T: forall (A B C:Prop), (A -> C) -> (B -> C) -> (A \/ B) -> C.
+proof.
+let A:Prop,B:Prop,C:Prop be such that HAC:(A -> C) and HBC:(B -> C).
+assume HAB:(A \/ B).
+per cases on HAB.
+suppose A.
+ hence thesis by HAC.
+suppose HB:B.
+ thus thesis by HB,HBC.
+end cases.
+Abort.
+
+Section Coq.
+
+Hypothesis EM : forall P:Prop, P \/ ~ P.
+
+Theorem T: forall (A C:Prop), (A -> C) -> (~A -> C) -> C.
+proof.
+let A:Prop,C:Prop be such that HAC:(A -> C) and HNAC:(~A -> C).
+per cases of (A \/ ~A) by EM.
+suppose (~A).
+ hence thesis by HNAC.
+suppose A.
+ hence thesis by HAC.
+end cases.
+Abort.
+
+Theorem T: forall (A C:Prop), (A -> C) -> (~A -> C) -> C.
+proof.
+let A:Prop,C:Prop be such that HAC:(A -> C) and HNAC:(~A -> C).
+per cases on (EM A).
+suppose (~A).
+Abort.
+End Coq.
+
+Theorem T: forall (A B:Prop) (x:bool), (if x then A else B) -> A \/ B.
+proof.
+let A:Prop,B:Prop,x:bool.
+per cases on x.
+suppose it is true.
+ assume A.
+ hence A.
+suppose it is false.
+ assume B.
+ hence B.
+end cases.
+Abort.
+
+Theorem T: forall (n:nat), n + 0 = n.
+proof.
+let n:nat.
+per induction on n.
+suppose it is 0.
+ thus (0 + 0 = 0).
+suppose it is (S m) and H:thesis for m.
+ then (S (m + 0) = S m).
+ thus =~ (S m + 0).
+end induction.
+Abort. \ No newline at end of file
diff --git a/test-suite/success/shrink_abstract.v b/test-suite/success/shrink_abstract.v
new file mode 100644
index 000000000..3f6b9cb39
--- /dev/null
+++ b/test-suite/success/shrink_abstract.v
@@ -0,0 +1,13 @@
+Set Shrink Abstract.
+
+Definition foo : forall (n m : nat), bool.
+Proof.
+pose (p := 0).
+intros n.
+pose (q := n).
+intros m.
+pose (r := m).
+abstract (destruct m; [left|right]).
+Defined.
+
+Check (foo_subproof : nat -> bool).
diff --git a/test-suite/success/shrink_obligations.v b/test-suite/success/shrink_obligations.v
new file mode 100644
index 000000000..676b97878
--- /dev/null
+++ b/test-suite/success/shrink_obligations.v
@@ -0,0 +1,28 @@
+Require Program.
+
+Obligation Tactic := idtac.
+
+Set Shrink Obligations.
+
+Program Definition foo (m : nat) (p := S m) (n : nat) (q := S n) : unit :=
+let bar : {r | n < r} := _ in
+let qux : {r | p < r} := _ in
+let quz : m = n -> True := _ in
+tt.
+Next Obligation.
+intros m p n q.
+exists (S n); constructor.
+Qed.
+Next Obligation.
+intros m p n q.
+exists (S (S m)); constructor.
+Qed.
+Next Obligation.
+intros m p n q ? ? H.
+destruct H.
+constructor.
+Qed.
+
+Check (foo_obligation_1 : forall n, {r | n < r}).
+Check (foo_obligation_2 : forall m, {r | (S m) < r}).
+Check (foo_obligation_3 : forall m n, m = n -> True).
diff --git a/test-suite/success/subst.v b/test-suite/success/subst.v
new file mode 100644
index 000000000..8336f6a80
--- /dev/null
+++ b/test-suite/success/subst.v
@@ -0,0 +1,25 @@
+(* Test various subtleties of the "subst" tactics *)
+
+(* Should proceed from left to right (see #4222) *)
+Goal forall x y, x = y -> x = 3 -> y = 2 -> x = y.
+intros.
+subst.
+change (3 = 2) in H1.
+change (3 = 3).
+Abort.
+
+(* Should work with "x = y" and "x = t" equations (see #4214, failed in 8.4) *)
+Goal forall x y, x = y -> x = 3 -> x = y.
+intros.
+subst.
+change (3 = 3).
+Abort.
+
+(* Should substitute cycles once, until a recursive equation is obtained *)
+(* (failed in 8.4) *)
+Goal forall x y, x = S y -> y = S x -> x = y.
+intros.
+subst.
+change (y = S (S y)) in H0.
+change (S y = y).
+Abort.
diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v
index de615301d..aaffc0978 100644
--- a/theories/Init/Datatypes.v
+++ b/theories/Init/Datatypes.v
@@ -151,6 +151,7 @@ Inductive option (A:Type) : Type :=
| Some : A -> option A
| None : option A.
+Arguments Some {A} a.
Arguments None {A}.
Definition option_map (A B:Type) (f:A->B) (o : option A) : option B :=
@@ -225,6 +226,7 @@ Inductive list (A : Type) : Type :=
| cons : A -> list A -> list A.
Arguments nil {A}.
+Arguments cons {A} a l.
Infix "::" := cons (at level 60, right associativity) : list_scope.
Delimit Scope list_scope with list.
Bind Scope list_scope with list.
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index fe18686e2..45306caf0 100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -7,7 +7,7 @@
(************************************************************************)
Require Setoid.
-Require Import PeanoNat Le Gt Minus Bool.
+Require Import PeanoNat Le Gt Minus Bool Lt.
Set Implicit Arguments.
(* Set Universe Polymorphism. *)
@@ -1633,6 +1633,80 @@ Section Cutting.
end
end.
+ Lemma firstn_nil n: firstn n [] = [].
+ Proof. induction n; now simpl. Qed.
+
+ Lemma firstn_cons n a l: firstn (S n) (a::l) = a :: (firstn n l).
+ Proof. now simpl. Qed.
+
+ Lemma firstn_all l: firstn (length l) l = l.
+ Proof. induction l as [| ? ? H]; simpl; [reflexivity | now rewrite H]. Qed.
+
+ Lemma firstn_all2 n: forall (l:list A), (length l) <= n -> firstn n l = l.
+ Proof. induction n as [|k iHk].
+ - intro. inversion 1 as [H1|?].
+ rewrite (length_zero_iff_nil l) in H1. subst. now simpl.
+ - destruct l as [|x xs]; simpl.
+ * now reflexivity.
+ * simpl. intro H. apply Peano.le_S_n in H. f_equal. apply iHk, H.
+ Qed.
+
+ Lemma firstn_O l: firstn 0 l = [].
+ Proof. now simpl. Qed.
+
+ Lemma firstn_le_length n: forall l:list A, length (firstn n l) <= n.
+ Proof.
+ induction n as [|k iHk]; simpl; [auto | destruct l as [|x xs]; simpl].
+ - auto with arith.
+ - apply Peano.le_n_S, iHk.
+ Qed.
+
+ Lemma firstn_length_le: forall l:list A, forall n:nat,
+ n <= length l -> length (firstn n l) = n.
+ Proof. induction l as [|x xs Hrec].
+ - simpl. intros n H. apply le_n_0_eq in H. rewrite <- H. now simpl.
+ - destruct n.
+ * now simpl.
+ * simpl. intro H. apply le_S_n in H. now rewrite (Hrec n H).
+ Qed.
+
+ Lemma firstn_app n:
+ forall l1 l2,
+ firstn n (l1 ++ l2) = (firstn n l1) ++ (firstn (n - length l1) l2).
+ Proof. induction n as [|k iHk]; intros l1 l2.
+ - now simpl.
+ - destruct l1 as [|x xs].
+ * unfold firstn at 2, length. now rewrite 2!app_nil_l, <- minus_n_O.
+ * rewrite <- app_comm_cons. simpl. f_equal. apply iHk.
+ Qed.
+
+ Lemma firstn_app_2 n:
+ forall l1 l2,
+ firstn ((length l1) + n) (l1 ++ l2) = l1 ++ firstn n l2.
+ Proof. induction n as [| k iHk];intros l1 l2.
+ - unfold firstn at 2. rewrite <- plus_n_O, app_nil_r.
+ rewrite firstn_app. rewrite <- minus_diag_reverse.
+ unfold firstn at 2. rewrite app_nil_r. apply firstn_all.
+ - destruct l2 as [|x xs].
+ * simpl. rewrite app_nil_r. apply firstn_all2. auto with arith.
+ * rewrite firstn_app. assert (H0 : (length l1 + S k - length l1) = S k).
+ auto with arith.
+ rewrite H0, firstn_all2; [reflexivity | auto with arith].
+ Qed.
+
+ Lemma firstn_firstn:
+ forall l:list A,
+ forall i j : nat,
+ firstn i (firstn j l) = firstn (min i j) l.
+ Proof. induction l as [|x xs Hl].
+ - intros. simpl. now rewrite ?firstn_nil.
+ - destruct i.
+ * intro. now simpl.
+ * destruct j.
+ + now simpl.
+ + simpl. f_equal. apply Hl.
+ Qed.
+
Fixpoint skipn (n:nat)(l:list A) : list A :=
match n with
| 0 => l
diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v
index 0a0bf0dea..c8ed95cd4 100644
--- a/theories/Lists/ListSet.v
+++ b/theories/Lists/ListSet.v
@@ -48,7 +48,11 @@ Section first_definitions.
end
end.
- (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing *)
+ (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing.
+ Invariant: any element should occur at most once in [x], see for
+ instance [set_add]. We hence remove here only the first occurrence
+ of [a] in [x]. *)
+
Fixpoint set_remove (a:A) (x:set) : set :=
match x with
| nil => empty_set
@@ -227,6 +231,68 @@ Section first_definitions.
intros; elim (Aeq_dec a a0); intros; discriminate.
Qed.
+ Lemma set_add_iff a b l : In a (set_add b l) <-> a = b \/ In a l.
+ Proof.
+ split. apply set_add_elim. apply set_add_intro.
+ Qed.
+
+ Lemma set_add_nodup a l : NoDup l -> NoDup (set_add a l).
+ Proof.
+ induction 1 as [|x l H H' IH]; simpl.
+ - constructor; [ tauto | constructor ].
+ - destruct (Aeq_dec a x) as [<-|Hax]; constructor; trivial.
+ rewrite set_add_iff. intuition.
+ Qed.
+
+ Lemma set_remove_1 (a b : A) (l : set) :
+ In a (set_remove b l) -> In a l.
+ Proof.
+ induction l as [|x xs Hrec].
+ - intros. auto.
+ - simpl. destruct (Aeq_dec b x).
+ * tauto.
+ * intro H. destruct H.
+ + rewrite H. apply in_eq.
+ + apply in_cons. apply Hrec. assumption.
+ Qed.
+
+ Lemma set_remove_2 (a b:A) (l : set) :
+ NoDup l -> In a (set_remove b l) -> a <> b.
+ Proof.
+ induction l as [|x l IH]; intro ND; simpl.
+ - tauto.
+ - inversion_clear ND.
+ destruct (Aeq_dec b x) as [<-|Hbx].
+ + congruence.
+ + destruct 1; subst; auto.
+ Qed.
+
+ Lemma set_remove_3 (a b : A) (l : set) :
+ In a l -> a <> b -> In a (set_remove b l).
+ Proof.
+ induction l as [|x xs Hrec].
+ - now simpl.
+ - simpl. destruct (Aeq_dec b x) as [<-|Hbx]; simpl; intuition.
+ congruence.
+ Qed.
+
+ Lemma set_remove_iff (a b : A) (l : set) :
+ NoDup l -> (In a (set_remove b l) <-> In a l /\ a <> b).
+ Proof.
+ split; try split.
+ - eapply set_remove_1; eauto.
+ - eapply set_remove_2; eauto.
+ - destruct 1; apply set_remove_3; auto.
+ Qed.
+
+ Lemma set_remove_nodup a l : NoDup l -> NoDup (set_remove a l).
+ Proof.
+ induction 1 as [|x l H H' IH]; simpl.
+ - constructor.
+ - destruct (Aeq_dec a x) as [<-|Hax]; trivial.
+ constructor; trivial.
+ rewrite set_remove_iff; trivial. intuition.
+ Qed.
Lemma set_union_intro1 :
forall (a:A) (x y:set), set_In a x -> set_In a (set_union x y).
@@ -264,18 +330,26 @@ Section first_definitions.
tauto.
Qed.
+ Lemma set_union_iff a l l': In a (set_union l l') <-> In a l \/ In a l'.
+ Proof.
+ split. apply set_union_elim. apply set_union_intro.
+ Qed.
+
+ Lemma set_union_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_union l l').
+ Proof.
+ induction 2 as [|x' l' ? ? IH]; simpl; trivial. now apply set_add_nodup.
+ Qed.
+
Lemma set_union_emptyL :
forall (a:A) (x:set), set_In a (set_union empty_set x) -> set_In a x.
intros a x H; case (set_union_elim _ _ _ H); auto || contradiction.
Qed.
-
Lemma set_union_emptyR :
forall (a:A) (x:set), set_In a (set_union x empty_set) -> set_In a x.
intros a x H; case (set_union_elim _ _ _ H); auto || contradiction.
Qed.
-
Lemma set_inter_intro :
forall (a:A) (x y:set),
set_In a x -> set_In a y -> set_In a (set_inter x y).
@@ -326,6 +400,21 @@ Section first_definitions.
eauto with datatypes.
Qed.
+ Lemma set_inter_iff a l l' : In a (set_inter l l') <-> In a l /\ In a l'.
+ Proof.
+ split.
+ - apply set_inter_elim.
+ - destruct 1. now apply set_inter_intro.
+ Qed.
+
+ Lemma set_inter_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_inter l l').
+ Proof.
+ induction 1 as [|x l H H' IH]; intro Hl'; simpl.
+ - constructor.
+ - destruct (set_mem x l'); auto.
+ constructor; auto. rewrite set_inter_iff; tauto.
+ Qed.
+
Lemma set_diff_intro :
forall (a:A) (x y:set),
set_In a x -> ~ set_In a y -> set_In a (set_diff x y).
@@ -360,6 +449,20 @@ Section first_definitions.
rewrite H; trivial.
Qed.
+ Lemma set_diff_iff a l l' : In a (set_diff l l') <-> In a l /\ ~In a l'.
+ Proof.
+ split.
+ - split; [eapply set_diff_elim1 | eapply set_diff_elim2]; eauto.
+ - destruct 1. now apply set_diff_intro.
+ Qed.
+
+ Lemma set_diff_nodup l l' : NoDup l -> NoDup l' -> NoDup (set_diff l l').
+ Proof.
+ induction 1 as [|x l H H' IH]; intro Hl'; simpl.
+ - constructor.
+ - destruct (set_mem x l'); auto using set_add_nodup.
+ Qed.
+
Lemma set_diff_trivial : forall (a:A) (x:set), ~ set_In a (set_diff x x).
red; intros a x H.
apply (set_diff_elim2 _ _ _ H).
diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml
index d3374675d..e0475646f 100644
--- a/tools/coq_makefile.ml
+++ b/tools/coq_makefile.ml
@@ -355,7 +355,7 @@ let clean sds sps =
sds;
print "\n";
print "printenv:\n\t@\"$(COQBIN)coqtop\" -config\n";
- print "\t@echo 'CAMLC =\t$(CAMLC)'\n\t@echo 'CAMLOPTC =\t$(CAMLOPTC)'\n\t@echo 'PP =\t$(PP)'\n\t@echo 'COQFLAGS =\t$(COQFLAGS)'\n";
+ print "\t@echo 'OCAMLFIND =\t$(OCAMLFIND)'\n\t@echo 'PP =\t$(PP)'\n\t@echo 'COQFLAGS =\t$(COQFLAGS)'\n";
print "\t@echo 'COQLIBINSTALL =\t$(COQLIBINSTALL)'\n\t@echo 'COQDOCINSTALL =\t$(COQDOCINSTALL)'\n\n"
let header_includes () = ()
@@ -365,19 +365,19 @@ let implicit () =
let mli_rules () =
print "$(MLIFILES:.mli=.cmi): %.cmi: %.mli\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
print "$(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli\n";
- print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+ print "\t$(OCAMLFIND) ocamldep -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
let ml4_rules () =
print "$(ML4FILES:.ml4=.cmo): %.cmo: %.ml4\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ML4FILES:.ml4=.cmx)): %.cmx: %.ml4\n";
print "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
print "$(addsuffix .d,$(ML4FILES)): %.ml4.d: %.ml4\n";
- print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) $(PP) -impl \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+ print "\t$(OCAMLFIND) ocamldep -slash $(OCAMLLIBS) $(PP) -impl \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
let ml_rules () =
print "$(MLFILES:.ml=.cmo): %.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(MLFILES:.ml=.cmx)): %.cmx: %.ml\n";
print "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
print "$(addsuffix .d,$(MLFILES)): %.ml.d: %.ml\n";
- print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+ print "\t$(OCAMLFIND) ocamldep -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
let cmxs_rules () = (* order is important here when there is foo.ml and foo.mllib *)
print "$(filter-out $(MLLIBFILES:.mllib=.cmxs),$(MLFILES:.ml=.cmxs) $(ML4FILES:.ml4=.cmxs) $(MLPACKFILES:.mlpack=.cmxs)): %.cmxs: %.cmx
\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $<\n\n";
@@ -447,7 +447,7 @@ let variables is_install opt (args,defs) =
(* Caml executables and relative variables *)
if !some_ml4file || !some_mlfile || !some_mlifile then begin
print "COQSRCLIBS?=-I \"$(COQLIB)kernel\" -I \"$(COQLIB)lib\" \\
- -I \"$(COQLIB)library\" -I \"$(COQLIB)parsing\" -I \"$(COQLIB)pretyping\" \\
+ -I \"$(COQLIB)library\" -I \"$(COQLIB)parsing\" -I \"$(COQLIB)engine\" -I \"$(COQLIB)pretyping\" \\
-I \"$(COQLIB)interp\" -I \"$(COQLIB)printing\" -I \"$(COQLIB)intf\" \\
-I \"$(COQLIB)proofs\" -I \"$(COQLIB)tactics\" -I \"$(COQLIB)tools\" \\
-I \"$(COQLIB)toplevel\" -I \"$(COQLIB)stm\" -I \"$(COQLIB)grammar\" \\
@@ -455,17 +455,18 @@ let variables is_install opt (args,defs) =
List.iter (fun c -> print " \\
-I \"$(COQLIB)/"; print c; print "\"") Coq_config.plugins_dirs; print "\n";
print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\n";
- print "CAMLC?=$(OCAMLC) -c -rectypes -thread\n";
- print "CAMLOPTC?=$(OCAMLOPT) -c -rectypes -thread\n";
- print "CAMLLINK?=$(OCAMLC) -rectypes -thread\n";
- print "CAMLOPTLINK?=$(OCAMLOPT) -rectypes -thread\n";
+ print "CAMLC?=$(OCAMLFIND) ocamlc -c -rectypes -thread\n";
+ print "CAMLOPTC?=$(OCAMLFIND) opt -c -rectypes -thread\n";
+ print "CAMLLINK?=$(OCAMLFIND) ocamlc -rectypes -thread\n";
+ print "CAMLOPTLINK?=$(OCAMLFIND) opt -rectypes -thread\n";
+ print "CAMLLIB?=$(shell $(OCAMLFIND) printconf stdlib)\n";
print "GRAMMARS?=grammar.cma\n";
print "ifeq ($(CAMLP4),camlp5)
CAMLP4EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo unix.cma threads.cma
else
CAMLP4EXTEND=threads.cma
endif\n";
- print "PP?=-pp '$(CAMLP4O) -I $(CAMLLIB) -I $(CAMLLIB)threads/ $(COQSRCLIBS) compat5.cmo \\
+ print "PP?=-pp '$(CAMLP4O) -I $(CAMLLIB) -I $(CAMLLIB)/threads/ $(COQSRCLIBS) compat5.cmo \\
$(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl'\n\n";
end;
match is_install with
@@ -507,7 +508,7 @@ let parameters () =
print "define donewline\n\n\nendef\n";
print "includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr -d '\\r' | tr '\\n' '@'; })))\n";
print "$(call includecmdwithout@,$(COQBIN)coqtop -config)\n\n";
- print "TIMED=\nTIMECMD=\nSTDTIME?=/usr/bin/time -f \"$* (user: %U mem: %M ko)\"\n";
+ print "TIMED?=\nTIMECMD?=\nSTDTIME=/usr/bin/time -f \"$* (user: %U mem: %M ko)\"\n";
print "TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD))\n\n";
print "vo_to_obj = $(addsuffix .o,\\\n";
print " $(filter-out Warning: Error:,\\\n";
@@ -682,9 +683,9 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other
begin
print "mlihtml: $(MLIFILES:.mli=.cmi)\n";
print "\t mkdir $@ || rm -rf $@/*\n";
- print "\t$(OCAMLDOC) -html -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
+ print "\t$(OCAMLFIND) ocamldoc -html -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
print "all-mli.tex: $(MLIFILES:.mli=.cmi)\n";
- print "\t$(OCAMLDOC) -latex -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
+ print "\t$(OCAMLFIND) ocamldoc -latex -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n";
end;
if !some_vfile then
begin
diff --git a/tools/coqdep.ml b/tools/coqdep.ml
index 110d30602..be50b0e1c 100644
--- a/tools/coqdep.ml
+++ b/tools/coqdep.ml
@@ -9,6 +9,7 @@
open Printf
open Coqdep_lexer
open Coqdep_common
+open System
(** The basic parts of coqdep (i.e. the parts used by [coqdep -boot])
are now in [Coqdep_common]. The code that remains here concerns
@@ -455,7 +456,7 @@ let rec parse = function
| "-R" :: ([] | [_]) -> usage ()
| "-dumpgraph" :: f :: ll -> option_dump := Some (false, f); parse ll
| "-dumpgraphbox" :: f :: ll -> option_dump := Some (true, f); parse ll
- | "-exclude-dir" :: r :: ll -> norec_dirnames := StrSet.add r !norec_dirnames; parse ll
+ | "-exclude-dir" :: r :: ll -> System.exclude_directory r; parse ll
| "-exclude-dir" :: [] -> usage ()
| "-coqlib" :: r :: ll -> Flags.coqlib_spec := true; Flags.coqlib := r; parse ll
| "-coqlib" :: [] -> usage ()
@@ -476,6 +477,7 @@ let coqdep () =
if !option_boot then begin
add_rec_dir add_known "theories" ["Coq"];
add_rec_dir add_known "plugins" ["Coq"];
+ add_caml_dir "tactics";
add_rec_dir (fun _ -> add_caml_known) "theories" ["Coq"];
add_rec_dir (fun _ -> add_caml_known) "plugins" ["Coq"];
end else begin
diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml
deleted file mode 100644
index 64ce66d2d..000000000
--- a/tools/coqdep_boot.ml
+++ /dev/null
@@ -1,49 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Coqdep_common
-
-(** [coqdep_boot] is a stripped-down version of [coqdep], whose
- behavior is the one of [coqdep -boot]. Its only dependencies
- are [Coqdep_lexer], [Coqdep_common] and [Unix], and it should stay so.
- If it needs someday some additional information, pass it via
- options (see for instance [option_natdynlk] below).
-*)
-
-let rec parse = function
- | "-natdynlink" :: "no" :: ll -> option_natdynlk := false; parse ll
- | "-c" :: ll -> option_c := true; parse ll
- | "-boot" :: ll -> parse ll (* We're already in boot mode by default *)
- | "-mldep" :: ocamldep :: ll ->
- option_mldep := Some ocamldep; option_c := true; parse ll
- | "-I" :: r :: ll ->
- (* To solve conflict (e.g. same filename in kernel and checker)
- we allow to state an explicit order *)
- add_caml_dir r;
- norec_dirs := StrSet.add r !norec_dirs;
- parse ll
- | f :: ll -> treat_file None f; parse ll
- | [] -> ()
-
-let _ =
- let () = option_boot := true in
- if Array.length Sys.argv < 2 then exit 1;
- parse (List.tl (Array.to_list Sys.argv));
- if !option_c then begin
- add_rec_dir add_known "." [];
- add_rec_dir (fun _ -> add_caml_known) "." ["Coq"];
- end
- else begin
- add_rec_dir add_known "theories" ["Coq"];
- add_rec_dir add_known "plugins" ["Coq"];
- add_caml_dir "tactics";
- add_rec_dir (fun _ -> add_caml_known) "theories" ["Coq"];
- add_rec_dir (fun _ -> add_caml_known) "plugins" ["Coq"];
- end;
- if !option_c then mL_dependencies ();
- coq_dependencies ()
diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml
index c11113757..2cdb66aa7 100644
--- a/tools/coqdep_common.ml
+++ b/tools/coqdep_common.ml
@@ -9,6 +9,7 @@
open Printf
open Coqdep_lexer
open Unix
+open System
(** [coqdep_boot] is a stripped-down version of [coqdep], whose
behavior is the one of [coqdep -boot]. Its only dependencies
@@ -32,26 +33,11 @@ let option_boot = ref false
let option_mldep = ref None
let norec_dirs = ref StrSet.empty
-let norec_dirnames = ref (List.fold_right StrSet.add ["CVS"; "_darcs"] StrSet.empty)
let suffixe = ref ".vo"
type dir = string option
-(* Filename.concat but always with a '/' *)
-let is_dir_sep s i =
- match Sys.os_type with
- | "Unix" -> s.[i] = '/'
- | "Cygwin" | "Win32" ->
- let c = s.[i] in c = '/' || c = '\\' || c = ':'
- | _ -> assert false
-
-let (//) dirname filename =
- let l = String.length dirname in
- if l = 0 || is_dir_sep dirname (l-1)
- then dirname ^ filename
- else dirname ^ "/" ^ filename
-
(** [get_extension f l] checks whether [f] has one of the extensions
listed in [l]. It returns [f] without its extension, alongside with
the extension. When no extension match, [(f,"")] is returned *)
@@ -203,6 +189,10 @@ let warning_clash file dir =
eprintf "%s and %s; used the latter)\n" d2 d1
| _ -> assert false
+let warning_cannot_open_dir dir =
+ eprintf "*** Warning: cannot open %s\n" dir;
+ flush stderr
+
let safe_assoc from verbose file k =
if verbose && StrListMap.mem k !clash_v then warning_clash file k;
match search_v_known ?from k with
@@ -514,42 +504,43 @@ let add_known recur phys_dir log_dir f =
List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths
| _ -> ()
-(* Visits all the directories under [dir], including [dir],
- or just [dir] if [recur=false] *)
+(* Visits all the directories under [dir], including [dir] *)
-let rec add_directory recur add_file phys_dir log_dir =
- let dirh = opendir phys_dir in
- try
- while true do
- let f = readdir dirh in
- (* we avoid all files and subdirs starting by '.' (e.g. .svn),
- plus CVS and _darcs and any subdirs given via -exclude-dirs *)
- if f.[0] <> '.' then
- let phys_f = if phys_dir = "." then f else phys_dir//f in
- match try (stat phys_f).st_kind with _ -> S_BLK with
- | S_DIR when recur ->
- if StrSet.mem f !norec_dirnames then ()
- else
- if StrSet.mem phys_f !norec_dirs then ()
- else
- add_directory recur add_file phys_f (log_dir@[f])
- | S_REG -> add_file phys_dir log_dir f
- | _ -> ()
- done
- with End_of_file -> closedir dirh
+let is_not_seen_directory phys_f =
+ not (StrSet.mem phys_f !norec_dirs)
+
+let rec add_directory add_file phys_dir log_dir =
+ let f = function
+ | FileDir (phys_f,f) ->
+ if is_not_seen_directory phys_f then
+ add_directory add_file phys_f (log_dir @ [f])
+ | FileRegular f ->
+ add_file phys_dir log_dir f
+ in
+ System.check_unix_dir (fun s -> eprintf "*** Warning: %s\n" s) phys_dir;
+ if exists_dir phys_dir then
+ process_directory f phys_dir
+ else
+ warning_cannot_open_dir phys_dir
(** -Q semantic: go in subdirs but only full logical paths are known. *)
let add_dir add_file phys_dir log_dir =
- try add_directory true (add_file false) phys_dir log_dir with Unix_error _ -> ()
+ try add_directory (add_file false) phys_dir log_dir with Unix_error _ -> ()
(** -R semantic: go in subdirs and suffixes of logical paths are known. *)
let add_rec_dir add_file phys_dir log_dir =
- handle_unix_error (add_directory true (add_file true) phys_dir) log_dir
+ add_directory (add_file true) phys_dir log_dir
+
+(** -R semantic but only on immediate capitalized subdirs *)
+
+let add_rec_uppercase_subdirs add_file phys_dir log_dir =
+ process_subdirectories (fun phys_dir f ->
+ add_directory (add_file true) phys_dir (log_dir@[String.capitalize f]))
+ phys_dir
(** -I semantic: do not go in subdirs. *)
let add_caml_dir phys_dir =
- handle_unix_error (add_directory true add_caml_known phys_dir) []
-
+ add_directory add_caml_known phys_dir []
let rec treat_file old_dirname old_name =
let name = Filename.basename old_name
diff --git a/tools/coqdep_common.mli b/tools/coqdep_common.mli
index d610a0558..c3570f811 100644
--- a/tools/coqdep_common.mli
+++ b/tools/coqdep_common.mli
@@ -14,10 +14,8 @@ val option_boot : bool ref
val option_natdynlk : bool ref
val option_mldep : string option ref
val norec_dirs : StrSet.t ref
-val norec_dirnames : StrSet.t ref
val suffixe : string ref
type dir = string option
-val ( // ) : string -> string -> string
val get_extension : string -> string list -> string * string
val basename_noext : string -> string
val mlAccu : (string * string * dir) list ref
@@ -43,13 +41,12 @@ val suffixes : 'a list -> 'a list list
val add_known : bool -> string -> string list -> string -> unit
val add_coqlib_known : bool -> string -> string list -> string -> unit
val add_caml_known : string -> string list -> string -> unit
-val add_directory :
- bool ->
- (string -> string list -> string -> unit) -> string -> string list -> unit
val add_caml_dir : string -> unit
val add_dir :
(bool -> string -> string list -> string -> unit) -> string -> string list -> unit
val add_rec_dir :
(bool -> string -> string list -> string -> unit) -> string -> string list -> unit
+val add_rec_uppercase_subdirs :
+ (bool -> string -> string list -> string -> unit) -> string -> string list -> unit
val treat_file : dir -> string -> unit
val error_cannot_parse : string -> int * int -> 'a
diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml
index be796e695..a6254b2a4 100644
--- a/tools/coqmktop.ml
+++ b/tools/coqmktop.ml
@@ -149,7 +149,7 @@ let usage () =
prerr_endline "Usage: coqmktop <options> <ocaml options> files\
\nFlags are:\
\n -coqlib dir Specify where the Coq object files are\
-\n -camlbin dir Specify where the OCaml binaries are\
+\n -ocamlfind dir Specify where the ocamlfind binary is\
\n -camlp4bin dir Specify where the Camlp4/5 binaries are\
\n -o exec-file Specify the name of the resulting toplevel\
\n -boot Run in boot mode\
@@ -167,8 +167,8 @@ let parse_args () =
(* Directories *)
| "-coqlib" :: d :: rem ->
Flags.coqlib_spec := true; Flags.coqlib := d ; parse (op,fl) rem
- | "-camlbin" :: d :: rem ->
- Flags.camlbin_spec := true; Flags.camlbin := d ; parse (op,fl) rem
+ | "-ocamlfind" :: d :: rem ->
+ Flags.ocamlfind_spec := true; Flags.ocamlfind := d ; parse (op,fl) rem
| "-camlp4bin" :: d :: rem ->
Flags.camlp4bin_spec := true; Flags.camlp4bin := d ; parse (op,fl) rem
| "-R" :: d :: rem -> parse (incl_all_subdirs d op,fl) rem
@@ -266,10 +266,9 @@ let main () =
let (options, userfiles) = parse_args () in
(* Directories: *)
let () = Envars.set_coqlib ~fail:Errors.error in
- let camlbin = Envars.camlbin () in
let basedir = if !Flags.boot then None else Some (Envars.coqlib ()) in
(* Which ocaml compiler to invoke *)
- let prog = camlbin/(if !opt then "ocamlopt" else "ocamlc") in
+ let prog = if !opt then "opt" else "ocamlc" in
(* Which arguments ? *)
if !opt && !top then failwith "no custom toplevel in native code !";
let flags = if !opt then [] else Coq_config.vmbyteflags in
@@ -284,14 +283,14 @@ let main () =
(std_includes basedir) @ tolink @ [ main_file ] @ topstart
in
if !echo then begin
- let command = String.concat " " (prog::args) in
+ let command = String.concat " " (Envars.ocamlfind ()::prog::args) in
print_endline command;
print_endline
("(command length is " ^
(string_of_int (String.length command)) ^ " characters)");
flush Pervasives.stdout
end;
- let exitcode = run_command prog args in
+ let exitcode = run_command (Envars.ocamlfind ()) (prog::args) in
clean main_file;
exitcode
with reraise -> clean main_file; raise reraise
diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml
index a9a7251c5..dfe6093d6 100644
--- a/tools/fake_ide.ml
+++ b/tools/fake_ide.ml
@@ -17,7 +17,18 @@ type coqtop = {
xml_parser : Xml_parser.t;
}
-let logger level content = prerr_endline content
+let print_xml chan xml =
+ let rec print = function
+ | Xml_datatype.PCData s -> output_string chan s
+ | Xml_datatype.Element (_, _, children) -> List.iter print children
+ in
+ print xml
+
+let error_xml s =
+ Printf.eprintf "fake_id: error: %a\n%!" print_xml s;
+ exit 1
+
+let logger level content = Printf.eprintf "%a\n%! " print_xml content
let base_eval_call ?(print=true) ?(fail=true) call coqtop =
if print then prerr_endline (Xmlprotocol.pr_call call);
@@ -38,8 +49,8 @@ let base_eval_call ?(print=true) ?(fail=true) call coqtop =
let res = loop () in
if print then prerr_endline (Xmlprotocol.pr_full_value call res);
match res with
- | Interface.Fail (_,_,s) when fail -> error s
- | Interface.Fail (_,_,s) as x -> prerr_endline s; x
+ | Interface.Fail (_,_,s) when fail -> error_xml (Richpp.repr s)
+ | Interface.Fail (_,_,s) as x -> Printf.eprintf "%a\n%!" print_xml (Richpp.repr s); x
| x -> x
let eval_call c q = ignore(base_eval_call c q)
@@ -188,7 +199,7 @@ let print_document () =
module GUILogic = struct
let after_add = function
- | Interface.Fail (_,_,s) -> error s
+ | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s)
| Interface.Good (id, (Util.Inl (), _)) ->
Document.assign_tip_id doc id
| Interface.Good (id, (Util.Inr tip, _)) ->
@@ -200,7 +211,7 @@ module GUILogic = struct
let at id id' _ = Stateid.equal id' id
let after_edit_at (id,need_unfocus) = function
- | Interface.Fail (_,_,s) -> error s
+ | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s)
| Interface.Good (Util.Inl ()) ->
if need_unfocus then Document.unfocus doc;
ignore(Document.cut_at doc id);
@@ -323,7 +334,7 @@ let main =
let finish () =
match base_eval_call (Xmlprotocol.status true) coq with
| Interface.Good _ -> exit 0
- | Interface.Fail (_,_,s) -> error s in
+ | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) in
(* The main loop *)
init ();
while true do
diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll
new file mode 100644
index 000000000..4e5edcf6c
--- /dev/null
+++ b/tools/ocamllibdep.mll
@@ -0,0 +1,210 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+{
+ exception Syntax_error of int*int
+
+ let syntax_error lexbuf =
+ raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf))
+}
+
+let space = [' ' '\t' '\n' '\r']
+let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255']
+let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar =
+ ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+let caml_up_ident = uppercase identchar*
+let caml_low_ident = lowercase identchar*
+
+rule mllib_list = parse
+ | caml_up_ident { let s = String.uncapitalize (Lexing.lexeme lexbuf)
+ in s :: mllib_list lexbuf }
+ | "*predef*" { mllib_list lexbuf }
+ | space+ { mllib_list lexbuf }
+ | eof { [] }
+ | _ { syntax_error lexbuf }
+
+{
+open Printf
+open Unix
+
+(** [coqdep_boot] is a stripped-down version of [coqdep] used to treat
+ with mllib files.
+*)
+
+(* Makefile's escaping rules are awful: $ is escaped by doubling and
+ other special characters are escaped by backslash prefixing while
+ backslashes themselves must be escaped only if part of a sequence
+ followed by a special character (i.e. in case of ambiguity with a
+ use of it as escaping character). Moreover (even if not crucial)
+ it is apparently not possible to directly escape ';' and leading '\t'. *)
+
+let escape =
+ let s' = Buffer.create 10 in
+ fun s ->
+ Buffer.clear s';
+ for i = 0 to String.length s - 1 do
+ let c = s.[i] in
+ if c = ' ' || c = '#' || c = ':' (* separators and comments *)
+ || c = '%' (* pattern *)
+ || c = '?' || c = '[' || c = ']' || c = '*' (* expansion in filenames *)
+ || i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' ||
+ 'A' <= s.[1] && s.[1] <= 'Z' ||
+ 'a' <= s.[1] && s.[1] <= 'z') (* homedir expansion *)
+ then begin
+ let j = ref (i-1) in
+ while !j >= 0 && s.[!j] = '\\' do
+ Buffer.add_char s' '\\'; decr j (* escape all preceding '\' *)
+ done;
+ Buffer.add_char s' '\\';
+ end;
+ if c = '$' then Buffer.add_char s' '$';
+ Buffer.add_char s' c
+ done;
+ Buffer.contents s'
+
+(* Filename.concat but always with a '/' *)
+let is_dir_sep s i =
+ match Sys.os_type with
+ | "Unix" -> s.[i] = '/'
+ | "Cygwin" | "Win32" ->
+ let c = s.[i] in c = '/' || c = '\\' || c = ':'
+ | _ -> assert false
+
+let (//) dirname filename =
+ let l = String.length dirname in
+ if l = 0 || is_dir_sep dirname (l-1)
+ then dirname ^ filename
+ else dirname ^ "/" ^ filename
+
+(** [get_extension f l] checks whether [f] has one of the extensions
+ listed in [l]. It returns [f] without its extension, alongside with
+ the extension. When no extension match, [(f,"")] is returned *)
+
+let rec get_extension f = function
+ | [] -> (f, "")
+ | s :: _ when Filename.check_suffix f s -> (Filename.chop_suffix f s, s)
+ | _ :: l -> get_extension f l
+
+let file_name s = function
+ | None -> s
+ | Some "." -> s
+ | Some d -> d // s
+
+type dir = string option
+
+(* Visits all the directories under [dir], including [dir],
+ or just [dir] if [recur=false] *)
+
+let rec add_directory add_file phys_dir =
+ let dirh = opendir phys_dir in
+ try
+ while true do
+ let f = readdir dirh in
+ (* we avoid all files and subdirs starting by '.' (e.g. .svn),
+ plus CVS and _darcs and any subdirs given via -exclude-dirs *)
+ if f.[0] <> '.' then
+ let phys_f = if phys_dir = "." then f else phys_dir//f in
+ match try (stat phys_f).st_kind with _ -> S_BLK with
+ | S_REG -> add_file phys_dir f
+ | _ -> ()
+ done
+ with End_of_file -> closedir dirh
+
+let error_cannot_parse s (i,j) =
+ Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j;
+ exit 1
+
+let warning_ml_clash x s suff s' suff' =
+ if suff = suff' then
+ eprintf
+ "*** Warning: %s%s already found in %s (discarding %s%s)\n" x suff
+ (match s with None -> "." | Some d -> d)
+ ((match s' with None -> "." | Some d -> d) // x) suff
+
+let mkknown () =
+ let h = (Hashtbl.create 19 : (string, dir * string) Hashtbl.t) in
+ let add x s suff =
+ try let s',suff' = Hashtbl.find h x in warning_ml_clash x s' suff' s suff
+ with Not_found -> Hashtbl.add h x (s,suff)
+ and search x =
+ try Some (fst (Hashtbl.find h x))
+ with Not_found -> None
+ in add, search
+
+let add_ml_known, search_ml_known = mkknown ()
+let add_mlpack_known, search_mlpack_known = mkknown ()
+
+let mllibAccu = ref ([] : (string * dir) list)
+
+let add_caml_known phys_dir f =
+ let basename,suff = get_extension f [".ml";".ml4";".mlpack"] in
+ match suff with
+ | ".ml"|".ml4" -> add_ml_known basename (Some phys_dir) suff
+ | ".mlpack" -> add_mlpack_known basename (Some phys_dir) suff
+ | _ -> ()
+
+let add_caml_dir phys_dir =
+ handle_unix_error (add_directory add_caml_known) phys_dir
+
+let traite_fichier_modules md ext =
+ try
+ let chan = open_in (md ^ ext) in
+ let list = mllib_list (Lexing.from_channel chan) in
+ List.fold_left
+ (fun a_faire str -> match search_mlpack_known str with
+ | Some mldir ->
+ let file = file_name str mldir in
+ a_faire^" "^file
+ | None ->
+ match search_ml_known str with
+ | Some mldir ->
+ let file = file_name str mldir in
+ a_faire^" "^file
+ | None -> a_faire) "" list
+ with
+ | Sys_error _ -> ""
+ | Syntax_error (i,j) -> error_cannot_parse (md^ext) (i,j)
+
+let addQueue q v = q := v :: !q
+
+let rec treat_file old_name =
+ let name = Filename.basename old_name in
+ let dirname = Some (Filename.dirname old_name) in
+ match get_extension name [".mllib"] with
+ | (base,".mllib") -> addQueue mllibAccu (base,dirname)
+ | _ -> ()
+
+let mllib_dependencies () =
+ List.iter
+ (fun (name,dirname) ->
+ let fullname = file_name name dirname in
+ let dep = traite_fichier_modules fullname ".mllib" in
+ let efullname = escape fullname in
+ printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname dep;
+ printf "%s.cma:$(addsuffix .cmo,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname;
+ printf "%s.cmxa %s.cmxs:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname efullname;
+ flush Pervasives.stdout)
+ (List.rev !mllibAccu)
+
+let rec parse = function
+ | "-I" :: r :: ll ->
+ (* To solve conflict (e.g. same filename in kernel and checker)
+ we allow to state an explicit order *)
+ add_caml_dir r;
+ parse ll
+ | f :: ll -> treat_file f; parse ll
+ | [] -> ()
+
+let coqdep_boot () =
+ if Array.length Sys.argv < 2 then exit 1;
+ parse (List.tl (Array.to_list Sys.argv));
+ mllib_dependencies ()
+
+let _ = Printexc.catch coqdep_boot ()
+}
diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml
index 7a89b9f54..e99b609b6 100644
--- a/toplevel/auto_ind_decl.ml
+++ b/toplevel/auto_ind_decl.ml
@@ -354,7 +354,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q =
)))
)
in
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let type_of_pq = Tacmach.New.of_old (fun gl -> pf_unsafe_type_of gl p) gl in
let u,v = destruct_ind type_of_pq
in let lb_type_of_p =
@@ -384,7 +384,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q =
Tacticals.New.tclTHENLIST [
Proofview.tclEFFECTS eff;
Equality.replace p q ; apply app ; Auto.default_auto]
- end
+ end }
(* used in the bool -> leib side *)
let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
@@ -416,7 +416,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
let rec aux l1 l2 =
match (l1,l2) with
| (t1::q1,t2::q2) ->
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let tt1 = Tacmach.New.pf_unsafe_type_of gl t1 in
if eq_constr t1 t2 then aux q1 q2
else (
@@ -457,7 +457,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
aux q1 q2 ]
)
)
- end
+ end }
| ([],[]) -> Proofview.tclUNIT ()
| _ -> Tacticals.New.tclZEROMSG (str "Both side of the equality must have the same arity.")
in
@@ -564,7 +564,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec =
avoid := fresh::(!avoid); fresh
end gl
in
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
let freshn = fresh_id (Id.of_string "x") gl in
let freshm = fresh_id (Id.of_string "y") gl in
@@ -587,18 +587,18 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
Tacticals.New.tclREPEAT (
Tacticals.New.tclTHENLIST [
Simple.apply_in freshz (andb_prop());
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let fresht = fresh_id (Id.of_string "Z") gl in
(destruct_on_as (mkVar freshz)
[[dl,IntroNaming (IntroIdentifier fresht);
dl,IntroNaming (IntroIdentifier freshz)]])
- end
+ end }
]);
(*
Ci a1 ... an = Ci b1 ... bn
replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto
*)
- Proofview.Goal.nf_enter begin fun gls ->
+ Proofview.Goal.nf_enter { enter = begin fun gls ->
let gl = Proofview.Goal.concl gls in
match (kind_of_term gl) with
| App (c,ca) -> (
@@ -617,10 +617,10 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
| _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.")
)
| _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.")
- end
+ end }
]
- end
+ end }
let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
@@ -707,7 +707,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec =
avoid := fresh::(!avoid); fresh
end gl
in
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
let freshn = fresh_id (Id.of_string "x") gl in
let freshm = fresh_id (Id.of_string "y") gl in
@@ -730,7 +730,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec =
Tacticals.New.tclTHENLIST [apply (andb_true_intro());
simplest_split ;Auto.default_auto ]
);
- Proofview.Goal.nf_enter begin fun gls ->
+ Proofview.Goal.nf_enter { enter = begin fun gls ->
let gl = Proofview.Goal.concl gls in
(* assume the goal to be eq (eq_type ...) = true *)
match (kind_of_term gl) with
@@ -746,9 +746,9 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec =
)
| _ ->
Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.")
- end
+ end }
]
- end
+ end }
let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined")
@@ -854,7 +854,7 @@ let compute_dec_tact ind lnamesparrec nparrec =
avoid := fresh::(!avoid); fresh
end gl
in
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
let freshn = fresh_id (Id.of_string "x") gl in
let freshm = fresh_id (Id.of_string "y") gl in
@@ -885,7 +885,7 @@ let compute_dec_tact ind lnamesparrec nparrec =
)
(Tacticals.New.tclTHEN (destruct_on eqbnm) Auto.default_auto);
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let freshH2 = fresh_id (Id.of_string "H") gl in
Tacticals.New.tclTHENS (destruct_on_using (mkVar freshH) freshH2) [
(* left *)
@@ -897,7 +897,7 @@ let compute_dec_tact ind lnamesparrec nparrec =
;
(*right *)
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let freshH3 = fresh_id (Id.of_string "H") gl in
Tacticals.New.tclTHENLIST [
simplest_right ;
@@ -919,11 +919,11 @@ let compute_dec_tact ind lnamesparrec nparrec =
true;
Equality.discr_tac false None
]
- end
+ end }
]
- end
+ end }
]
- end
+ end }
let make_eq_decidability mode mind =
let mib = Global.lookup_mind mind in
diff --git a/toplevel/classes.ml b/toplevel/classes.ml
index c354c7d32..0a10cfdc3 100644
--- a/toplevel/classes.ml
+++ b/toplevel/classes.ml
@@ -20,6 +20,7 @@ open Libnames
open Globnames
open Constrintern
open Constrexpr
+open Sigma.Notations
(*i*)
open Decl_kinds
@@ -322,7 +323,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
if not (Option.is_empty term) then
let init_refine =
Tacticals.New.tclTHENLIST [
- Proofview.Refine.refine (fun evm -> evm, Option.get term);
+ Proofview.Refine.refine { run = fun evm -> Sigma (Option.get term, evm, Sigma.refl) };
Proofview.Unsafe.tclNEWGOALS gls;
Tactics.New.reduce_after_refine;
]
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index eca344b27..e089b7ecc 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -125,7 +125,7 @@ let init_ocaml_path () =
Mltop.add_ml_dir (Envars.coqlib ());
List.iter add_subdir
[ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ];
- [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ];
+ [ "engine" ]; [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ];
[ "tactics" ]; [ "toplevel" ]; [ "printing" ]; [ "intf" ];
[ "grammar" ]; [ "ide" ] ]
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index 72966a4ad..4852a6d33 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -480,7 +480,7 @@ let parse_args arglist =
|"-compile-verbose" -> add_compile true (next ())
|"-dump-glob" -> Dumpglob.dump_into_file (next ()); glob_opt := true
|"-feedback-glob" -> Dumpglob.feedback_glob ()
- |"-exclude-dir" -> exclude_search_in_dirname (next ())
+ |"-exclude-dir" -> System.exclude_directory (next ())
|"-init-file" -> set_rcfile (next ())
|"-inputstate"|"-is" -> set_inputstate (next ())
|"-load-ml-object" -> Mltop.dir_ml_load (next ())
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
index 7616bfff6..7714cc810 100644
--- a/toplevel/metasyntax.ml
+++ b/toplevel/metasyntax.ml
@@ -49,7 +49,7 @@ let interp_prod_item lev = function
| TacTerm s -> GramTerminal s
| TacNonTerm (loc, nt, po) ->
let sep = match po with Some (_,sep) -> sep | _ -> "" in
- let (etyp, e) = interp_entry_name true (Some lev) nt sep in
+ let EntryName (etyp, e) = interp_entry_name true (TgTactic lev) nt sep in
GramNonTerminal (loc, etyp, e, Option.map fst po)
let make_terminal_status = function
@@ -58,7 +58,7 @@ let make_terminal_status = function
let rec make_tags = function
| GramTerminal s :: l -> make_tags l
- | GramNonTerminal (loc, etyp, _, po) :: l -> etyp :: make_tags l
+ | GramNonTerminal (loc, etyp, _, po) :: l -> Genarg.unquote etyp :: make_tags l
| [] -> []
let make_fresh_key =
@@ -160,20 +160,22 @@ type atomic_entry = string * Genarg.glob_generic_argument list option
type ml_tactic_grammar_obj = {
mltacobj_name : Tacexpr.ml_tactic_name;
(** ML-side unique name *)
- mltacobj_prod : grammar_prod_item list list;
+ mltacobj_prod : Tacexpr.raw_tactic_expr grammar_prod_item list list;
(** Grammar rules generating the ML tactic. *)
}
(** ML tactic notations whose use can be restricted to an identifier are added
as true Ltac entries. *)
let extend_atomic_tactic name entries =
- let add_atomic (id, args) = match args with
+ let add_atomic i (id, args) = match args with
| None -> ()
| Some args ->
- let body = Tacexpr.TacML (Loc.ghost, name, args) in
+ let open Tacexpr in
+ let entry = { mltac_name = name; mltac_index = i } in
+ let body = TacML (Loc.ghost, entry, args) in
Tacenv.register_ltac false false (Names.Id.of_string id) body
in
- List.iter add_atomic entries
+ List.iteri add_atomic entries
let cache_ml_tactic_notation (_, obj) =
extend_ml_tactic_grammar obj.mltacobj_name obj.mltacobj_prod
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
index f22839f48..f7049999e 100644
--- a/toplevel/metasyntax.mli
+++ b/toplevel/metasyntax.mli
@@ -24,7 +24,7 @@ val add_tactic_notation :
type atomic_entry = string * Genarg.glob_generic_argument list option
val add_ml_tactic_notation : ml_tactic_name ->
- Egramml.grammar_prod_item list list -> atomic_entry list -> unit
+ Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> atomic_entry list -> unit
(** Adding a (constr) notation in the environment*)
diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml
index a7fb7a58f..fa5ed7bbd 100644
--- a/toplevel/mltop.ml
+++ b/toplevel/mltop.ml
@@ -155,7 +155,7 @@ let add_ml_dir s =
| WithoutTop when has_dynlink -> keep_copy_mlpath s
| _ -> ()
-(* For Rec Add ML Path *)
+(* For Rec Add ML Path (-R) *)
let add_rec_ml_dir unix_path =
List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs ~unix_path)
diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml
index e488f84f8..0e2de74aa 100644
--- a/toplevel/obligations.ml
+++ b/toplevel/obligations.ml
@@ -592,14 +592,16 @@ let declare_mutual_definition l =
List.iter progmap_remove l; kn
let shrink_body c =
- let ctx, b = decompose_lam c in
+ let ctx, b = decompose_lam_assum c in
let b', n, args =
- List.fold_left (fun (b, i, args) (n,t) ->
+ List.fold_left (fun (b, i, args) (n, u, t) ->
if noccurn 1 b then
subst1 mkProp b, succ i, args
- else mkLambda (n,t,b), succ i, mkRel i :: args)
+ else
+ let args = if Option.is_empty u then mkRel i :: args else args in
+ mkLambda_or_LetIn (n, u, t) b, succ i, args)
(b, 1, []) ctx
- in List.map (fun (c,t) -> (c,None,t)) ctx, b', Array.of_list args
+ in ctx, b', Array.of_list args
let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst]
@@ -803,6 +805,36 @@ let solve_by_tac name evi t poly ctx =
Inductiveops.control_only_guard (Global.env ()) (fst body);
(fst body), entry.const_entry_type, Evd.evar_universe_context ctx'
+let obligation_terminator name num guard hook pf =
+ let open Proof_global in
+ let term = Lemmas.universe_proof_terminator guard hook in
+ match pf with
+ | Admitted _ -> apply_terminator term pf
+ | Proved (opq, id, proof) ->
+ if not !shrink_obligations then apply_terminator term pf
+ else
+ let (_, (entry, uctx, _)) = Pfedit.cook_this_proof proof in
+ let env = Global.env () in
+ let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in
+ let ty = entry.Entries.const_entry_type in
+ let (body, cstr), eff = Future.force entry.Entries.const_entry_body in
+ assert(Safe_typing.empty_private_constants = eff);
+ assert(Univ.ContextSet.is_empty cstr);
+ Inductiveops.control_only_guard (Global.env ()) body;
+ (** Declare the obligation ourselves and drop the hook *)
+ let prg = get_info (ProgMap.find name !from_prg) in
+ let prg = { prg with prg_ctx = uctx } in
+ let obls, rem = prg.prg_obligations in
+ let obl = obls.(num) in
+ let ctx = Evd.evar_context_universe_context uctx in
+ let (_, obl) = declare_obligation prg obl body ty ctx in
+ let obls = Array.copy obls in
+ let _ = obls.(num) <- obl in
+ try ignore (update_obls prg obls (pred rem))
+ with e when Errors.noncritical e ->
+ let e = Errors.push e in
+ pperror (Errors.iprint (Cerrors.process_vernac_interp_error e))
+
let obligation_hook prg obl num auto ctx' _ gr =
let obls, rem = prg.prg_obligations in
let cst = match gr with ConstRef cst -> cst | _ -> assert false in
@@ -852,8 +884,9 @@ let rec solve_obligation prg num tac =
let kind = kind_of_obligation (pi2 prg.prg_kind) obl.obl_status in
let evd = Evd.from_ctx prg.prg_ctx in
let auto n tac oblset = auto_solve_obligations n ~oblset tac in
+ let terminator guard hook = Proof_global.make_terminator (obligation_terminator prg.prg_name num guard hook) in
let hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in
- let () = Lemmas.start_proof_univs obl.obl_name kind evd obl.obl_type hook in
+ let () = Lemmas.start_proof_univs obl.obl_name kind evd obl.obl_type ~terminator hook in
let () = trace (str "Started obligation " ++ int user_num ++ str " proof: " ++
Printer.pr_constr_env (Global.env ()) Evd.empty obl.obl_type) in
let _ = Pfedit.by (snd (get_default_tactic ())) in
diff --git a/toplevel/search.ml b/toplevel/search.ml
index 9e67eef00..9c32bddad 100644
--- a/toplevel/search.ml
+++ b/toplevel/search.ml
@@ -18,10 +18,28 @@ open Printer
open Libnames
open Globnames
open Nametab
+open Goptions
type filter_function = global_reference -> env -> constr -> bool
type display_function = global_reference -> env -> constr -> unit
+(* This option restricts the output of [SearchPattern ...],
+[SearchAbout ...], etc. to the names of the symbols matching the
+query, separated by a newline. This type of output is useful for
+editors (like emacs), to generate a list of completion candidates
+without having to parse thorugh the types of all symbols. *)
+
+let search_output_name_only = ref false
+
+let _ =
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "output-name-only search";
+ optkey = ["Search";"Output";"Name";"Only"];
+ optread = (fun () -> !search_output_name_only);
+ optwrite = (:=) search_output_name_only }
+
type glob_search_about_item =
| GlobSearchSubPattern of constr_pattern
| GlobSearchString of string
@@ -98,11 +116,14 @@ let generic_search glnumopt fn =
iter_declarations fn
(** Standard display *)
-
let plain_display accu ref env c =
- let pc = pr_lconstr_env env Evd.empty c in
let pr = pr_global ref in
- accu := hov 2 (pr ++ str":" ++ spc () ++ pc) :: !accu
+ if !search_output_name_only then
+ accu := pr :: !accu
+ else begin
+ let pc = pr_lconstr_env env Evd.empty c in
+ accu := hov 2 (pr ++ str":" ++ spc () ++ pc) :: !accu
+ end
let format_display l = prlist_with_sep fnl (fun x -> x) (List.rev l)
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index 472503ced..292136406 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -114,12 +114,7 @@ let print_config () =
if Coq_config.local then Printf.printf "LOCAL=1\n" else Printf.printf "LOCAL=0\n";
Printf.printf "COQLIB=%s/\n" (Envars.coqlib ());
Printf.printf "DOCDIR=%s/\n" (Envars.docdir ());
- Printf.printf "OCAMLDEP=%s\n" Coq_config.ocamldep;
- Printf.printf "OCAMLC=%s\n" Coq_config.ocamlc;
- Printf.printf "OCAMLOPT=%s\n" Coq_config.ocamlopt;
- Printf.printf "OCAMLDOC=%s\n" Coq_config.ocamldoc;
- Printf.printf "CAMLBIN=%s/\n" (Envars.camlbin ());
- Printf.printf "CAMLLIB=%s/\n" (Envars.camllib ());
+ Printf.printf "OCAMLFIND=%s\n" (Envars.ocamlfind ());
Printf.printf "CAMLP4=%s\n" Coq_config.camlp4;
Printf.printf "CAMLP4O=%s\n" Coq_config.camlp4o;
Printf.printf "CAMLP4BIN=%s/\n" (Envars.camlp4bin ());
diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml
index 31bfc004a..bf090384d 100644
--- a/toplevel/vernacentries.ml
+++ b/toplevel/vernacentries.ml
@@ -347,7 +347,7 @@ let dump_universes_gen g s =
end
in
try
- Univ.dump_universes output_constraint g;
+ UGraph.dump_universes output_constraint g;
close ();
msg_info (str "Universes written to file \"" ++ str s ++ str "\".")
with reraise ->
@@ -357,7 +357,7 @@ let dump_universes_gen g s =
let dump_universes sorted s =
let g = Global.universes () in
- let g = if sorted then Univ.sort_universes g else g in
+ let g = if sorted then UGraph.sort_universes g else g in
dump_universes_gen g s
(*********************)
@@ -1559,7 +1559,7 @@ let vernac_global_check c =
let sigma = Evd.from_env env in
let c,ctx = interp_constr env sigma c in
let senv = Global.safe_env() in
- let cstrs = snd (Evd.evar_universe_context_set Univ.UContext.empty ctx) in
+ let cstrs = snd (UState.context_set ctx) in
let senv = Safe_typing.add_constraints cstrs senv in
let j = Safe_typing.typing senv c in
let env = Safe_typing.env_of_safe_env senv in
@@ -1625,12 +1625,12 @@ let vernac_print = function
| PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ())
| PrintUniverses (b, None) ->
let univ = Global.universes () in
- let univ = if b then Univ.sort_universes univ else univ in
+ let univ = if b then UGraph.sort_universes univ else univ in
let pr_remaining =
if Global.is_joined_environment () then mt ()
else str"There may remain asynchronous universe constraints"
in
- msg_notice (Univ.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining)
+ msg_notice (UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining)
| PrintUniverses (b, Some s) -> dump_universes b s
| PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r))
| PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ())