diff options
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 @@ -12,6 +12,8 @@ S kernel/byterun B kernel/byterun S library B library +S engine +B engine S pretyping B pretyping S interp @@ -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 @@ -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) @@ -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) @@ -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";; @@ -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 @@ -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 ()) |