diff options
139 files changed, 4281 insertions, 2645 deletions
diff --git a/.gitignore b/.gitignore index 3adb9c67c1..0466eac855 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 @@ -28,6 +28,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. API diff --git a/COMPATIBILITY b/COMPATIBILITY index eaeb2cba24..ab29903b93 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 6ceff2de95..018937fc6d 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 @@ -600,7 +601,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. @@ -608,12 +609,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) @@ -828,34 +826,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) @@ -867,7 +865,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) @@ -1016,10 +1014,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" $< > $@ @@ -1059,35 +1053,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 8f3d39bf22..f6ec1694ae 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 ) @@ -376,7 +376,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 49ca6bf051..246fe64dee 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 c63ba65d48..26f4a148cb 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 3fe34d6cae..ffb7c15f5e 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,29 +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 Filename.dirname camlc, 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" @@ -536,12 +511,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 *) @@ -638,40 +609,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" @@ -822,14 +776,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 *) @@ -1039,12 +993,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; @@ -1128,13 +1077,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"; @@ -1144,8 +1088,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 d58b6ad13c..197528acdb 100644 --- a/dev/base_include +++ b/dev/base_include @@ -8,6 +8,7 @@ #directory "toplevel";; #directory "library";; #directory "kernel";; +#directory "engine";; #directory "pretyping";; #directory "lib";; #directory "proofs";; diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index d4ab22ced1..b00d084edb 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/doc/refman/Program.tex b/doc/refman/Program.tex index 8e078e9814..efcc84ee98 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 d388840df5..7011f1ef89 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -1028,6 +1028,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 739a89af4c..c444b5ae05 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 fa6f783934..315acc0811 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 0000000000..dc7ff2a642 --- /dev/null +++ b/engine/engine.mllib @@ -0,0 +1,5 @@ +Logic_monad +Termops +Namegen +Evd +Proofview_monad diff --git a/pretyping/evd.ml b/engine/evd.ml index 168a10df93..168a10df93 100644 --- a/pretyping/evd.ml +++ b/engine/evd.ml diff --git a/pretyping/evd.mli b/engine/evd.mli index f2d8a83350..f2d8a83350 100644 --- a/pretyping/evd.mli +++ b/engine/evd.mli diff --git a/proofs/logic_monad.ml b/engine/logic_monad.ml index cb3e5a1860..c88de133d4 100644 --- a/proofs/logic_monad.ml +++ b/engine/logic_monad.ml @@ -135,46 +135,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 @@ -205,32 +172,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 } @@ -247,27 +207,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 *) @@ -281,9 +235,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 @@ -292,7 +246,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 -> @@ -304,6 +258,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 @@ -313,6 +378,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 ab729aff71..1869f32633 100644 --- a/proofs/logic_monad.mli +++ b/engine/logic_monad.mli @@ -97,9 +97,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. *) @@ -142,16 +181,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 a88c2e20e3..a88c2e20e3 100644 --- a/pretyping/namegen.ml +++ b/engine/namegen.ml diff --git a/pretyping/namegen.mli b/engine/namegen.mli index f66bc6d88c..f66bc6d88c 100644 --- a/pretyping/namegen.mli +++ b/engine/namegen.mli diff --git a/proofs/proofview_monad.ml b/engine/proofview_monad.ml index 6e68cd2e45..6e68cd2e45 100644 --- a/proofs/proofview_monad.ml +++ b/engine/proofview_monad.ml diff --git a/proofs/proofview_monad.mli b/engine/proofview_monad.mli index d2a2e55fb1..d2a2e55fb1 100644 --- a/proofs/proofview_monad.mli +++ b/engine/proofview_monad.mli diff --git a/pretyping/termops.ml b/engine/termops.ml index 937471cf76..937471cf76 100644 --- a/pretyping/termops.ml +++ b/engine/termops.ml diff --git a/pretyping/termops.mli b/engine/termops.mli index 4581e23100..6c680005db 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/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 66f82fcdfc..2e725b46c3 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -77,7 +77,8 @@ 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< [] >> @@ -112,14 +113,14 @@ let rec make_tags loc = function <: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 = mlexpr_of_list make_one_printing_rule let make_empty_check = function | GramNonTerminal(_, t, e, _)-> @@ -141,30 +142,20 @@ 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 @@ -188,6 +179,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 +194,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 +213,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 +222,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 diff --git a/ide/coq.ml b/ide/coq.ml index b7753e6e8a..d061df6fd0 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 diff --git a/ide/coqOps.ml b/ide/coqOps.ml index c6d3149475..2cffdf816e 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,11 @@ 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 module Doc = Document @@ -630,7 +627,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 diff --git a/ide/coqide.ml b/ide/coqide.ml index c0e2281258..6769ce768b 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,7 +315,7 @@ 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); @@ -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,7 +427,7 @@ 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 @@ -467,7 +463,7 @@ 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 + let cmd = local_cd f ^ cmd_make#get ^ " 2>&1" in sn.messages#set "Compilation output:\n"; Buffer.reset last_make_buf; last_make := ""; @@ -477,7 +473,7 @@ let make sn = sn.messages#add 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 @@ -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 @@ -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 occurence" - ~accel:(prefs.modifier_for_navigation^"less"); - item "Next" ~label:"_Next" ~stock:`GO_FORWARD ~callback:Nav.next_occ - ~tooltip:"Next occurence" - ~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 occurence", "less"); + ("Next", "_Next", `GO_FORWARD, Nav.next_occ, "Next occurence", "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; @@ -1214,7 +1143,7 @@ let build_ui () = browse notebook#current_term.messages#add (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 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))); @@ -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 03b3fcd4ee..eccd61d0d9 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 e082bd18c1..83b3142839 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/ideutils.ml b/ide/ideutils.ml index 5892fb3d96..053bba805d 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -74,7 +74,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 +90,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 +140,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 +164,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 +193,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 +238,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 @@ -364,7 +364,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 +375,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/nanoPG.ml b/ide/nanoPG.ml index 805ace935c..0668ad09f4 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 1bd9f587c7..765dc7e59f 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -17,19 +17,58 @@ 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 +(** Generic preferences *) -(* 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" +type obj = { + set : string list -> unit; + get : unit -> string list; +} -let loaded_accel_file = - try get_config_file "coqide.keys" - with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys" +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 +113,335 @@ 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 + +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 () -> ()) - -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; +(** New style preferences *) -} +let cmd_coqtop = + new preference ~name:["cmd_coqtop"] ~init:None ~repr:Repr.(option string) -let use_default_doc_url = "(automatic)" +let cmd_coqc = + new preference ~name:["cmd_coqc"] ~init:"coqc" ~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 cmd_make = + new preference ~name:["cmd_make"] ~init:"make" ~repr:Repr.(string) - global_auto_revert = false; - global_auto_revert_delay = 10000; +let cmd_coqmakefile = + new preference ~name:["cmd_coqmakefile"] ~init:"coq_makefile -o makefile *.v" ~repr:Repr.(string) - auto_save = true; - auto_save_delay = 10000; - auto_save_name = "#","#"; +let cmd_coqdoc = + new preference ~name:["cmd_coqdoc"] ~init:"coqdoc -q -g" ~repr:Repr.(string) - source_language = "coq"; - source_style = "coq_style"; +let source_language = + new preference ~name:["source_language"] ~init:"coq" ~repr:Repr.(string) - read_project = Append_args; - project_file_name = "_CoqProject"; - project_path = None; +let source_style = + new preference ~name:["source_style"] ~init:"coq_style" ~repr:Repr.(string) - encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale; +let global_auto_revert = + new preference ~name:["global_auto_revert"] ~init:false ~repr:Repr.(bool) - automatic_tactics = ["trivial"; "tauto"; "auto"; "omega"; - "auto with *"; "intuition" ]; +let global_auto_revert_delay = + new preference ~name:["global_auto_revert_delay"] ~init:10000 ~repr:Repr.(int) - modifier_for_navigation = "<Control><Alt>"; - modifier_for_templates = "<Control><Shift>"; - modifier_for_tactics = "<Control><Alt>"; - modifier_for_display = "<Alt><Shift>"; - modifiers_valid = "<Alt><Control><Shift>"; +let auto_save = + new preference ~name:["auto_save"] ~init:true ~repr:Repr.(bool) +let auto_save_delay = + new preference ~name:["auto_save_delay"] ~init:10000 ~repr:Repr.(int) - cmd_browse = Flags.browser_cmd_fmt; - cmd_editor = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s"; +let auto_save_name = + new preference ~name:["auto_save_name"] ~init:("#","#") ~repr:Repr.(string_pair) -(* 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 read_project = + let repr = Repr.custom string_of_project_behavior project_behavior_of_string in + new preference ~name:["read_project"] ~init:Append_args ~repr - doc_url = Coq_config.wwwrefman; - library_url = Coq_config.wwwstdlib; +let project_file_name = + new preference ~name:["project_file_name"] ~init:"_CoqProject" ~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 project_path = + new preference ~name:["project_path"] ~init:None ~repr:Repr.(option string) + +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 + +let automatic_tactics = + let init = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ] in + new preference ~name:["automatic_tactics"] ~init ~repr:Repr.(string_list) + +let cmd_print = + new preference ~name:["cmd_print"] ~init:"lpr" ~repr:Repr.(string) + +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 + +let modifier_for_navigation = + new preference ~name:["modifier_for_navigation"] ~init:"<Control><Alt>" ~repr:Repr.(string) + +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) + +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/" + +let modifiers_valid = + new preference ~name:["modifiers_valid"] ~init:"<Alt><Control><Shift>" ~repr:Repr.(string) + +let cmd_browse = + new preference ~name:["cmd_browse"] ~init:Flags.browser_cmd_fmt ~repr:Repr.(string) + +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) + +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 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) + +(** 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 +450,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 +468,60 @@ 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) () - in - let processing_button = GButton.color_button - ~color:(Tags.get_processing_color ()) - ~packing:(table#attach ~left:1 ~top:2) () - in - let error_button = GButton.color_button - ~color:(Tags.get_error_color ()) - ~packing:(table#attach ~left:1 ~top:3) () - in - let error_fg_button = GButton.color_button - ~color:(Tags.get_error_fg_color ()) - ~packing:(table#attach ~left:1 ~top:4) () - 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); + 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 _ = reset_button#connect#clicked ~callback:reset_cb in + 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 () = - 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 - in + let callback () = () 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 +549,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 +653,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 +667,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 +679,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 diff --git a/ide/preferences.mli b/ide/preferences.mli index 1e4f152c23..d815c01ddf 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -12,95 +12,86 @@ 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; - - } +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 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 a795f6331a..e4cc177428 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 52e5572186..3a6b458582 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 c9b57af4cb..09b562530b 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 14cfd0dbfe..6418d1b2e5 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 7dad92ed6f..163bd28b13 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 () = @@ -144,13 +146,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 +156,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 91a8f26cac..1f0e31988a 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 3f5ae4bd55..7d77679ce5 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 211db537ed..30bb48e3f3 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Preferences + class type message_view_signals = object inherit GObj.misc_signals @@ -32,8 +34,6 @@ class type message_view = (** 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 +53,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 @@ -82,11 +88,4 @@ let message_view () : message_view = 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 23c94f4048..457ece0900 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -24,8 +24,6 @@ class type message_view = (** 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 69d460b016..6402789ec3 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -7,6 +7,7 @@ (************************************************************************) open Util +open Preferences class type proof_view = object @@ -193,6 +194,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 8298d9954f..14cbf92eb7 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 25a031d6e5..2ee2884547 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/intf/tacexpr.mli b/intf/tacexpr.mli index 2b37c580ea..ce53680f38 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 @@ -290,7 +295,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 @@ -386,8 +391,8 @@ type raw_tactic_arg = type t_trm = Term.constr type t_utrm = Glob_term.closed_glob_constr -type t_pat = glob_constr_and_expr * constr_pattern -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/environ.ml b/kernel/environ.ml index 109e3830c2..bf12d6c6dc 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -584,7 +584,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/indtypes.ml b/kernel/indtypes.ml index 8c89abe940..e3457006d0 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 @@ -451,17 +456,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 -> @@ -474,21 +492,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 @@ -497,12 +529,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 *) @@ -513,8 +546,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 @@ -528,10 +564,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 @@ -571,6 +611,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/nativelib.ml b/kernel/nativelib.ml index b2142b43c7..331598d85a 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/reduction.ml b/kernel/reduction.ml index b09367dd92..3253cddf7c 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -735,8 +735,8 @@ let vm_conv cv_pb env t1 t2 = try !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> - (* If compilation fails, fall-back to closure 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 = ref (fun cv_pb ?(l2r=false) -> fconv cv_pb l2r (fun _->None)) @@ -747,8 +747,8 @@ let default_conv cv_pb ?(l2r=false) env t1 t2 = try !default_conv ~l2r cv_pb env t1 t2 with Not_found | Invalid_argument _ -> - (* If compilation fails, fall-back to closure conversion *) - fconv cv_pb false (fun _->None) env t1 t2 + Pp.msg_warning (Pp.str "Compilation failed, falling back to standard conversion"); + fconv cv_pb false (fun _->None) env t1 t2 let default_conv_leq = default_conv CUMUL (* diff --git a/lib/cMap.ml b/lib/cMap.ml index cf590d96c3..876f847365 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 23d3801e08..cd3d2f5b19 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 ac0b6f722e..315d28cebd 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -156,23 +156,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} *) @@ -183,9 +172,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 @@ -193,7 +180,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 b62b9f28a9..7c20c035a5 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/flags.ml b/lib/flags.ml index ab4ac03f80..9a0d4b5ec1 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 8e37136560..29a0bbef01 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 f902eded03..8e900cd581 100644 --- a/lib/hMap.ml +++ b/lib/hMap.ml @@ -329,4 +329,18 @@ struct Int.Map.map fs s end + module Monad(M : CMap.MonadS) = + struct + module IntM = Int.Map.Monad(M) + module ExtM = Map.Monad(M) + open M + + let fold f s accu = + let ff _ m accu = ExtM.fold f m accu in + IntM.fold ff s accu + + let fold_left _ _ _ = assert false + let fold_right _ _ _ = assert false + end + end diff --git a/lib/system.ml b/lib/system.ml index 27e21204cc..26bf780101 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 file_exists_respecting_case f = diff --git a/lib/system.mli b/lib/system.mli index 051e92f166..eb29b69701 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/myocamlbuild.ml b/myocamlbuild.ml index 097a104259..73ef7e1eda 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/egramcoq.ml b/parsing/egramcoq.ml index 01194c60d0..d9eb5d4126 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -258,8 +258,12 @@ type all_grammar_command = 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 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)]); 1 diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index c232ae31ad..96d5279a75 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/funind/recdef.ml b/plugins/funind/recdef.ml index d3979748e1..b5a42b3078 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1326,7 +1326,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 675321d99c..31d051cb4d 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 b4f305dd76..63485ab269 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 2812e36edd..ef1169342f 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -18,6 +18,8 @@ open Pp open Mutils +open Proofview +open Goptions (** * Debug flag @@ -37,6 +39,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 +408,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") @@ -837,7 +887,7 @@ struct let is_convertible gl t1 t2 = - Reductionops.is_conv (Tacmach.pf_env gl) (Tacmach.project gl) t1 t2 + Reductionops.is_conv (Tacmach.New.pf_env gl) (Goal.sigma gl) t1 t2 let parse_zop gl (op,args) = match kind_of_term op with @@ -1094,10 +1144,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 +1167,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 (Goal.env gl) (Goal.sigma gl) term in + let sort = Typing.sort_of (Goal.env gl) (ref (Goal.sigma 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 +1191,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 +1430,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 + begin fun gl -> + 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.New.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 +1490,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 +1545,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 +1706,78 @@ 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 + begin + fun gl -> + let concl = Tacmach.New.pf_concl gl in + let hyps = Tacmach.New.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 + begin + fun gl -> + 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.New.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 +1790,42 @@ 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 + begin + fun gl -> + let concl = Tacmach.New.pf_concl gl in + let hyps = Tacmach.New.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 +1981,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 +2044,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 +2054,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 +2075,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 +2098,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 1ac44a4260..62f0ae5037 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 88c1a78366..0247204490 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 a07cbec68c..465c7afcee 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/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 new file mode 100644 index 0000000000..856ec0db5f --- /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 e590958ccf..f73a15dba0 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml @@ -30,8 +30,7 @@ open Declare open Decl_kinds open Entries open Misctypes - -DECLARE PLUGIN "newring_plugin" +open Newring_ast (****************************************************************************) (* controlled reduction *) @@ -105,13 +104,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 +112,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 +129,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, @@ -350,20 +340,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" @@ -595,13 +571,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 @@ -609,10 +578,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 @@ -716,41 +681,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") @@ -775,20 +711,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. *) @@ -834,13 +756,6 @@ let ring_lookup (f:glob_tactic_expr) lH rl t = 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 - - - (***********************************************************************) let new_field_path = @@ -914,19 +829,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" @@ -1073,15 +975,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 @@ -1106,21 +999,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 @@ -1149,9 +1027,3 @@ let field_lookup (f:glob_tactic_expr) lH rl t = 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 diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli new file mode 100644 index 0000000000..4bd3383d65 --- /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 0000000000..c26fcc8d1f --- /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 a98392f1e0..7d6c495889 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/pretyping.mllib b/pretyping/pretyping.mllib index a644e3d107..b59589bda2 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -1,7 +1,4 @@ Locusops -Termops -Namegen -Evd Reductionops Inductiveops Vnorm diff --git a/printing/pptactic.ml b/printing/pptactic.ml index a669aef9a8..e8ccd29c8a 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; diff --git a/printing/pptactic.mli b/printing/pptactic.mli index fa91aefcf3..30b9483db7 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 166a6675c1..1631bda377 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/pfedit.ml b/proofs/pfedit.ml index d024c01ba5..e48a336a6e 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_env ~ctx Environ.empty_env 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 c02b909164..10e7b758da 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) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index b5dd5ef85f..995e90efcc 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 32bf5576fa..1bd701cb9b 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 de6d605670..11b7d07d05 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -887,7 +887,7 @@ module Unsafe = struct end - +module UnsafeRepr = Proof.Unsafe (** {7 Notations} *) diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 5a9e7f39f0..98e1477ff1 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -405,6 +405,15 @@ module Unsafe : sig val mark_as_goal : proofview -> Evar.t -> proofview end +(** 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 + (** {7 Notations} *) module Notations : sig diff --git a/stm/lemmas.ml b/stm/lemmas.ml index a7ef96c668..df10e7376a 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -327,7 +327,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 @@ -345,12 +346,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 @@ -359,8 +364,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 @@ -482,7 +490,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 @@ -492,7 +500,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 6556aa2297..dca6afe19b 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/tactics/class_tactics.ml b/tactics/class_tactics.ml index 80f47c680f..365d61e170 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 *) @@ -184,7 +197,7 @@ let with_prods nprods poly (c, clenv) f gls = 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 @@ -266,7 +279,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 } @@ -281,7 +295,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) = @@ -363,7 +377,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) @@ -384,8 +398,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 @@ -462,7 +487,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 @@ -470,22 +495,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 @@ -508,11 +536,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 } @@ -527,16 +555,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; @@ -580,16 +630,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 = @@ -599,7 +647,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' @@ -608,6 +656,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. *) diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 34f87c6cf0..b7dc7b4931 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -33,27 +33,35 @@ 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 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 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 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 +90,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"; @@ -138,19 +146,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 begin fun gl -> + let d = Tacmach.New.pf_last_hyp gl in + let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) d in + e_trivial_fail_db db_list (Hint_db.add_list hintl local_db) + end in + Proofview.Goal.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 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 @@ -165,14 +175,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) -> Proofview.V82.tactic (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 (unify_e_resolve poly st (term,cl)) - (e_trivial_fail_db db_list local_db)) + Tacticals.New.tclTHEN (Proofview.V82.tactic (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 @@ -224,7 +234,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 @@ -262,7 +272,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 diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 7073e8a2b8..b55c70fa12 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/equality.ml b/tactics/equality.ml index d012427a08..ec0e1d2f4e 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1662,7 +1662,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 diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml index 09a98bc8cc..c1e4d72e38 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 2df6bb04a2..47d9efda57 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/tactics.ml b/tactics/tactics.ml index 0235126cc0..4c53d5340b 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -126,6 +126,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 +157,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) } (*********************************************) @@ -4397,6 +4410,49 @@ 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 @@ -4438,6 +4494,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*) @@ -4449,7 +4509,6 @@ let abstract_subproof id gk tac = let eff = Safe_typing.sideff_of_con (Global.safe_env ()) cst in let effs = cons_side_effects 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 <*> diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index b4c7bffa9c..59c5792377 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -159,6 +159,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]) diff --git a/test-suite/bugs/closed/3911.v b/test-suite/bugs/closed/3911.v new file mode 100644 index 0000000000..b289eafbf4 --- /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 0000000000..4031dcc45e --- /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 0000000000..e20a6e97f0 --- /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 3daf452132..d684e8cf4b 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 0000000000..6b287324cc --- /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 0000000000..f9ac9be2c8 --- /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 0000000000..fd95503e6b --- /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 0000000000..0d661de9c4 --- /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 0000000000..ce4f509cad --- /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 0000000000..6aa6b4932e --- /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 0000000000..cfad763572 --- /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 0000000000..b470eb229b --- /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 0000000000..2d0d1930f1 --- /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 0000000000..e77bdbc652 --- /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 0000000000..165813084d --- /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/bugs/opened/3956.v b/test-suite/bugs/opened/3956.v new file mode 100644 index 0000000000..94c0c6744c --- /dev/null +++ b/test-suite/bugs/opened/3956.v @@ -0,0 +1,141 @@ +(* -*- mode: coq; mode: visual-line -*- *) +Set Universe Polymorphism. +Set Primitive Projections. +Close Scope nat_scope. + +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Arguments pair {A B} _ _. +Arguments fst {A B} _ / . +Arguments snd {A B} _ / . +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. + +Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. +Definition Type2 := Eval hnf in let gt := (Type1 : Type@{i}) in Type@{i}. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. +Definition concat {A} {x y z : A} (p : x = y) (q : y = z) : x = z + := match p, q with idpath, idpath => idpath end. + +Definition path_prod {A B : Type} (z z' : A * B) +: (fst z = fst z') -> (snd z = snd z') -> (z = z'). +Proof. + destruct z, z'; simpl; intros [] []; reflexivity. +Defined. + +Module Type TypeM. + Parameter m : Type2. +End TypeM. + +Module ProdM (XM : TypeM) (YM : TypeM) <: TypeM. + Definition m := XM.m * YM.m. +End ProdM. + +Module Type FunctionM (XM YM : TypeM). + Parameter m : XM.m -> YM.m. +End FunctionM. + +Module IdmapM (XM : TypeM) <: FunctionM XM XM. + Definition m := (fun x => x) : XM.m -> XM.m. +End IdmapM. + +Module Type HomotopyM (XM YM : TypeM) (fM gM : FunctionM XM YM). + Parameter m : forall x, fM.m x = gM.m x. +End HomotopyM. + +Module ComposeM (XM YM ZM : TypeM) + (gM : FunctionM YM ZM) (fM : FunctionM XM YM) + <: FunctionM XM ZM. + Definition m := (fun x => gM.m (fM.m x)). +End ComposeM. + +Module Type CorecM (YM ZM : TypeM) (fM : FunctionM YM ZM) + (XM : TypeM) (gM : FunctionM XM ZM). + Parameter m : XM.m -> YM.m. + Parameter m_beta : forall x, fM.m (m x) = gM.m x. +End CorecM. + +Module Type CoindpathsM (YM ZM : TypeM) (fM : FunctionM YM ZM) + (XM : TypeM) (hM kM : FunctionM XM YM). + Module fhM := ComposeM XM YM ZM fM hM. + Module fkM := ComposeM XM YM ZM fM kM. + Declare Module mM (pM : HomotopyM XM ZM fhM fkM) + : HomotopyM XM YM hM kM. +End CoindpathsM. + +Module Type Comodality (XM : TypeM). + Parameter m : Type2. + Module mM <: TypeM. + Definition m := m. + End mM. + Parameter from : m -> XM.m. + Module fromM <: FunctionM mM XM. + Definition m := from. + End fromM. + Declare Module corecM : CorecM mM XM fromM. + Declare Module coindpathsM : CoindpathsM mM XM fromM. +End Comodality. + +Module Comodality_Theory (F : Comodality). + + Module F_functor_M (XM YM : TypeM) (fM : FunctionM XM YM) + (FXM : Comodality XM) (FYM : Comodality YM). + Module f_o_from_M <: FunctionM FXM.mM YM. + Definition m := fun x => fM.m (FXM.from x). + End f_o_from_M. + Module mM := FYM.corecM FXM.mM f_o_from_M. + Definition m := mM.m. + End F_functor_M. + + Module F_prod_cmp_M (XM YM : TypeM) + (FXM : Comodality XM) (FYM : Comodality YM). + Module PM := ProdM XM YM. + Module PFM := ProdM FXM FYM. + Module fstM <: FunctionM PM XM. + Definition m := @fst XM.m YM.m. + End fstM. + Module sndM <: FunctionM PM YM. + Definition m := @snd XM.m YM.m. + End sndM. + Module FPM := F PM. + Module FfstM := F_functor_M PM XM fstM FPM FXM. + Module FsndM := F_functor_M PM YM sndM FPM FYM. + Definition m : FPM.m -> PFM.m + := fun z => (FfstM.m z , FsndM.m z). + End F_prod_cmp_M. + + Module isequiv_F_prod_cmp_M + (XM YM : TypeM) + (FXM : Comodality XM) (FYM : Comodality YM). + (** The comparison map *) + Module cmpM := F_prod_cmp_M XM YM FXM FYM. + Module FPM := cmpM.FPM. + (** We construct an inverse to it using corecursion. *) + Module prod_from_M <: FunctionM cmpM.PFM cmpM.PM. + Definition m : cmpM.PFM.m -> cmpM.PM.m + := fun z => ( FXM.from (fst z) , FYM.from (snd z) ). + End prod_from_M. + Module cmpinvM <: FunctionM cmpM.PFM FPM + := FPM.corecM cmpM.PFM prod_from_M. + (** We prove the first homotopy *) + Module cmpinv_o_cmp_M <: FunctionM FPM FPM + := ComposeM FPM cmpM.PFM FPM cmpinvM cmpM. + Module idmap_FPM <: FunctionM FPM FPM + := IdmapM FPM. + Module cip_FPM := FPM.coindpathsM FPM cmpinv_o_cmp_M idmap_FPM. + Module cip_FPHM <: HomotopyM FPM cmpM.PM cip_FPM.fhM cip_FPM.fkM. + Definition m : forall x, cip_FPM.fhM.m@{i j} x = cip_FPM.fkM.m@{i j} x. + Proof. + intros x. + refine (concat (cmpinvM.m_beta@{i j} (cmpM.m@{i j} x)) _). + apply path_prod@{i i i}; simpl. + - exact (cmpM.FfstM.mM.m_beta@{i j} x). + - exact (cmpM.FsndM.mM.m_beta@{i j} x). + Defined. + Fail End cip_FPHM. +(* End isequiv_F_prod_cmp_M. + +End Comodality_Theory.*) diff --git a/test-suite/failure/positivity.v b/test-suite/failure/positivity.v index d44bccdfa3..30762a77f3 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 30a2a7429c..d6e590af30 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 0000000000..46174e4810 --- /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 0000000000..3f6b9cb39f --- /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 0000000000..676b97878f --- /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 0000000000..8336f6a806 --- /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 de615301d0..aaffc0978d 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 e0e5d94d82..2437184a93 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 0a0bf0dea0..c8ed95cd45 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 934a632dd1..4b92d57082 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 @@ -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 110d306022..be50b0e1c7 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 64ce66d2d1..0000000000 --- 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 c111137571..2cdb66aa74 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 d610a0558d..c3570f811b 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 be796e6956..a6254b2a44 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/ocamllibdep.mll b/tools/ocamllibdep.mll new file mode 100644 index 0000000000..4e5edcf6c2 --- /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/coqinit.ml b/toplevel/coqinit.ml index 19d4363ab8..f0cac72d0a 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 d67559d77f..3c87533a93 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -481,7 +481,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 7616bfff65..9864182a07 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -167,13 +167,15 @@ type ml_tactic_grammar_obj = { (** 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/mltop.ml b/toplevel/mltop.ml index a7fb7a58f2..fa5ed7bbd7 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 11857b5724..738e93e2f9 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -605,14 +605,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] @@ -800,6 +802,36 @@ let solve_by_tac name evi t poly ctx = Inductiveops.control_only_guard (Global.env ()) (fst body); (fst body), entry.Entries.const_entry_type, 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 = Term_typing.handle_entry_side_effects env entry in + let ty = entry.Entries.const_entry_type in + let (body, cstr), eff = Future.force entry.Entries.const_entry_body in + assert(Declareops.side_effects_is_empty 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 @@ -849,8 +881,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_env ~ctx:prg.prg_ctx Environ.empty_env 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 9e67eef008..9c32bddad4 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 a5d8450b9d..1144ffb940 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 ()); |