diff options
557 files changed, 13226 insertions, 14599 deletions
diff --git a/.gitignore b/.gitignore index bea12162c..64c49b008 100644 --- a/.gitignore +++ b/.gitignore @@ -43,12 +43,14 @@ TAGS .DS_Store .pc bin/ +_build_ci _build myocamlbuild_config.ml config/Makefile config/coq_config.ml config/Info-*.plist dev/ocamldebug-coq +dev/camlp4.dbg plugins/micromega/csdpcert kernel/byterun/dllcoqrun.so coqdoc.sty @@ -121,10 +123,10 @@ g_*.ml ide/project_file.ml parsing/compat.ml parsing/cLexer.ml -ltac/coretactics.ml -ltac/extratactics.ml -ltac/extraargs.ml -ltac/profile_ltac_tactics.ml +plugins/ltac/coretactics.ml +plugins/ltac/extratactics.ml +plugins/ltac/extraargs.ml +plugins/ltac/profile_ltac_tactics.ml ide/coqide_main.ml plugins/ssrmatching/ssrmatching.ml @@ -157,5 +159,8 @@ dev/myinclude /doc/refman/Reference-Manual.hoptind /doc/refman/Reference-Manual.optidx /doc/refman/Reference-Manual.optind + user-contrib .*.sw* +test-suite/.lia.cache +test-suite/.nra.cache @@ -1,5 +1,7 @@ -FLG -rectypes -thread +FLG -rectypes -thread -safe-string +S ltac +B ltac S config B config S ide @@ -32,6 +34,8 @@ S stm B stm S toplevel B toplevel +S vernac +B vernac S tools B tools @@ -1,3 +1,27 @@ +Changes beyond V8.6 +=================== + +Tactics + +- New tactic "extensionality in H" which applies (possibly dependent) + functional extensionality in H supposed to be a quantified equality + until giving a bare equality. + +Standard Library + +- New file PropExtensionality.v to explicitly work in the axiomatic + context of propositional extensionality. +- New file SetoidChoice.v axiomatically providing choice over setoids, + and, consequently, choice of representatives in equivalence classes. + Various proof-theoretic characterizations of choice over setoids in + file ChoiceFacts.v. + +- IZR (Reals) has been changed to produce a compact representation of + integers. As a consequence, IZR is no longer convertible to INR and + lemmas such as INR_IZR_INZ should be used instead. +- Real constants are now represented using IZR rather than R0 and R1; + this might cause rewriting rules to fail to apply to constants. + Changes from V8.6beta1 to V8.6 ============================== @@ -29,17 +29,18 @@ WHAT DO YOU NEED ? To compile Coq V8.6 yourself, you need: - - Objective Caml version 4.01.0 or later + - OCaml version 4.02.1 or later (available at http://caml.inria.fr/) + OCaml version 4.02.0 is not supported because of a severe performance + issue increasing compilation time. + - 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, for instance, Objective Caml version 4.02.1 - is then needed or a patched version of 4.01.0 as e.g. version - 4.01.0-4 in Debian Jessie) + less well supported) - GNU Make version 3.81 or later @@ -65,8 +66,8 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). computer and that "ocamlc" (or, better, its native code version "ocamlc.opt") lies in a directory which is present in your $PATH environment variable. At the time of writing this sentence, all - versions of Objective Caml later or equal to 4.01.0 are - supported to the exception of Objective Caml 4.02.0. + versions of Objective Caml later or equal to 4.02.1 are + supported. To get Coq in native-code, (it runs 4 to 10 times faster than bytecode, but it takes more time to get compiled and the binary is diff --git a/INSTALL.ide b/INSTALL.ide index cb7ca325f..513e37c91 100644 --- a/INSTALL.ide +++ b/INSTALL.ide @@ -22,7 +22,7 @@ Else, read the rest of this document to compile your own CoqIde. COMPILATION REQUIREMENTS -- OCaml >= 4.01 with native threads support. +- OCaml >= 4.02.1 with native threads support. - make world must succeed. - The graphical toolkit GTK+ 2.x. See http://www.gtk.org. The official supported version is at least 2.24.x. @@ -1,5 +1,15 @@ +# TODO: Move to META.in once coq_makefile2 is merged. +# We need to reuse: +# - The variable substitution mechanism. +# - Sourcing of "coq_install_path" and "coq_version" variables. +# +# With this rules, we would have: +# version = ${coq_version} +# and +# linkopts(byte) = "-dllpath ${coq_install_path}/kernel/byterun/ -dllib -lcoqrun" + description = "The Coq Proof Assistant Plugin API" -version = "8.6" +version = "8.7" directory = "" requires = "camlp5" @@ -7,7 +17,7 @@ requires = "camlp5" package "config" ( description = "Coq Configuration Variables" - version = "8.6" + version = "8.7" directory = "config" @@ -16,7 +26,7 @@ package "config" ( package "lib" ( description = "Base Coq Library" - version = "8.6" + version = "8.7" directory = "lib" @@ -33,22 +43,16 @@ package "lib" ( package "vm" ( description = "Coq VM" + version = "8.7" - version = "8.6" - -# EJGA FIXME: Unfortunately dllpath is dependent on the type of Coq -# install. In a local one we'll want kernel/byterun, in a non-local -# one we want to set it to coqlib. We should thus generate this file -# at configure time, but let's hear for some more feedback from -# experts. + directory = "kernel/byterun" -# Enable for local native & byte builds -# directory = "kernel/byterun" +# We should generate this file at configure time for local byte builds +# to work properly. -# Enable for local byte builds and set up properly -# linkopts(byte) = "-dllpath /path/to/coq/kernel/byterun/ -dllib -lcoqrun" +# Enable this setting for local byte builds, disabling the one below. +# linkopts(byte) = "-dllpath path_to_coq/kernel/byterun/ -dllib -lcoqrun" -# Disable for local byte builds linkopts(byte) = "-dllib -lcoqrun" linkopts(native) = "-cclib -lcoqrun" @@ -56,8 +60,8 @@ package "vm" ( package "kernel" ( - description = "The Coq's Kernel" - version = "8.6" + description = "Coq's Kernel" + version = "8.7" directory = "kernel" @@ -71,7 +75,7 @@ package "kernel" ( package "library" ( description = "Coq Libraries (vo) support" - version = "8.6" + version = "8.7" requires = "coq.kernel" @@ -85,7 +89,7 @@ package "library" ( package "intf" ( description = "Coq Public Data Types" - version = "8.6" + version = "8.7" requires = "coq.library" @@ -95,8 +99,8 @@ package "intf" ( package "engine" ( - description = "Coq Libraries (vo) support" - version = "8.6" + description = "Coq Tactic Engine" + version = "8.7" requires = "coq.library" directory = "engine" @@ -109,7 +113,7 @@ package "engine" ( package "pretyping" ( description = "Coq Pretyper" - version = "8.6" + version = "8.7" requires = "coq.engine" directory = "pretyping" @@ -122,7 +126,7 @@ package "pretyping" ( package "interp" ( description = "Coq Term Interpretation" - version = "8.6" + version = "8.7" requires = "coq.pretyping" directory = "interp" @@ -135,7 +139,7 @@ package "interp" ( package "grammar" ( description = "Coq Base Grammar" - version = "8.6" + version = "8.7" requires = "coq.interp" directory = "grammar" @@ -147,7 +151,7 @@ package "grammar" ( package "proofs" ( description = "Coq Proof Engine" - version = "8.6" + version = "8.7" requires = "coq.interp" directory = "proofs" @@ -160,7 +164,7 @@ package "proofs" ( package "parsing" ( description = "Coq Parsing Engine" - version = "8.6" + version = "8.7" requires = "coq.proofs" directory = "parsing" @@ -172,8 +176,8 @@ package "parsing" ( package "printing" ( - description = "Coq Printing Libraries" - version = "8.6" + description = "Coq Printing Engine" + version = "8.7" requires = "coq.parsing" directory = "printing" @@ -185,8 +189,8 @@ package "printing" ( package "tactics" ( - description = "Coq Tactics" - version = "8.6" + description = "Coq Basic Tactics" + version = "8.7" requires = "coq.printing" directory = "tactics" @@ -196,12 +200,25 @@ package "tactics" ( ) +package "vernac" ( + + description = "Coq Vernacular Interpreter" + version = "8.7" + + requires = "coq.tactics" + directory = "vernac" + + archive(byte) = "vernac.cma" + archive(native) = "vernac.cmxa" + +) + package "stm" ( description = "Coq State Transactional Machine" - version = "8.6" + version = "8.7" - requires = "coq.tactics" + requires = "coq.vernac" directory = "stm" archive(byte) = "stm.cma" @@ -212,7 +229,7 @@ package "stm" ( package "toplevel" ( description = "Coq Toplevel" - version = "8.6" + version = "8.7" requires = "coq.stm" directory = "toplevel" @@ -225,7 +242,7 @@ package "toplevel" ( package "highparsing" ( description = "Coq Extra Parsing" - version = "8.6" + version = "8.7" requires = "coq.toplevel" directory = "parsing" @@ -235,15 +252,42 @@ package "highparsing" ( ) +package "idetop" ( + + description = "Coq IDE Libraries" + version = "8.7" + + requires = "coq.toplevel" + directory = "ide" + + archive(byte) = "coqidetop.cma" + archive(native) = "coqidetop.cmxa" + +) + +package "ide" ( + + description = "Coq IDE Libraries" + version = "8.7" + +# XXX Add GTK + requires = "coq.toplevel" + directory = "ide" + + archive(byte) = "ide.cma" + archive(native) = "ide.cmxa" + +) + package "ltac" ( description = "Coq LTAC Plugin" - version = "8.6" + version = "8.7" requires = "coq.highparsing" - directory = "ltac" + directory = "plugins/ltac" - archive(byte) = "ltac.cma" - archive(native) = "ltac.cmxa" + archive(byte) = "ltac_plugin.cmo" + archive(native) = "ltac_plugin.cmx" ) @@ -231,7 +231,7 @@ cacheclean: find theories plugins test-suite -name '.*.aux' -delete cleanconfig: - rm -f config/Makefile config/coq_config.ml myocamlbuild_config.ml dev/ocamldebug-v7 config/Info-*.plist + rm -f config/Makefile config/coq_config.ml myocamlbuild_config.ml dev/ocamldebug-coq dev/camlp4.dbg config/Info-*.plist distclean: clean cleanconfig cacheclean diff --git a/Makefile.build b/Makefile.build index 95df69c2d..01cc4d878 100644 --- a/Makefile.build +++ b/Makefile.build @@ -220,7 +220,7 @@ CINCLUDES= -I $(CAMLHLIB) $(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN) cd $(dir $(LIBCOQRUN)) && \ - $(OCAMLFIND) ocamlmklib -oc $(COQRUN) $(foreach u,$(BYTERUN),$(notdir $(u))) + $(OCAMLFIND) ocamlmklib -oc $(COQRUN) $(notdir $(BYTERUN)) kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' \ @@ -440,9 +440,9 @@ $(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkm # fake_ide : for debugging or test-suite purpose, a fake ide simulating # a connection to coqtop -ideslave -FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo ide/document.cmo \ +FAKEIDECMO:= lib/clib.cma lib/cErrors.cmo lib/spawn.cmo ide/document.cmo \ ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo ide/xml_printer.cmo \ - ide/xmlprotocol.cmo tools/fake_ide.cmo + ide/richpp.cmo ide/xmlprotocol.cmo tools/fake_ide.cmo $(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPLOOPCMA:.cma=$(BESTDYN)) $(SHOW)'OCAMLBEST -o $@' @@ -505,6 +505,12 @@ test-suite: world $(ALLSTDLIB).v # but the -include mechanism should already ensure that we have # up-to-date dependencies. +# Specific rule for kernel.cma, with $(VMBYTEFLAGS). +# This helps loading dllcoqrun.so during an ocamldebug +kernel/kernel.cma: kernel/kernel.mllib + $(SHOW)'OCAMLC -a -o $@' + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(VMBYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) + %.cma: %.mllib $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) @@ -591,7 +597,7 @@ plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLLEX $<' $(HIDE)$(OCAMLLEX) -o $@ "$*.mll" -%.ml: %.ml4 | $(CAMLP4DEPS) +%.ml: %.ml4 $(CAMLP4DEPS) $(SHOW)'CAMLP4O $<' $(HIDE)$(CAMLP4O) -I $(MYCAMLP4LIB) $(PR_O) \ $(CAMLP4DEPS) $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@ diff --git a/Makefile.common b/Makefile.common index a2b59a93b..1e71bcf7d 100644 --- a/Makefile.common +++ b/Makefile.common @@ -53,16 +53,16 @@ INSTALLSH:=./install.sh MKDIR:=install -d CORESRCDIRS:=\ - config lib kernel kernel/byterun library \ - proofs tactics pretyping interp stm \ - toplevel parsing printing intf engine ltac + config lib kernel intf kernel/byterun library \ + engine pretyping interp proofs parsing printing \ + tactics vernac stm toplevel PLUGINDIRS:=\ omega romega micromega quote \ setoid_ring extraction fourier \ cc funind firstorder derive \ rtauto nsatz syntax decl_mode btauto \ - ssrmatching ltac + ssrmatching ltac SRCDIRS:=\ $(CORESRCDIRS) \ @@ -77,14 +77,13 @@ BYTERUN:=$(addprefix kernel/byterun/, \ coq_fix_code.o coq_memory.o coq_values.o coq_interp.o ) # LINK ORDER: -# Beware that highparsing.cma should appear before ltac.cma # respecting this order is useful for developers that want to load or link # the libraries directly CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma library/library.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 ltac/ltac.cma + parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \ + stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma @@ -123,12 +122,12 @@ DERIVECMO:=plugins/derive/derive_plugin.cmo LTACCMO:=plugins/ltac/ltac_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo -PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ +PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ $(QUOTECMO) $(RINGCMO) \ $(FOURIERCMO) $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(NATSYNTAXCMO) $(OTHERSYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) $(LTACCMO) + $(DERIVECMO) $(SSRMATCHINGCMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) diff --git a/Makefile.dev b/Makefile.dev index 1f81edc2c..ea6b8b919 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -15,21 +15,18 @@ .PHONY: devel printers -DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/printers.cma +DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo devel: printers -printers: $(DEBUGPRINTERS) - -dev/printers.cma: dev/printers.mllib - $(SHOW)'Testing $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(SYSCMA) $(P4CMA) $(filter-out %.mllib, $^) -o test-printer - @rm -f test-printer - $(SHOW)'OCAMLC -a $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(SYSCMA) $(P4CMA) $(filter-out %.mllib, $^) -linkall -a -o $@ - -dev/%.mllib.d: dev/%.mllib | $(OCAMLLIBDEP) $(GENFILES) - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) -I dev "$<" $(TOTARGET) +printers: $(CORECMA) $(DEBUGPRINTERS) dev/camlp4.dbg + +ifeq ($(CAMLP4),camlp5) +dev/camlp4.dbg: + echo "load_printer gramlib.cma" > $@ +else +dev/camlp4.dbg: + echo "load_printer camlp4lib.cma" > $@ +endif ############ # revision @@ -124,10 +121,9 @@ pretyping: pretyping/pretyping.cma highparsing: parsing/highparsing.cma stm: stm/stm.cma toplevel: toplevel/toplevel.cma -ltac: ltac/ltac.cma .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping -.PHONY: engine highparsing stm toplevel ltac +.PHONY: engine highparsing stm toplevel ###################### ### 3) theories files @@ -186,6 +182,7 @@ RTAUTOVO:=$(filter plugins/rtauto/%, $(PLUGINSVO)) EXTRACTIONVO:=$(filter plugins/extraction/%, $(PLUGINSVO)) CCVO:= DERIVEVO:=$(filter plugins/derive/%, $(PLUGINSVO)) +LTACVO:=$(filter plugins/ltac/%, $(PLUGINSVO)) omega: $(OMEGAVO) $(OMEGACMO) $(ROMEGAVO) $(ROMEGACMO) micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT) @@ -197,9 +194,10 @@ funind: $(FUNINDCMO) $(FUNINDVO) cc: $(CCVO) $(CCCMO) rtauto: $(RTAUTOVO) $(RTAUTOCMO) btauto: $(BTAUTOVO) $(BTAUTOCMO) +ltac: $(LTACVO) $(LTACCMO) .PHONY: omega micromega setoid_ring nsatz extraction -.PHONY: fourier funind cc rtauto btauto +.PHONY: fourier funind cc rtauto btauto ltac ################################# ### Misc other development rules diff --git a/Makefile.install b/Makefile.install index 4800ea0b9..bde035551 100644 --- a/Makefile.install +++ b/Makefile.install @@ -104,11 +104,12 @@ install-library: $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(MKDIR) $(FULLCOQLIB)/user-contrib + $(MKDIR) $(FULLCOQLIB)/kernel/byterun ifndef CUSTOM - $(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB) + $(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)/kernel/byterun endif ifeq ($(BEST),opt) - $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB) + $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)/kernel/byterun $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSOPT) endif # csdpcert is not meant to be directly called by the user; we install diff --git a/README.ci b/README.ci new file mode 100644 index 000000000..dcf93cf00 --- /dev/null +++ b/README.ci @@ -0,0 +1,77 @@ +**WARNING:** This document is a work in progress and intended as a RFC. +If you are not a Coq Developer, don't follow this instructions yet. + +Introduction +============ + +The Coq Travis CI infrastructure is meant to provide lightweight +automatics testing of pull requests. + +More comprehensive testing is the responsability of Coq's [Jenkins CI +server](https://ci.inria.fr/coq/) see, [XXX: add document] for +instructions on how to add your development to Jenkins. + +How to submit your development for Coq Travis CI +================================================ + +Travis CI provides a convenient way to perform testing of Coq changes +versus a set of curated libraries. + +Are you an author of a Coq library who would be interested in having +the latest Coq changes validated against your development? + +If so, keep reading! Getting Coq changes tested against your library +is easy, all that you need to do is: + +1.- Put you development in a public repository tracking coq trunk. +2.- Make sure that your development builds in less than 35 minutes. +3.- Submit a PR adding you development. +4.- ? +5.- Profit! Your library is now part of Coq's continous integration! + +Note that by partipating in this program, you assume a reasonable +compromise to discuss and eventually integrate compatibility changes +upstream. + +Get in touch with us to discuss any special need your development may +have. + +Maintaining your contribution manually [current method] +====================================== + +To add your contribution to the Coq Travis CI set, add a script for +building your library to `dev/ci/`, update `.travis.yml` and +`Makefile.ci`. Then, submit a PR. + +Maintaining your contribution as an OPAM package [work in progress] [to be implemented] +================================================ + +You can also provide an opam package for your contribution XXX at +https://github.com/coq/opam-coq-archive + +Then, add a `ci-opam-XXX` target to the `.travis.yml` file, the +package XXX.dev will be tested against each Coq commit and pull +request. + +- TODO: The main question here is what to do with `.opam` caching. We + could disable it altogether, however this will have an impact. We + could install a dummy Coq package, but `coq-*` dependencies will be + botched too. Need to think more. + +PR Overlays [work in progress] [to be implemented] +=========== + +It is common for PR to break some of the external tests. To this +purpose, we provide a method for particular PR to overlay the +repositories of some of the tests so they can provide fixed +developments. + +The general idea is that the PR author will drop a file +`dev/ci/overlays/$branch.overlay` where branch name is taken from +`${TRAVIS_PULL_REQUEST_BRANCH:-$TRAVIS_BRANCH}` +that is to say, the name of the original branch for the PR. + +The `.overlay` file will contain a set of variables that will be used +to do the corresponding `opam pin` or to overload the corresponding +git repositories, etc... + diff --git a/checker/Makefile b/checker/Makefile deleted file mode 100644 index 2bcc9d365..000000000 --- a/checker/Makefile +++ /dev/null @@ -1,88 +0,0 @@ -OCAMLC=ocamlc -OCAMLOPT=ocamlopt - -COQSRC=.. - -MLDIRS=-I $(COQSRC)/config -I $(COQSRC)/lib -I $(COQSRC)/kernel -I +camlp4 -BYTEFLAGS=$(MLDIRS) -OPTFLAGS=$(MLDIRS) - -CHECKERNAME=coqchk - -BINARIES=../bin/$(CHECKERNAME)$(EXE) ../bin/$(CHECKERNAME).opt$(EXE) -MCHECKERLOCAL :=\ - declarations.cmo environ.cmo \ - closure.cmo reduction.cmo \ - type_errors.cmo \ - modops.cmo \ - inductive.cmo typeops.cmo \ - indtypes.cmo subtyping.cmo mod_checking.cmo \ -validate.cmo \ - safe_typing.cmo check.cmo \ - check_stat.cmo checker.cmo - -MCHECKER:=\ - $(COQSRC)/config/coq_config.cmo \ - $(COQSRC)/lib/pp_control.cmo $(COQSRC)/lib/pp.cmo $(COQSRC)/lib/compat.cmo \ - $(COQSRC)/lib/util.cmo $(COQSRC)/lib/option.cmo $(COQSRC)/lib/hashcons.cmo \ - $(COQSRC)/lib/system.cmo $(COQSRC)/lib/flags.cmo \ - $(COQSRC)/lib/predicate.cmo $(COQSRC)/lib/rtree.cmo \ - $(COQSRC)/kernel/names.cmo $(COQSRC)/kernel/univ.cmo \ - $(COQSRC)/kernel/esubst.cmo term.cmo \ - $(MCHECKERLOCAL) - -all: $(BINARIES) - -byte : ../bin/$(CHECKERNAME)$(EXE) -opt : ../bin/$(CHECKERNAME).opt$(EXE) - -check.cma: $(MCHECKERLOCAL) - ocamlc $(BYTEFLAGS) -a -o $@ $(MCHECKER) - -check.cmxa: $(MCHECKERLOCAL:.cmo=.cmx) - ocamlopt $(OPTFLAGS) -a -o $@ $(MCHECKER:.cmo=.cmx) - -../bin/$(CHECKERNAME)$(EXE): check.cma - ocamlc $(BYTEFLAGS) -o $@ unix.cma gramlib.cma check.cma main.ml - -../bin/$(CHECKERNAME).opt$(EXE): check.cmxa - ocamlopt $(OPTFLAGS) -o $@ unix.cmxa gramlib.cmxa check.cmxa main.ml - -stats: - @echo STRUCTURE - @wc names.ml term.ml declarations.ml environ.ml type_errors.ml - @echo - @echo REDUCTION - @-wc esubst.ml closure.ml reduction.ml - @echo - @echo TYPAGE - @wc univ.ml inductive.ml indtypes.ml typeops.ml safe_typing.ml - @echo - @echo MODULES - @wc modops.ml subtyping.ml - @echo - @echo INTERFACE - @wc check*.ml main.ml - @echo - @echo TOTAL - @wc *.ml | tail -1 - -.SUFFIXES:.ml .mli .cmi .cmo .cmx - -.ml.cmo: - $(OCAMLC) -c $(BYTEFLAGS) $< - -.ml.cmx: - $(OCAMLOPT) -c $(OPTFLAGS) $< - -.mli.cmi: - $(OCAMLC) -c $(BYTEFLAGS) $< - - -depend:: - ocamldep *.ml* > .depend - -clean:: - rm -f *.cm* *.o *.a *~ $(BINARIES) - --include .depend diff --git a/checker/check.ml b/checker/check.ml index 8b299bf2a..11678fa6b 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -248,12 +248,12 @@ let locate_qualified_library qid = let error_unmapped_dir qid = let prefix = qid.dirpath in - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirlist prefix ++ fnl ()) let error_lib_not_found qid = - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str"Cannot find library " ++ pr_path qid ++ str" in loadpath") let try_locate_absolute_library dir = @@ -314,18 +314,18 @@ let intern_from_file (dir, f) = let () = close_in ch in let ch = open_in_bin f in if not (String.equal (Digest.channel ch pos) checksum) then - errorlabstrm "intern_from_file" (str "Checksum mismatch"); + user_err ~hdr:"intern_from_file" (str "Checksum mismatch"); let () = close_in ch in if dir <> sd.md_name then - errorlabstrm "intern_from_file" + user_err ~hdr:"intern_from_file" (name_clash_message dir sd.md_name f); if tasks <> None || discharging <> None then - errorlabstrm "intern_from_file" + user_err ~hdr:"intern_from_file" (str "The file "++str f++str " contains unfinished tasks"); if opaque_csts <> None then begin chk_pp (str " (was a vio file) "); Option.iter (fun (_,_,b) -> if not b then - errorlabstrm "intern_from_file" + user_err ~hdr:"intern_from_file" (str "The file "++str f++str " is still a .vio")) opaque_csts; Validate.validate !Flags.debug Values.v_univopaques opaque_csts; diff --git a/checker/checker.ml b/checker/checker.ml index 8dbb7e011..95a9ea78b 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -216,7 +216,9 @@ let report () = (str "." ++ spc () ++ str "Please report" ++ let guill s = str "\"" ++ str s ++ str "\"" -let where s = +let where = function +| None -> mt () +| Some s -> if !Flags.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) let rec explain_exn = function diff --git a/checker/modops.ml b/checker/modops.ml index b720fb621..aba9da2fe 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -33,7 +33,7 @@ let error_no_such_label_sub l l1 = Label.to_string l^" is missing in "^l1^".") let error_not_a_module_loc loc s = - user_err_loc (loc,"",str ("\""^Label.to_string s^"\" is not a module")) + user_err ~loc (str ("\""^Label.to_string s^"\" is not a module")) let error_not_a_module s = error_not_a_module_loc Loc.ghost s diff --git a/checker/reduction.ml b/checker/reduction.ml index ec16aa261..28c0126b4 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -176,9 +176,9 @@ let sort_cmp env univ pb s0 s1 = then begin if !Flags.debug then begin let op = match pb with CONV -> "=" | CUMUL -> "<=" in - Printf.eprintf "sort_cmp: %s\n%!" Pp.(string_of_ppcmds - (str"Error: " ++ Univ.pr_uni u1 ++ str op ++ Univ.pr_uni u2 ++ str ":" ++ cut() - ++ Univ.pr_universes univ)) + Format.eprintf "sort_cmp: @[%a@]\n%!" Pp.pp_with Pp.( + str"Error: " ++ Univ.pr_uni u1 ++ str op ++ Univ.pr_uni u2 ++ str ":" ++ cut() + ++ Univ.pr_universes univ) end; raise NotConvertible end diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index 11cd742ba..53d80c6d5 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -89,6 +89,6 @@ let import file clib univs digest = let unsafe_import file clib univs digest = let env = !genv in if !Flags.debug then check_imports Feedback.msg_warning clib.comp_name env clib.comp_deps - else check_imports (errorlabstrm"unsafe_import") clib.comp_name env clib.comp_deps; + else check_imports (user_err ~hdr:"unsafe_import") clib.comp_name env clib.comp_deps; check_engagement env clib.comp_enga; full_add_module clib.comp_name clib.comp_mod univs digest diff --git a/checker/term.mli b/checker/term.mli index 0af83e05d..6b026d056 100644 --- a/checker/term.mli +++ b/checker/term.mli @@ -4,8 +4,6 @@ open Cic val family_of_sort : sorts -> sorts_family val family_equal : sorts_family -> sorts_family -> bool -val strip_outer_cast : constr -> constr -val collapse_appl : constr -> constr val decompose_app : constr -> constr * constr list val applist : constr * constr list -> constr val iter_constr_with_binders : @@ -26,7 +26,7 @@ done ## We check that $cmd is ok before the real exec $cmd -`$cmd -version > /dev/null 2>&1` && exec $cmd $script "$@" +`$cmd -version > /dev/null 2>&1` && exec $cmd -w "-3" $script "$@" ## If we're still here, something is wrong with $cmd diff --git a/configure.ml b/configure.ml index 04b04979d..dfc6724a2 100644 --- a/configure.ml +++ b/configure.ml @@ -11,11 +11,11 @@ #load "str.cma" open Printf -let coq_version = "8.6" -let coq_macos_version = "8.6.00" (** "[...] should be a string comprised of +let coq_version = "trunk" +let coq_macos_version = "8.6.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) -let vo_magic = 8600 -let state_magic = 58600 +let vo_magic = 8691 +let state_magic = 58691 let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr"; "coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"] @@ -261,9 +261,13 @@ module Prefs = struct let withdoc = ref false let geoproof = ref false let byteonly = ref false - let debug = ref false + let debug = ref true let profile = ref false let annotate = ref false + (* Note, disabling this should be OK, but be careful with the + sharing invariants. + *) + let safe_string = ref true let nativecompiler = ref (not (os_type_win32 || os_type_cygwin)) let coqwebsite = ref "http://coq.inria.fr/" let force_caml_version = ref false @@ -336,7 +340,9 @@ let args_options = Arg.align [ "-byteonly", Arg.Set Prefs.byteonly, " Compiles only bytecode version of Coq"; "-debug", Arg.Set Prefs.debug, - " Add debugging information in the Coq executables"; + " Deprecated"; + "-nodebug", Arg.Clear Prefs.debug, + " Do not add debugging information in the Coq executables"; "-profile", Arg.Set Prefs.profile, " Add profiling information in the Coq executables"; "-annotate", Arg.Set Prefs.annotate, @@ -381,9 +387,12 @@ let coq_debug_flag = if !Prefs.debug then "-g" else "" let coq_profile_flag = if !Prefs.profile then "-p" else "" let coq_annotate_flag = if !Prefs.annotate - then if program_in_path "ocamlmerlin" then "-bin-annot" else "-dtypes" + then if program_in_path "ocamlmerlin" then "-bin-annot" else "-annot" else "" +let coq_safe_string = + if !Prefs.safe_string then "-safe-string" else "" + let cflags = "-Wall -Wno-unused -g -O2" (** * Architecture *) @@ -487,19 +496,14 @@ let caml_version_nums = "Is it installed properly?") let check_caml_version () = - if caml_version_nums >= [4;1;0] then - if caml_version_nums = [4;2;0] && not !Prefs.force_caml_version then - die ("Your version of OCaml is 4.02.0 which suffers from a bug inducing\n" ^ - "very slow compilation times. If you still want to use it, use \n" ^ - "option -force-caml-version.\n") - else - printf "You have OCaml %s. Good!\n" caml_version + if caml_version_nums >= [4;2;1] then + printf "You have OCaml %s. Good!\n" caml_version else let () = printf "Your version of OCaml is %s.\n" caml_version in if !Prefs.force_caml_version then printf "*Warning* Your version of OCaml is outdated.\n" else - die "You need OCaml 4.01 or later." + die "You need OCaml 4.02.1 or later." let _ = check_caml_version () @@ -568,13 +572,6 @@ let check_camlp5_version camlp5o = printf "You have Camlp5 %s. Good!\n" version; version | _ -> die "Error: unsupported Camlp5 (version < 6.06 or unrecognized).\n" -let check_caml_version_for_camlp4 () = - if caml_version_nums = [4;1;0] && !Prefs.debug && not !Prefs.force_caml_version then - die ("Your version of OCaml is detected to be 4.01.0 which fails to compile\n" ^ - "Coq in -debug mode with Camlp4. Remove -debug option or use a different\n" ^ - "version of OCaml or use Camlp5, or bypass this test by using option\n" ^ - "-force-caml-version.\n") - let config_camlpX () = try if not !Prefs.usecamlp5 then raise NoCamlp5; @@ -593,7 +590,6 @@ let config_camlpX () = let camlp4orf = which_camlpX "camlp4orf" in let version_line, _ = run ~err:StdOut camlp4orf ["-v"] in let camlp4_version = List.nth (string_split ' ' version_line) 2 in - check_caml_version_for_camlp4 (); "camlp4", camlp4orf, Filename.dirname camlp4orf, camlp4libdir, camlp4mod, camlp4_version with _ -> die "No Camlp4 installation found.\n" @@ -937,7 +933,7 @@ let config_runtime () = | _ -> let ld="CAML_LD_LIBRARY_PATH" in build_loadpath := sprintf "export %s:='%s/kernel/byterun':$(%s)" ld coqtop ld; - ["-dllib";"-lcoqrun";"-dllpath";libdir] + ["-dllib";"-lcoqrun";"-dllpath";libdir/"kernel/byterun"] let vmbyteflags = config_runtime () @@ -1107,6 +1103,7 @@ let write_makefile f = pr "LOCAL=%B\n\n" !Prefs.local; pr "# Bytecode link flags : should we use -custom or not ?\n"; pr "CUSTOM=%s\n" custom_flag; + pr "VMBYTEFLAGS=%s\n" (String.concat " " vmbyteflags); pr "%s\n\n" !build_loadpath; pr "# Paths for true installation\n"; List.iter (fun (v,msg,_,_) -> pr "# %s: path for %s\n" v msg) install_dirs; @@ -1128,7 +1125,7 @@ let write_makefile f = pr "CAMLHLIB=%S\n\n" camllib; pr "# Caml link command and Caml make top command\n"; pr "# Caml flags\n"; - pr "CAMLFLAGS=-rectypes %s\n" coq_annotate_flag; + pr "CAMLFLAGS=-rectypes %s %s\n" coq_annotate_flag coq_safe_string; pr "# User compilation flag\n"; pr "USERFLAGS=\n\n"; pr "# Flags for GCC\n"; diff --git a/dev/Makefile.oug b/dev/Makefile.oug deleted file mode 100644 index ee69ea80d..000000000 --- a/dev/Makefile.oug +++ /dev/null @@ -1,74 +0,0 @@ -####################################################################### -# v # The Coq Proof Assistant / The Coq Development Team # -# <O___,, # INRIA-Rocquencourt & LRI-CNRS-Orsay # -# \VV/ ############################################################# -# // # This file is distributed under the terms of the # -# # GNU Lesser General Public License Version 2.1 # -####################################################################### - - -#### Source Code Analysis via Oug #### -#### Cf http://home.gna.org/oug #### - - -# To be used from top dir : make -f dev/Makefile.oug ... - -include Makefile.build - -# Oug location: in the path by default, native version - -OUG:=oug.x - -# NB: coq should have been compiled with the same ocaml version as oug - -# NOTA: it seems we obtain more useless elements reported when _not_ -# providing the .mli files, and also when giving a precise start point. -# TO BE INVESTIGATED - -ml_of_cma = $(patsubst %.cmo,%.ml,$(filter %.cmo,$(shell cat $(1:.cma=.mllib.d)))) -local_ml_of_cma = $(filter $(dir $(1))%,$(call ml_of_cma,$(1))) -mli_of_ml = $(foreach ml,$(1),$(wildcard $(ml)i)) - -# Analysis of coqtop, without plugins - -COREML:=config/coq_config.ml $(call ml_of_cma, $(CORECMA)) -COREMLI:=$(call mli_of_ml,$(COREML)) - -core.oug: - $(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(COREML) - -core.useless: core.oug - $(OUG) --load-data $< --no-reduce --print-loc --roots "<Coqtop.start>" --useless-elements $@ - -core_intf.oug: - $(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(COREML) $(COREMLI) - -core_intf.useless: core_intf.oug - $(OUG) --load-data $< --no-reduce --print-loc --roots "<Coqtop.start>" --useless-elements $@ - -# Analysis of coqchk, considering only files in the checker/ subdir - -CHECKERML:=$(call local_ml_of_cma,checker/check.cma) -CHECKERMLI:=$(call mli_of_ml,$(CHECKERML)) - -## BUG: in oug, include dirs have reversed priority compared with ocaml, cannot use CHKLIBS -MYCHKINCL:=$(MLINCLUDES) -I checker - -checker.oug: - $(OUG) --dump-data $@ -rectypes $(MYCHKINCL) $(CHECKERML) #$(CHECKERMLI) - -checker.useless: checker.oug - $(OUG) --load-data $< --no-reduce --print-loc --roots "<Checker.start>" --useless-elements $@ - -# Analysis of extraction - -EXTRACTIONML:=$(call local_ml_of_cma,$(EXTRACTIONCMA)) -EXTRACTIONMLI:=$(call mli_of_ml,$(EXTRACTIONMLI)) - -extraction.oug: - $(OUG) --dump-data $@ -rectypes $(MLINCLUDES) $(EXTRACTIONML) #$(EXTRACTIONMLI) - -extraction.useless: extraction.oug - $(OUG) --load-data $< --no-reduce --print-loc --useless-elements $@ - -# More to come ...
\ No newline at end of file diff --git a/dev/base_db b/dev/base_db index b540aed6c..e18ac534a 100644 --- a/dev/base_db +++ b/dev/base_db @@ -1,6 +1,6 @@ -load_printer "gramlib.cma" -load_printer "top_printers.cmo" -install_printer Top_printers.prid -install_printer Top_printers.prsp -install_printer Top_printers.print_pure_constr +source core.dbg +load_printer top_printers.cmo +install_printer Top_printers.ppid +install_printer Top_printers.ppsp +install_printer Top_printers.ppconstr diff --git a/dev/base_include b/dev/base_include index b09b6df2d..242405ae2 100644 --- a/dev/base_include +++ b/dev/base_include @@ -17,7 +17,7 @@ #directory "grammar";; #directory "intf";; #directory "stm";; -#directory "ltac";; +#directory "vernac";; #directory "+camlp4";; (* lazy solution: add both of camlp4/5 so that *) #directory "+camlp5";; (* Gramext is found in top_printers.ml *) @@ -195,7 +195,7 @@ let qid = Libnames.qualid_of_string;; (* parsing of terms *) let parse_constr = Pcoq.parse_string Pcoq.Constr.constr;; -let parse_tac = Pcoq.parse_string Pcoq.Tactic.tactic;; +let parse_tac = Pcoq.parse_string Ltac_plugin.Pltac.tactic;; let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac;; (* build a term of type glob_constr without type-checking or resolution of diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 9fdd2504d..2711b7eca 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -27,11 +27,11 @@ git_checkout() # Allow an optional 4th argument for the commit local _COMMIT=${4:-FETCH_HEAD} - local _DEPTH=${5:-1} + local _DEPTH=$(if [ -z "${4}" ]; then echo "--depth 1"; fi) mkdir -p ${_DEST} ( cd ${_DEST} && \ - if [ ! -d .git ] ; then git clone --depth ${_DEPTH} ${_URL} . ; fi && \ + if [ ! -d .git ] ; then git clone ${_DEPTH} ${_URL} . ; fi && \ echo "Checking out ${_DEST}" && \ git fetch ${_URL} ${_BRANCH} && \ git checkout ${_COMMIT} && \ diff --git a/dev/ci/ci-iris-coq.sh b/dev/ci/ci-iris-coq.sh index dcb46ed2a..262dd6fa0 100755 --- a/dev/ci/ci-iris-coq.sh +++ b/dev/ci/ci-iris-coq.sh @@ -17,9 +17,8 @@ read -a IRIS_DEP < ${Iris_CI_DIR}/opam.pins # Setup stdpp stdpp_CI_GITURL=${IRIS_DEP[1]}.git stdpp_CI_COMMIT=${IRIS_DEP[2]} -stdpp_CI_DEPTH="1000" -git_checkout ${stdpp_CI_BRANCH} ${stdpp_CI_GITURL} ${stdpp_CI_DIR} ${stdpp_CI_COMMIT} ${stdpp_CI_DEPTH} +git_checkout ${stdpp_CI_BRANCH} ${stdpp_CI_GITURL} ${stdpp_CI_DIR} ${stdpp_CI_COMMIT} ( cd ${stdpp_CI_DIR} && make -j ${NJOBS} && make install ) diff --git a/dev/core.dbg b/dev/core.dbg new file mode 100644 index 000000000..f04e5c07b --- /dev/null +++ b/dev/core.dbg @@ -0,0 +1,19 @@ +source camlp4.dbg +load_printer threads.cma +load_printer str.cma +load_printer clib.cma +load_printer lib.cma +load_printer kernel.cma +load_printer library.cma +load_printer engine.cma +load_printer pretyping.cma +load_printer interp.cma +load_printer proofs.cma +load_printer parsing.cma +load_printer printing.cma +load_printer tactics.cma +load_printer vernac.cma +load_printer stm.cma +load_printer toplevel.cma +load_printer highparsing.cma +load_printer ltac_plugin.cmo @@ -1,4 +1,5 @@ -load_printer "printers.cma" +source core.dbg +load_printer top_printers.cmo install_printer Top_printers.ppfuture diff --git a/dev/doc/api.txt b/dev/doc/api.txt new file mode 100644 index 000000000..5827257b5 --- /dev/null +++ b/dev/doc/api.txt @@ -0,0 +1,10 @@ +Recommendations in using the API: + +The type of terms: constr (see kernel/constr.ml and kernel/term.ml) + +- On type constr, the canonical equality on CIC (up to + alpha-conversion and cast removal) is Constr.equal +- The type constr is abstract, use mkRel, mkSort, etc. to build + elements in constr; use "kind_of_term" to analyze the head of a + constr; use destRel, destSort, etc. when the head constructor is + known diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 3de938d77..03742fb8a 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -1,4 +1,134 @@ ========================================= += CHANGES BETWEEN COQ V8.6 AND COQ V8.7 = +========================================= + +* Ocaml * + +Coq is compiled with -safe-string enabled and requires plugins to do +the same. This means that code using `String` in an imperative way +will fail to compile now. They should switch to `Bytes.t` + +* ML API * + +We renamed the following functions: + + Context.Rel.Declaration.fold -> Context.Rel.Declaration.fold_constr + Context.Named.Declaration.fold -> Context.Named.Declaration.fold_constr + Printer.pr_var_list_decl -> Printer.pr_compacted_decl + Printer.pr_var_decl -> Printer.pr_named_decl + Nameops.lift_subscript -> Nameops.increment_subscript + +We removed the following functions: + + Termops.compact_named_context_reverse ... practical substitute is Termops.compact_named_context + Namegen.to_avoid ... equivalent substitute is Names.Id.List.mem + +We renamed the following modules: + + Context.ListNamed -> Context.Compacted + +The following type aliases where removed + + Context.section_context ... it was just an alias for "Context.Named.t" which is still available + +The module Constrarg was merged into Stdarg. + +** Ltac API ** + +Many Ltac specific API has been moved in its own ltac/ folder. Amongst other +important things: + +- Pcoq.Tactic -> Pltac +- Constrarg.wit_tactic -> Tacarg.wit_tactic +- Constrarg.wit_ltac -> Tacarg.wit_ltac +- API below ltac/ that accepted a *_tactic_expr now accept a *_generic_argument + instead +- Some printing functions were moved from Pptactic to Pputils +- A part of Tacexpr has been moved to Tactypes +- The TacFun tactic expression constructor now takes a `Name.t list` for the + variable list rather than an `Id.t option list`. + +The folder itself has been turned into a plugin. This does not change much, +but because it is a packed plugin, it may wreak havoc for third-party plugins +depending on any module defined in the ltac/ directory. Namely, even if +everything looks OK at compile time, a plugin can fail to load at link time +because it mistakenly looks for a module Foo instead of Ltac_plugin.Foo, with +an error of the form: + +Error: while loading myplugin.cmxs, no implementation available for Foo. + +In particular, most EXTEND macros will trigger this problem even if they +seemingly do not use any Ltac module, as their expansion do. + +The solution is simple, and consists in adding a statement "open Ltac_plugin" +in each file using a Ltac module, before such a module is actually called. An +alternative solution would be to fully qualify Ltac modules, e.g. turning any +call to Tacinterp into Ltac_plugin.Tacinterp. Note that this solution does not +work for EXTEND macros though. + +** Error handling ** + +- All error functions now take an optional parameter `?loc:Loc.t`. For + functions that used to carry a suffix `_loc`, such suffix has been + dropped. + +- `errorlabstrm` has been removed in favor of `user_err`. + +- The header parameter to `user_err` has been made optional. + +** Pretty printing ** + +Some functions have been removed, see pretty printing below for more +details. + +* Pretty Printing and XML protocol * + +The type std_cmdpps has been reworked and made the canonical "Coq rich +document type". This allows for a more uniform handling of printing +(specially in IDEs). The main consequences are: + + - Richpp has been confined to IDE use. Most of previous uses of the + `richpp` type should be replaced now by `Pp.std_cmdpps`. Main API + has been updated. + + - The XML protocol will send a new message type of `pp`, which should + be rendered client-wise. + + - `Set Printing Width` is deprecated, now width is controlled + client-side. + + - `Pp_control` has removed. The new module `Topfmt` implements + console control for the toplevel. + + - The impure tag system in Pp has been removed. This also does away + with the printer signatures and functors. Now printers tag + unconditionally. + + - The following functions have been removed from `Pp`: + + val stras : int * string -> std_ppcmds + val tbrk : int * int -> std_ppcmds + val tab : unit -> std_ppcmds + val pifb : unit -> std_ppcmds + val comment : int -> std_ppcmds + val comments : ((int * int) * string) list ref + val eval_ppcmds : std_ppcmds -> std_ppcmds + val is_empty : std_ppcmds -> bool + val t : std_ppcmds -> std_ppcmds + val hb : int -> std_ppcmds + val vb : int -> std_ppcmds + val hvb : int -> std_ppcmds + val hovb : int -> std_ppcmds + val tb : unit -> std_ppcmds + val close : unit -> std_ppcmds + val tclose : unit -> std_ppcmds + val open_tag : Tag.t -> std_ppcmds + val close_tag : unit -> std_ppcmds + val msg_with : ... + + module Tag + +========================================= = CHANGES BETWEEN COQ V8.5 AND COQ V8.6 = ========================================= diff --git a/dev/doc/debugging.txt b/dev/doc/debugging.txt index f0df2fc37..79cde4884 100644 --- a/dev/doc/debugging.txt +++ b/dev/doc/debugging.txt @@ -51,8 +51,8 @@ Debugging from Caml debugger failure/error/anomaly has been raised - Alternatively, for an error or an anomaly, add breakpoints in the middle of each of error* functions or anomaly* functions in lib/util.ml - - If "source db" fails, recompile printers.cma with - "make dev/printers.cma" and try again + - If "source db" fails, do a "make printers" and try again (it should build + top_printers.cmo and the core cma files). Global gprof-based profiling ============================ diff --git a/dev/doc/style.txt b/dev/doc/style.txt index 27695a09b..2ee3dadd7 100644 --- a/dev/doc/style.txt +++ b/dev/doc/style.txt @@ -1,75 +1,142 @@ - -<< L'uniformité du style est plus importante que le style lui-même. >> -(Kernigan & Pike, The Practice of Programming) - -Mode Emacs -========== - Tuareg, que l'on trouve ici : http://www.prism.uvsq.fr/~acohen/tuareg/ - - avec le réglage suivant : (setq tuareg-in-indent 2) - -Types récursifs et filtrages -============================ - Une barre de séparation y compris sur le premier constructeur - -type t = - | A - | B of machin - -match expr with - | A -> ... - | B x -> ... - -Remarque : à partir de la 8.2 environ, la tendance est à utiliser le -format suivant qui permet de limiter l'escalade d'indentation tout en -produisant un aspect visuel intéressant de bloc : - -type t = -| A -| B of machin - -match expr with -| A -> ... -| B x -> ... - -let f expr = match expr with -| A -> ... -| B x -> ... - -let f expr = function -| A -> ... -| B x -> ... - -Le deuxième cas est obtenu sous tuareg avec les réglages - - (setq tuareg-with-indent 0) - (setq tuareg-function-indent 0) - (setq tuareg-let-always-indent nil) /// notons que cette dernière est bien - /// pour les let mais pas pour les let-in - -Conditionnelles -=============== - if condition then - premier-cas - else - deuxieme-cas - - Si effets de bord dans les branches, utilisez begin ... end et non des - parenthèses i.e. - - if condition then begin - instr1; - instr2 - end else begin - instr3; - instr4 - end - - Si la première branche lève une exception, évitez le else i.e. - - if condition then if condition then error "machin"; - error "machin" -----> suite +<< Style uniformity is more important than style itself >> + (Kernigan & Pike, The Practice of Programming) + +OCaml Style: +- Spacing and indentation + - indent your code (using tuareg default) + - no strong constraints in formatting "let in"; possible styles are: + "let x = ... in" + "let x = + ... in" + "let + x = ... + in" + - but: no extra indentation before a "in" coming on next line, + otherwise, it first shifts further and further on the right, + reducing the amount of space available; second, it is not robust to + insertion of a new "let" + - it is established usage to have space around "|" as in + "match c with + | [] | [a] -> ... + | a::b::l -> ..." + - in a one-line "match", it is preferred to have no "|" in front of + the first case (this saves spaces for the match to hold in the line) + - from about 8.2, the tendency is to use the following format which + limit excessive indentation while providing an interesting "block" aspect + type t = + | A + | B of machin + + let f expr = match expr with + | A -> ... + | B x -> ... + + let f expr = function + | A -> ... + | B x -> ... + - add spaces around = and == (make the code "breaths") + - the common usage is to write "let x,y = ... in ..." rather than + "let (x,y) = ... in ..." + - parenthesizing with either "(" and ")" or with "begin" and "end" is + common practice + - preferred layout for conditionals: + if condition then + premier-cas else - suite - - + deuxieme-cas + - in case of effects in branches, use "begin ... end" rather than + parentheses + if condition then begin + instr1; + instr2 + end else begin + instr3; + instr4 + end + - if the first branch raises an exception, avoid the "else", i.e.: + if condition then if condition then error "foo"; + error "foo" -----> bar + else + bar + - it is the usage not to use ;; to end OCaml sentences (however, + inserting ";;" can be useful for debugging syntax errors crossing + the boundary of functions) + - relevant options in tuareg: + (setq tuareg-in-indent 2) + (setq tuareg-with-indent 0) + (setq tuareg-function-indent 0) + (setq tuareg-let-always-indent nil) + +- Coding methodology + - no "try ... with _ -> ..." which catches even Sys.Break (Ctrl-C), + Out_of_memory, Stack_overflow, etc. + at least, use "try with e when Errors.noncritical e -> ..." + (to be detailed, Pierre L. ?) + - do not abuse of fancy combinators: sometimes what a "let rec" loop + does is more readable and simpler to grasp than what a "fold" does + - do not break abstractions: if an internal property is hidden + behind an interface, do no rely on it in code which uses this + interface (e.g. do not use List.map thinking it is left-to-right, + use map_left) + - in particular, do not use "=" on abstract types: there is no + reason a priori that it is the intended equality on this type; use the + "equal" function normally provided with the abstract type + - avoid polymorphically typed "=" whose implementation is not + optimized in OCaml and which has moreover no reason to be the + intended implementation of the equality when it comes to be + instantiated on a particular type (e.g. use List.mem_f, + List.assoc_f, rather than List.mem, List.assoc, etc, unless it is + absolutely clear that "=" will implement the intended equality, and + with the right complexity) + - any new general-purpose enough combinator on list should be put in + cList.ml, on type option in cOpt.ml, etc. + - unless of a good reason not to so, follow the style of the + surrounding code in the same file as much as possible, + the general guidelines are otherwise "let spacing breaths" (we + have large screen nowadays), "make your code easy to read and + to understand" + - document what is tricky, but do not overdocument, sometimes the + choice of names and the structuration of the code is a better + documentation than a long discourse; use of unicode in comments is + welcome if it can make comments more readable (then + "toggle-enable-multibyte-characters" can help when using the + debugger in emacs) + - all of initial "open File", or of small-scope File.(...), or + per-ident File.foo are common practices + +- Choice of variable names + - be consistent when naming from one function to another + - be consistent with the naming adopted in the functions from the + same file, or with the naming used elsewhere by similar functions + - use variable names which express meaning + - keep "cst" for constants and avoid it for constructors which is + otherwise a source of confusion + - for constructors, use "cstr" in type constructor (resp. "cstru" in + constructor puniverse); avoid "constr" for "constructor" which + could be think as the name of an arbitrary Constr.t + - for inductive types, use "ind" in the type inductive (resp "indu" + in inductive puniverse) + - for env, use "env" + - for evar_map, use "sigma", with tolerance into "evm" and "evd" + - for named_context or rel_context, use "ctxt" or "ctx" (or "sign") + - for formal/actual indices of inductive types: "realdecls", "realargs" + - for formal/actual parameters of inductive types: "paramdecls", "paramargs" + - for terms, use e.g. c, b, a, ... + - if a term is known to be a function: f, ... + - if a term is known to be a type: t, u, typ, ... + - for a declaration, use d or "decl" + - for errors, exceptions, use e + +- Common OCaml pitfalls + - in "match ... with Case1 -> try ... with ... -> ... | Case2 -> ...", or in + "match ... with Case1 -> match ... with SubCase -> ... | Case2 -> ...", or in + parentheses are needed around the "try" and the inner "match" + - even if stream are lazy, the Pp.(++) combinator is strict and + forces the evaluation of its arguments (use a "lazy" or a "fun () ->") + to make it lazy explicitly + - in "if ... then ... else ... ++ ...", the default parenthesizing + is somehow counter-intuitive; use "(if ... then ... else ...) ++ ..." + - in "let myspecialfun = mygenericfun args", be sure that it does no + do side-effect; prefer otherwise "let mygenericfun arg = + mygenericfun args arg" to ensure that the function is evaluated at + runtime diff --git a/dev/include b/dev/include index d82fb74f2..0f43f0072 100644 --- a/dev/include +++ b/dev/include @@ -47,7 +47,6 @@ #install_printer (* univ full subst *) ppuniverse_level_subst;; #install_printer (* univ opt subst *) ppuniverse_opt_subst;; #install_printer (* evar univ ctx *) ppevar_universe_context;; -#install_printer (* constraints_map *) ppconstraints_map;; #install_printer (* inductive *) ppind;; #install_printer (* 'a scheme_kind *) ppscheme;; #install_printer (* type_judgement *) pptype;; @@ -62,7 +61,7 @@ (*#install_printer (* hints_path *) pphintspath;;*) #install_printer (* goal *) ppgoal;; (*#install_printer (* sigma goal *) ppsigmagoal;;*) -(*#install_printer (* proof *) pproof;;*) +#install_printer (* proof *) pproof;; #install_printer (* Goal.goal *) ppgoalgoal;; #install_printer (* proofview *) ppproofview;; #install_printer (* metaset.t *) ppmetas;; diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index f9310e076..3850c05fd 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -12,13 +12,15 @@ [ -z "$COQTOP" -a -d "$PWD/kernel" ] && COQTOP=$PWD [ -z "$COQTOP" -a -d "$PWD/../kernel" ] && COQTOP=`dirname $PWD` +export CAML_LD_LIBRARY_PATH=$COQTOP/kernel/byterun:$CAML_LD_LIBRARY_PATH + exec $OCAMLDEBUG \ - -I $CAMLP4LIB \ + -I $CAMLP4LIB -I +threads \ -I $COQTOP \ -I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar \ - -I $COQTOP/lib -I $COQTOP/intf -I $COQTOP/kernel \ + -I $COQTOP/lib -I $COQTOP/intf -I $COQTOP/kernel -I $COQTOP/kernel/byterun \ -I $COQTOP/library -I $COQTOP/engine \ - -I $COQTOP/pretyping -I $COQTOP/parsing \ + -I $COQTOP/pretyping -I $COQTOP/parsing -I $COQTOP/vernac \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \ -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \ -I $COQTOP/plugins/cc -I $COQTOP/plugins/dp \ @@ -30,6 +32,6 @@ exec $OCAMLDEBUG \ -I $COQTOP/plugins/ring -I $COQTOP/plugins/romega \ -I $COQTOP/plugins/rtauto -I $COQTOP/plugins/setoid_ring \ -I $COQTOP/plugins/subtac -I $COQTOP/plugins/syntax \ - -I $COQTOP/plugins/xml \ + -I $COQTOP/plugins/xml -I $COQTOP/plugins/ltac \ -I $COQTOP/ide \ "$@" diff --git a/dev/printers.mllib b/dev/printers.mllib deleted file mode 100644 index 316549548..000000000 --- a/dev/printers.mllib +++ /dev/null @@ -1,219 +0,0 @@ -Coq_config - -Terminal -Hook -Canary -Hashset -Hashcons -CSet -CMap -Int -Dyn -HMap -Option -Store -Exninfo -Backtrace -IStream -Pp_control -Loc -CList -CString -Tok -Compat -Flags -Control -Loc -Serialize -Stateid -CObj -CArray -CStack -Util -Pp -Ppstyle -Richpp -Feedback -Segmenttree -Unicodetable -Unicode -CErrors -CWarnings -Bigint -CUnix -Minisys -System -Envars -Aux_file -Profile -Explore -Predicate -Rtree -Heap -Genarg -Stateid -CEphemeron -Future -RemoteCounter -Monad - -Names -Univ -UGraph -Esubst -Uint31 -Sorts -Evar -Constr -Context -Vars -Term -Mod_subst -Cbytecodes -Copcodes -Cemitcodes -Nativevalues -Primitives -Nativeinstr -Future -Opaqueproof -Declareops -Retroknowledge -Conv_oracle -Pre_env -Nativelambda -Nativecode -Nativelib -Cbytegen -Environ -CClosure -Reduction -Nativeconv -Type_errors -Modops -Inductive -Typeops -Fast_typeops -Indtypes -Cooking -Term_typing -Subtyping -Mod_typing -Nativelibrary -Safe_typing -Unionfind - -Summary -Nameops -Libnames -Globnames -Global -Nametab -Libobject -Lib -Loadpath -Goptions -Decls -Heads -Keys -Locusops -Miscops -Universes -Termops -Namegen -UState -Evd -Sigma -Glob_ops -Redops -Pretype_errors -Evarutil -Reductionops -Inductiveops -Arguments_renaming -Nativenorm -Retyping -Cbv - -Evardefine -Evarsolve -Recordops -Evarconv -Typing -Patternops -Constr_matching -Find_subterm -Tacred -Classops -Typeclasses_errors -Logic_monad -Proofview_monad -Proofview -Ftactic -Geninterp -Typeclasses -Detyping -Indrec -Program -Coercion -Cases -Pretyping -Unification -Declaremods -Library -States - -Genprint -CLexer -Ppextend -Pputils -Ppannotation -Stdarg -Constrarg -Constrexpr_ops -Genintern -Notation_ops -Notation -Dumpglob -Syntax_def -Smartlocate -Topconstr -Reserve -Impargs -Implicit_quantifiers -Constrintern -Modintern -Constrextern -Goal -Miscprint -Logic -Refiner -Clenv -Evar_refiner -Refine -Proof -Proof_global -Pfedit -Decl_mode -Ppconstr -Pcoq -Printer -Pptactic -Ppdecl_proof -Egramml -Egramcoq -Tacsubst -Trie -Dn -Btermdn -Hints -Himsg -ExplainErr -Locality -Assumptions -Vernacinterp -Dischargedhypsmap -Discharge -Declare -Ind_tables -Top_printers diff --git a/dev/top_printers.ml b/dev/top_printers.ml index a3d5cf5c1..cd464801b 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -29,7 +29,7 @@ let _ = set_bool_option_value ["Printing";"Matching"] false let _ = Detyping.set_detype_anonymous (fun _ _ -> raise Not_found) (* std_ppcmds *) -let pp x = Pp.pp_with !Pp_control.std_ft x +let pp x = Pp.pp_with !Topfmt.std_ft x (** Future printer *) @@ -200,7 +200,8 @@ let pppftreestate p = pp(print_pftreestate p) (* let ppsigmagoal g = pp(pr_goal (sig_it g)) *) (* let prgls gls = pp(pr_gls gls) *) (* let prglls glls = pp(pr_glls glls) *) -(* let pproof p = pp(print_proof Evd.empty empty_named_context p) *) + +let pproof p = pp(Proof.pr_proof p) let ppuni u = pp(pr_uni u) let ppuni_level u = pp (Level.pr u) @@ -233,7 +234,7 @@ let ppenvwithcst e = pp str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]" ++ spc() ++ str "{" ++ Cmap_env.fold (fun a _ s -> pr_con a ++ spc () ++ s) (Obj.magic e).Pre_env.env_globals.Pre_env.env_constants (mt ()) ++ str "}") -let pptac = (fun x -> pp(Pptactic.pr_glob_tactic (Global.env()) x)) +let pptac = (fun x -> pp(Ltac_plugin.Pptactic.pr_glob_tactic (Global.env()) x)) let ppobj obj = Format.print_string (Libobject.object_tag obj) @@ -502,7 +503,7 @@ END open Pcoq open Genarg -open Constrarg +open Stdarg open Egramml let _ = diff --git a/doc/refman/Polynom.tex b/doc/refman/Polynom.tex index 0664bf909..77d592834 100644 --- a/doc/refman/Polynom.tex +++ b/doc/refman/Polynom.tex @@ -342,16 +342,16 @@ describes their syntax and effects: By default the tactic does not recognize power expressions as ring expressions. \item[sign {\term}] allows {\tt ring\_simplify} to use a minus operation - when outputing its normal form, i.e writing $x - y$ instead of $x + (-y)$. + when outputting its normal form, i.e writing $x - y$ instead of $x + (-y)$. The term {\term} is a proof that a given sign function indicates expressions that are signed ({\term} has to be a - proof of {\tt Ring\_theory.get\_sign}). See {\tt plugins/setoid\_ring/IntialRing.v} for examples of sign function. -\item[div {\term}] allows {\tt ring} and {\tt ring\_simplify} to use moniomals + proof of {\tt Ring\_theory.get\_sign}). See {\tt plugins/setoid\_ring/InitialRing.v} for examples of sign function. +\item[div {\term}] allows {\tt ring} and {\tt ring\_simplify} to use monomials with coefficient other than 1 in the rewriting. The term {\term} is a proof that a given division function satisfies the specification of an euclidean division function ({\term} has to be a proof of {\tt Ring\_theory.div\_theory}). For example, this function is called when trying to rewrite $7x$ by $2x = z$ to tell that $7 = 3 * 2 + 1$. - See {\tt plugins/setoid\_ring/IntialRing.v} for examples of div function. + See {\tt plugins/setoid\_ring/InitialRing.v} for examples of div function. \end{description} diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index bef0a1686..45230fb6e 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -123,12 +123,6 @@ The following command-line options are recognized by the commands {\tt valid for {\tt coqc} as the toplevel module name is inferred from the name of the output file. -\item[{\tt -notop}]\ % - - Use the empty logical path for the toplevel module name instead of {\tt - Top}. Not valid for {\tt coqc} as the toplevel module name is - inferred from the name of the output file. - \item[{\tt -exclude-dir} {\em directory}]\ % Exclude any subdirectory named {\em directory} while diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index b475a5233..1d423f8b1 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -991,7 +991,7 @@ but library file names based on other roots can be obtained by using {\Coq} commands ({\tt coqc}, {\tt coqtop}, {\tt coqdep}, \dots) options {\tt -Q} or {\tt -R} (see Section~\ref{coqoptions}). Also, when an interactive {\Coq} session starts, a library of root {\tt Top} is -started, unless option {\tt -top} or {\tt -notop} is set (see +started, unless option {\tt -top} is set (see Section~\ref{coqoptions}). \subsection{Qualified names diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index c37367de5..16c822b6a 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -477,15 +477,15 @@ names. \item{\tt Show Intro.}\comindex{Show Intro}\\ If the current goal begins by at least one product, this command prints the name of the first product, as it would be generated by -an anonymous {\tt Intro}. The aim of this command is to ease the +an anonymous {\tt intro}. The aim of this command is to ease the writing of more robust scripts. For example, with an appropriate {\ProofGeneral} macro, it is possible to transform any anonymous {\tt - Intro} into a qualified one such as {\tt Intro y13}. + intro} into a qualified one such as {\tt intro y13}. In the case of a non-product goal, it prints nothing. \item{\tt Show Intros.}\comindex{Show Intros}\\ This command is similar to the previous one, it simulates the naming -process of an {\tt Intros}. +process of an {\tt intros}. \item{\tt Show Existentials.\label{ShowExistentials}}\comindex{Show Existentials} \\ It displays diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index 21c39de96..ecaf82806 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -59,6 +59,12 @@ and pretty-printer of {\Coq} already know how to deal with the syntactic expression (see \ref{ReservedNotation}), explicit precedences and associativity rules have to be given. +\Rem The right-hand side of a notation is interpreted at the time the +notation is given. In particular, implicit arguments (see +Section~\ref{Implicit Arguments}), coercions (see +Section~\ref{Coercions}), etc. are resolved at the time of the +declaration of the notation. + \subsection[Precedences and associativity]{Precedences and associativity\index{Precedences} \index{Associativity}} @@ -114,7 +120,7 @@ Notation "A \/ B" := (or A B) (at level 85, right associativity). By default, a notation is considered non associative, but the precedence level is mandatory (except for special cases whose level is -canonical). The level is either a number or the mention {\tt next +canonical). The level is either a number or the phrase {\tt next level} whose meaning is obvious. The list of levels already assigned is on Figure~\ref{init-notations}. @@ -297,7 +303,7 @@ the possible following elements delimited by single quotes: of each newline \end{itemize} -Thus, for the previous example, we get +%Thus, for the previous example, we get %\footnote{The ``@'' is here to shunt %the notation "'IF' A 'then' B 'else' C" which is defined in {\Coq} %initial state}: @@ -908,6 +914,28 @@ interpretation. See the next section. \SeeAlso The command to show the scopes bound to the arguments of a function is described in Section~\ref{About}. +\Rem In notations, the subterms matching the identifiers of the +notations are interpreted in the scope in which the identifiers +occurred at the time of the declaration of the notation. Here is an +example: + +\begin{coq_example} +Parameter g : bool -> bool. +Notation "@@" := true (only parsing) : bool_scope. +Notation "@@" := false (only parsing): mybool_scope. + +(* Defining a notation while the argument of g is bound to bool_scope *) +Bind Scope bool_scope with bool. +Notation "# x #" := (g x) (at level 40). +Check # @@ #. +(* Rebinding the argument of g to mybool_scope has no effect on the notation *) +Arguments g _%mybool_scope. +Check # @@ #. +(* But we can force the scope *) +Delimit Scope mybool_scope with mybool. +Check # @@%mybool #. +\end{coq_example} + \subsection[The {\tt type\_scope} interpretation scope]{The {\tt type\_scope} interpretation scope\index{type\_scope@\texttt{type\_scope}}} The scope {\tt type\_scope} has a special status. It is a primitive diff --git a/doc/refman/RefMan-tus.tex b/doc/refman/RefMan-tus.tex index 3e2988676..797b0aded 100644 --- a/doc/refman/RefMan-tus.tex +++ b/doc/refman/RefMan-tus.tex @@ -1012,7 +1012,7 @@ the different kinds of errors used in \Coq{} : \fun{val Std.error : string -> 'a} {For simple error messages} -\fun{val Std.errorlabstrm : string -> std\_ppcmds -> 'a} +\fun{val Std.user_err : ?loc:Loc.t -> string -> std\_ppcmds -> 'a} {See Section~\ref{PrettyPrinter} : this can be used if the user want to display a term or build a complex error message} diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 9216c81fc..aeb0de48a 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -46,6 +46,7 @@ through the <tt>Require Import</tt> command.</p> theories/Logic/ClassicalDescription.v theories/Logic/ClassicalEpsilon.v theories/Logic/ClassicalUniqueChoice.v + theories/Logic/SetoidChoice.v theories/Logic/Berardi.v theories/Logic/Diaconescu.v theories/Logic/Hurkens.v @@ -55,7 +56,10 @@ through the <tt>Require Import</tt> command.</p> theories/Logic/Description.v theories/Logic/Epsilon.v theories/Logic/IndefiniteDescription.v + theories/Logic/PropExtensionality.v + theories/Logic/PropExtensionalityFacts.v theories/Logic/FunctionalExtensionality.v + theories/Logic/ExtensionalFunctionRepresentative.v theories/Logic/ExtensionalityFacts.v theories/Logic/WeakFan.v theories/Logic/WKL.v diff --git a/engine/engine.mllib b/engine/engine.mllib index 9ce5af819..53cbbd73e 100644 --- a/engine/engine.mllib +++ b/engine/engine.mllib @@ -1,9 +1,10 @@ Logic_monad -Termops Namegen +Universes UState Evd Sigma +Termops Proofview_monad Evarutil Proofview diff --git a/engine/evarutil.ml b/engine/evarutil.ml index df170c8dd..13444cb37 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -18,6 +18,9 @@ open Environ open Evd open Sigma.Notations +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + let safe_evar_info sigma evk = try Some (Evd.find sigma evk) with Not_found -> None @@ -167,13 +170,11 @@ let is_ground_term evd t = not (has_undefined_evars evd t) let is_ground_env evd env = - let open Context.Rel.Declaration in let is_ground_rel_decl = function - | LocalDef (_,b,_) -> is_ground_term evd b + | RelDecl.LocalDef (_,b,_) -> is_ground_term evd b | _ -> true in - let open Context.Named.Declaration in let is_ground_named_decl = function - | LocalDef (_,b,_) -> is_ground_term evd b + | NamedDecl.LocalDef (_,b,_) -> is_ground_term evd b | _ -> true in List.for_all is_ground_rel_decl (rel_context env) && List.for_all is_ground_named_decl (named_context env) @@ -255,11 +256,10 @@ let non_instantiated sigma = (************************) let make_pure_subst evi args = - let open Context.Named.Declaration in snd (List.fold_right (fun decl (args,l) -> match args with - | a::rest -> (rest, (get_id decl, a)::l) + | a::rest -> (rest, (NamedDecl.get_id decl, a)::l) | _ -> anomaly (Pp.str "Instance does not match its signature")) (evar_filtered_context evi) (Array.rev_to_list args,[])) @@ -331,21 +331,18 @@ let push_var id (n, s) = (succ n, s) let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) = - let open Context.Named.Declaration in let replace_var_named_declaration id0 id decl = - let id' = get_id decl in + let id' = NamedDecl.get_id decl in let id' = if Id.equal id0 id' then id else id' in let vsubst = [id0 , mkVar id] in - decl |> set_id id' |> map_constr (replace_vars vsubst) + decl |> NamedDecl.set_id id' |> NamedDecl.map_constr (replace_vars vsubst) in let extract_if_neq id = function | Anonymous -> None | Name id' when id_ord id id' = 0 -> None | Name id' -> Some id' in - let open Context.Rel.Declaration in - let (na, c, t) = to_tuple decl in - let open Context.Named.Declaration in + let na = RelDecl.get_name decl in let id = (* ppedrot: we want to infer nicer names for the refine tactic, but keeping at the same time backward compatibility in other code @@ -356,7 +353,7 @@ let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) = else (** id_of_name_using_hdchar only depends on the rel context which is empty here *) - next_ident_away (id_of_name_using_hdchar empty_env t na) avoid + next_ident_away (id_of_name_using_hdchar empty_env (RelDecl.get_type decl) na) avoid in match extract_if_neq id na with | Some id0 when not (is_section_variable id0) -> @@ -366,10 +363,7 @@ let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) = context. Unless [id] is a section variable. *) let subst = (fst subst, Int.Map.map (replace_vars [id0,mkVar id]) (snd subst)) in let vsubst = (id0,mkVar id)::vsubst in - let d = match c with - | None -> LocalAssum (id0, subst2 subst vsubst t) - | Some c -> LocalDef (id0, subst2 subst vsubst c, subst2 subst vsubst t) - in + let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> NamedDecl.map_constr (subst2 subst vsubst) in let nc = List.map (replace_var_named_declaration id0 id) nc in (push_var id0 subst, vsubst, Id.Set.add id avoid, d :: nc) | _ -> @@ -377,10 +371,7 @@ let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) = incorrect. We revert to a less robust behaviour where the new binder has name [id]. Which amounts to the same behaviour than when [id=id0]. *) - let d = match c with - | None -> LocalAssum (id, subst2 subst vsubst t) - | Some c -> LocalDef (id, subst2 subst vsubst c, subst2 subst vsubst t) - in + let d = decl |> NamedDecl.of_rel_decl (fun _ -> id) |> NamedDecl.map_constr (subst2 subst vsubst) in (push_var id subst, vsubst, Id.Set.add id avoid, d :: nc) let push_rel_context_to_named_context env typ = @@ -560,8 +551,7 @@ let rec check_and_clear_in_constr env evdref err ids global c = let () = Id.Map.iter check ri in (* No dependency at all, we can keep this ev's context hyp *) (ri, true::filter) - with Depends id -> let open Context.Named.Declaration in - (Id.Map.add (get_id h) id ri, false::filter)) + with Depends id -> (Id.Map.add (NamedDecl.get_id h) id ri, false::filter)) ctxt (Array.to_list l) (Id.Map.empty,[]) in (* Check if some rid to clear in the context of ev has dependencies in the type of ev and adjust the source of the dependency *) @@ -600,10 +590,9 @@ let clear_hyps_in_evi_main env evdref hyps terms ids = let terms = List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids global) terms in let nhyps = - let open Context.Named.Declaration in let check_context decl = - let err = OccurHypInSimpleClause (Some (get_id decl)) in - map_constr (check_and_clear_in_constr env evdref err ids global) decl + let err = OccurHypInSimpleClause (Some (NamedDecl.get_id decl)) in + NamedDecl.map_constr (check_and_clear_in_constr env evdref err ids global) decl in let check_value vk = match force_lazy_val vk with | None -> vk @@ -642,8 +631,8 @@ let process_dependent_evar q acc evm is_dependent e = hypotheses), they are all dependent. *) queue_term q true evi.evar_concl; List.iter begin fun decl -> - let open Context.Named.Declaration in - queue_term q true (get_type decl); + let open NamedDecl in + queue_term q true (NamedDecl.get_type decl); match decl with | LocalAssum _ -> () | LocalDef (_,b,_) -> queue_term q true b @@ -719,9 +708,8 @@ let undefined_evars_of_term evd t = evrec Evar.Set.empty t let undefined_evars_of_named_context evd nc = - let open Context.Named.Declaration in Context.Named.fold_outside - (fold (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c))) + (NamedDecl.fold_constr (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c))) nc ~init:Evar.Set.empty diff --git a/engine/evd.ml b/engine/evd.ml index c2f848291..62d396395 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -13,11 +13,13 @@ open Names open Nameops open Term open Vars -open Termops open Environ open Globnames open Context.Named.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (** Generic filters *) module Filter : sig @@ -226,7 +228,7 @@ let evar_instance_array test_id info args = if i < len then let c = Array.unsafe_get args i in if test_id d c then instrec filter ctxt (succ i) - else (get_id d, c) :: instrec filter ctxt (succ i) + else (NamedDecl.get_id d, c) :: instrec filter ctxt (succ i) else instance_mismatch () | _ -> instance_mismatch () in @@ -235,7 +237,7 @@ let evar_instance_array test_id info args = let map i d = if (i < len) then let c = Array.unsafe_get args i in - if test_id d c then None else Some (get_id d, c) + if test_id d c then None else Some (NamedDecl.get_id d, c) else instance_mismatch () in List.map_filter_i map (evar_context info) @@ -243,7 +245,7 @@ let evar_instance_array test_id info args = instrec filter (evar_context info) 0 let make_evar_instance_array info args = - evar_instance_array (isVarId % get_id) info args + evar_instance_array (NamedDecl.get_id %> isVarId) info args let instantiate_evar_array info c args = let inst = make_evar_instance_array info args in @@ -284,7 +286,7 @@ let metavars_of c = let rec collrec acc c = match kind_of_term c with | Meta mv -> Int.Set.add mv acc - | _ -> fold_constr collrec acc c + | _ -> Term.fold_constr collrec acc c in collrec Int.Set.empty c @@ -383,8 +385,7 @@ let add_name_newly_undefined naming evk evi (evtoid, idtoev as names) = | Misctypes.IntroAnonymous -> None | Misctypes.IntroIdentifier id -> if Idmap.mem id idtoev then - user_err_loc - (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id); + user_err (str "Already an existential evar of name " ++ pr_id id); Some id | Misctypes.IntroFresh id -> let id = Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in @@ -685,7 +686,7 @@ let restrict evk filter ?candidates evd = | _ -> Evar.Set.add evk evd.last_mods in let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in let ctxt = Filter.filter_list filter (evar_context evar_info) in - let id_inst = Array.map_of_list (mkVar % get_id) ctxt in + let id_inst = Array.map_of_list (NamedDecl.get_id %> mkVar) ctxt in let body = mkEvar(evk',id_inst) in let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; @@ -735,23 +736,22 @@ let evar_list c = let rec evrec acc c = match kind_of_term c with | Evar (evk, _ as ev) -> ev :: acc - | _ -> fold_constr evrec acc c in + | _ -> Term.fold_constr evrec acc c in evrec [] c let evars_of_term c = let rec evrec acc c = match kind_of_term c with | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) - | _ -> fold_constr evrec acc c + | _ -> Term.fold_constr evrec acc c in evrec Evar.Set.empty c let evars_of_named_context nc = - List.fold_right (fun decl s -> - Option.fold_left (fun s t -> - Evar.Set.union s (evars_of_term t)) - (Evar.Set.union s (evars_of_term (get_type decl))) (get_value decl)) - nc Evar.Set.empty + Context.Named.fold_outside + (NamedDecl.fold_constr (fun constr s -> Evar.Set.union s (evars_of_term constr))) + nc + ~init:Evar.Set.empty let evars_of_filtered_evar_info evi = Evar.Set.union (evars_of_term evi.evar_concl) @@ -1273,7 +1273,9 @@ let protect f x = try f x with e -> str "EXCEPTION: " ++ str (Printexc.to_string e) -let print_constr a = protect print_constr a +let (f_print_constr, print_constr_hook) = Hook.make () + +let print_constr a = protect (fun c -> Hook.get f_print_constr (Global.env ()) c) a let pr_meta_map mmap = let pr_name = function @@ -1294,13 +1296,13 @@ let pr_meta_map mmap = prlist pr_meta_binding (metamap_to_list mmap) let pr_decl (decl,ok) = - let id = get_id decl in - match get_value decl with - | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}") - | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ - print_constr c ++ str (if ok then ")" else "}") + match decl with + | LocalAssum (id,_) -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}") + | LocalDef (id,c,_) -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ + print_constr c ++ str (if ok then ")" else "}") let pr_evar_source = function + | Evar_kinds.NamedHole id -> pr_id id | Evar_kinds.QuestionMark _ -> str "underscore" | Evar_kinds.CasesType false -> str "pattern-matching return predicate" | Evar_kinds.CasesType true -> @@ -1409,12 +1411,11 @@ let pr_evar_universe_context ctx = h 0 (Universes.pr_universe_opt_subst (UState.subst ctx)) ++ fnl()) let print_env_short env = - let pr_body n = function - | None -> pr_name n - | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in - let pr_named_decl decl = pr_body (Name (get_id decl)) (get_value decl) in - let pr_rel_decl decl = let open Context.Rel.Declaration in - pr_body (get_name decl) (get_value decl) in + let pr_rel_decl = function + | RelDecl.LocalAssum (n,_) -> pr_name n + | RelDecl.LocalDef (n,b,_) -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" + in + let pr_named_decl = NamedDecl.to_rel_decl %> pr_rel_decl in let nc = List.rev (named_context env) in let rc = List.rev (rel_context env) in str "[" ++ pr_sequence pr_named_decl nc ++ str "]" ++ spc () ++ @@ -1433,11 +1434,11 @@ let pr_evar_constraints pbs = Namegen.make_all_name_different env in print_env_short env ++ spc () ++ str "|-" ++ spc () ++ - print_constr_env env t1 ++ spc () ++ + Hook.get f_print_constr env t1 ++ spc () ++ str (match pbty with | Reduction.CONV -> "==" | Reduction.CUMUL -> "<=") ++ - spc () ++ print_constr_env env t2 + spc () ++ Hook.get f_print_constr env t2 in prlist_with_sep fnl pr_evconstr pbs diff --git a/engine/evd.mli b/engine/evd.mli index 86887f3dc..993ed300b 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -618,6 +618,7 @@ val pr_evar_suggested_name : existential_key -> evar_map -> Id.t (** {5 Debug pretty-printers} *) +val print_constr_hook : (Environ.env -> constr -> Pp.std_ppcmds) Hook.t val pr_evar_info : evar_info -> Pp.std_ppcmds val pr_evar_constraints : evar_constraint list -> Pp.std_ppcmds val pr_evar_map : ?with_univs:bool -> int option -> evar_map -> Pp.std_ppcmds diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 17ff898b0..6e821ea5a 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -34,7 +34,7 @@ exception Timeout exception TacticFailure of exn let _ = CErrors.register_handler begin function - | Timeout -> CErrors.errorlabstrm "Some timeout function" (Pp.str"Timeout!") + | Timeout -> CErrors.user_err ~hdr:"Some timeout function" (Pp.str"Timeout!") | Exception e -> CErrors.print e | TacticFailure e -> CErrors.print e | _ -> Pervasives.raise CErrors.Unhandled diff --git a/engine/namegen.ml b/engine/namegen.ml index 84eb98684..e56ec2877 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -21,9 +21,10 @@ open Nameops open Libnames open Globnames open Environ -open Termops open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (**********************************************************************) (* Conventional names *) @@ -76,6 +77,10 @@ let is_constructor id = with Not_found -> false +let is_section_variable id = + try let _ = Global.lookup_named id in true + with Not_found -> false + (**********************************************************************) (* Generating "intuitive" names from its type *) @@ -114,9 +119,9 @@ let hdchar env c = | Rel n -> (if n<=k then "p" (* the initial term is flexible product/function *) else - try match Environ.lookup_rel (n-k) env |> to_tuple with - | (Name id,_,_) -> lowercase_first_char id - | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) + try match Environ.lookup_rel (n-k) env with + | LocalAssum (Name id,_) | LocalDef (Name id,_,_) -> lowercase_first_char id + | LocalAssum (Anonymous,t) | LocalDef (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) with Not_found -> "y") | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> let id = match lna.(i) with Name id -> id | _ -> assert false in @@ -168,7 +173,7 @@ let it_mkLambda_or_LetIn_name env b hyps = (* Looks for next "good" name by lifting subscript *) let next_ident_away_from id bad = - let rec name_rec id = if bad id then name_rec (lift_subscript id) else id in + let rec name_rec id = if bad id then name_rec (increment_subscript id) else id in name_rec id (* Restart subscript from x0 if name starts with xN, or x00 if name @@ -180,10 +185,6 @@ let restart_subscript id = *** make_ident id (Some 0) *** but compatibility would be lost... *) forget_subscript id -let rec to_avoid id = function -| [] -> false -| id' :: avoid -> Id.equal id id' || to_avoid id avoid - let visible_ids (nenv, c) = let accu = ref (Refset_env.empty, Int.Set.empty, Id.Set.empty) in let rec visible_ids n c = match kind_of_term c with @@ -205,8 +206,8 @@ let visible_ids (nenv, c) = if p > n && not (Int.Set.mem p vseen) then let vseen = Int.Set.add p vseen in let name = - try Some (lookup_name_of_rel (p - n) nenv) - with Not_found -> + try Some (List.nth nenv (p - n - 1)) + with Invalid_argument _ | Failure _ -> (* Unbound index: may happen in debug and actually also while computing temporary implicit arguments of an inductive type *) @@ -230,8 +231,8 @@ let visible_ids (nenv, c) = let next_name_away_in_cases_pattern env_t na avoid = let id = match na with Name id -> id | Anonymous -> default_dependent_ident in let visible = visible_ids env_t in - let bad id = to_avoid id avoid || is_constructor id - || Id.Set.mem id visible in + let bad id = Id.List.mem id avoid || is_constructor id + || Id.Set.mem id visible in next_ident_away_from id bad (* 2- Looks for a fresh name for introduction in goal *) @@ -244,8 +245,8 @@ let next_name_away_in_cases_pattern env_t na avoid = name is taken by finding a free subscript starting from 0 *) let next_ident_away_in_goal id avoid = - let id = if to_avoid id avoid then restart_subscript id else id in - let bad id = to_avoid id avoid || (is_global id && not (is_section_variable id)) in + let id = if Id.List.mem id avoid then restart_subscript id else id in + let bad id = Id.List.mem id avoid || (is_global id && not (is_section_variable id)) in next_ident_away_from id bad let next_name_away_in_goal na avoid = @@ -262,16 +263,16 @@ let next_name_away_in_goal na avoid = beyond the current subscript *) let next_global_ident_away id avoid = - let id = if to_avoid id avoid then restart_subscript id else id in - let bad id = to_avoid id avoid || is_global id in + let id = if Id.List.mem id avoid then restart_subscript id else id in + let bad id = Id.List.mem id avoid || is_global id in next_ident_away_from id bad (* 4- Looks for next fresh name outside a list; if name already used, looks for same name with lower available subscript *) let next_ident_away id avoid = - if to_avoid id avoid then - next_ident_away_from (restart_subscript id) (fun id -> to_avoid id avoid) + if Id.List.mem id avoid then + next_ident_away_from (restart_subscript id) (fun id -> Id.List.mem id avoid) else id let next_name_away_with_default default na avoid = @@ -292,15 +293,18 @@ let next_name_away_with_default_using_types default na avoid t = let next_name_away = next_name_away_with_default default_non_dependent_string let make_all_name_different env = - let avoid = ref (ids_of_named_context (named_context env)) in - process_rel_context + (** FIXME: this is inefficient, but only used in printing *) + let avoid = ref (Id.Set.elements (Context.Named.to_vars (named_context env))) in + let sign = named_context_val env in + let rels = rel_context env in + let env0 = reset_with_named_context sign env in + Context.Rel.fold_outside (fun decl newenv -> - let (na,_,t) = to_tuple decl in - let na = named_hd newenv t na in + let na = named_hd newenv (RelDecl.get_type decl) (RelDecl.get_name decl) in let id = next_name_away na !avoid in avoid := id::!avoid; - push_rel (set_name (Name id) decl) newenv) - env + push_rel (RelDecl.set_name (Name id) decl) newenv) + rels ~init:env0 (* 5- Looks for next fresh name outside a list; avoids also to use names that would clash with short name of global references; if name is already used, @@ -309,7 +313,7 @@ let make_all_name_different env = let next_ident_away_for_default_printing env_t id avoid = let visible = visible_ids env_t in - let bad id = to_avoid id avoid || Id.Set.mem id visible in + let bad id = Id.List.mem id avoid || Id.Set.mem id visible in next_ident_away_from id bad let next_name_away_for_default_printing env_t na avoid = @@ -380,12 +384,12 @@ let rename_bound_vars_as_displayed avoid env c = let na',avoid' = compute_displayed_name_in (RenamingElsewhereFor (env,c2)) avoid na c2 in - mkProd (na', c1, rename avoid' (add_name na' env) c2) + mkProd (na', c1, rename avoid' (na' :: env) c2) | LetIn (na,c1,t,c2) -> let na',avoid' = compute_displayed_let_name_in (RenamingElsewhereFor (env,c2)) avoid na c2 in - mkLetIn (na',c1,t, rename avoid' (add_name na' env) c2) + mkLetIn (na',c1,t, rename avoid' (na' :: env) c2) | Cast (c,k,t) -> mkCast (rename avoid env c, k,t) | _ -> c in diff --git a/engine/namegen.mli b/engine/namegen.mli index 97c7c34a5..33ce9a34d 100644 --- a/engine/namegen.mli +++ b/engine/namegen.mli @@ -54,7 +54,22 @@ val it_mkLambda_or_LetIn_name : env -> constr -> Context.Rel.t -> constr (** Avoid clashing with a name satisfying some predicate *) val next_ident_away_from : Id.t -> (Id.t -> bool) -> Id.t -(** Avoid clashing with a name of the given list *) +(** [next_ident_away original_id unwanted_ids] returns a new identifier as close as possible + to the [original_id] while avoiding all [unwanted_ids]. + + In particular: + {ul {- if [original_id] does not appear in the list of [unwanted_ids], then [original_id] is returned.} + {- if [original_id] appears in the list of [unwanted_ids], + then this function returns a new id that: + {ul {- has the same {i root} as the [original_id],} + {- does not occur in the list of [unwanted_ids],} + {- has the smallest possible {i subscript}.}}}} + + where by {i subscript} of some identifier we mean last part of it that is composed + only from (decimal) digits and by {i root} of some identifier we mean + the whole identifier except for the {i subscript}. + + E.g. if we take [foo42], then [42] is the {i subscript}, and [foo] is the root. *) val next_ident_away : Id.t -> Id.t list -> Id.t (** Avoid clashing with a name already used in current module *) diff --git a/engine/proofview.ml b/engine/proofview.ml index c01879765..721389af4 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -22,6 +22,8 @@ open Context.Named.Declaration (** Main state of tactics *) type proofview = Proofview_monad.proofview +(* The first items in pairs below are proofs (under construction). + The second items in the pairs below are statements that are being proved. *) type entry = (Term.constr * Term.types) list (** Returns a stylised view of a proofview for use by, for instance, @@ -341,7 +343,7 @@ let set_nosuchgoals_hook f = nosuchgoals_hook := f let _ = CErrors.register_handler begin function | NoSuchGoals n -> let suffix = !nosuchgoals_hook n in - CErrors.errorlabstrm "" + CErrors.user_err (str "No such " ++ str (String.plural n "goal") ++ str "." ++ pr_non_empty_arg (fun x -> x) suffix) | _ -> raise CErrors.Unhandled @@ -421,13 +423,13 @@ let tclFOCUSID id t = exception SizeMismatch of int*int let _ = CErrors.register_handler begin function - | SizeMismatch (i,_) -> + | SizeMismatch (i,j) -> let open Pp in let errmsg = str"Incorrect number of goals" ++ spc() ++ - str"(expected "++int i++str(String.plural i " tactic") ++ str")." + str"(expected "++int i++str(String.plural i " tactic") ++ str", was given "++ int j++str")." in - CErrors.errorlabstrm "" errmsg + CErrors.user_err errmsg | _ -> raise CErrors.Unhandled end @@ -451,6 +453,25 @@ let iter_goal i = Solution.get >>= fun evd -> Comb.set CList.(undefined evd (flatten (rev subgoals))) +(** List iter but allocates a list of results *) +let map_goal i = + let rev = List.rev in (* hem... Proof masks List... *) + let open Proof in + Comb.get >>= fun initial -> + Proof.List.fold_left begin fun (acc, subgoals as cur) goal -> + Solution.get >>= fun step -> + match Evarutil.advance step goal with + | None -> return cur + | Some goal -> + Comb.set [goal] >> + i goal >>= fun res -> + Proof.map (fun comb -> comb :: subgoals) Comb.get >>= fun x -> + return (res :: acc, x) + end ([],[]) initial >>= fun (results_rev, subgoals) -> + Solution.get >>= fun evd -> + Comb.set CList.(undefined evd (flatten (rev subgoals))) >> + return (rev results_rev) + (** A variant of [Monad.List.fold_left2] where the first list is the list of focused goals. The argument tactic is executed in a focus comprising only of the current goal, a goal which has been solved @@ -583,7 +604,15 @@ let tclINDEPENDENT tac = let tac = InfoL.tag (Info.DBranch) tac in InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac)) - +let tclINDEPENDENTL tac = + let open Proof in + Pv.get >>= fun initial -> + match initial.comb with + | [] -> tclUNIT [] + | [_] -> tac >>= fun x -> return [x] + | _ -> + let tac = InfoL.tag (Info.DBranch) tac in + InfoL.tag (Info.Dispatch) (map_goal (fun _ -> tac)) (** {7 Goal manipulation} *) @@ -839,11 +868,11 @@ let tclPROGRESS t = if not test then tclUNIT res else - tclZERO (CErrors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) + tclZERO (CErrors.UserError (Some "Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) exception Timeout let _ = CErrors.register_handler begin function - | Timeout -> CErrors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") + | Timeout -> CErrors.user_err ~hdr:"Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") | _ -> Pervasives.raise CErrors.Unhandled end @@ -1050,7 +1079,7 @@ module Goal = struct exception NotExactlyOneSubgoal let _ = CErrors.register_handler begin function | NotExactlyOneSubgoal -> - CErrors.errorlabstrm "" (Pp.str"Not exactly one subgoal.") + CErrors.user_err (Pp.str"Not exactly one subgoal.") | _ -> raise CErrors.Unhandled end diff --git a/engine/proofview.mli b/engine/proofview.mli index 90be2f90a..294b03dca 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -292,6 +292,7 @@ val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tact independent of backtracking in another. It is equivalent to [tclEXTEND [] tac []]. *) val tclINDEPENDENT : unit tactic -> unit tactic +val tclINDEPENDENTL: 'a tactic -> 'a list tactic (** {7 Goal manipulation} *) diff --git a/engine/termops.ml b/engine/termops.ml index 697b9a5f1..2f4c5e204 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -17,6 +17,7 @@ open Environ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration +module CompactedDecl = Context.Compacted.Declaration (* Sorts and sort family *) @@ -100,6 +101,7 @@ let term_printer = ref (fun _ -> pr_constr) let print_constr_env t = !term_printer t let print_constr t = !term_printer (Global.env()) t let set_print_constr f = term_printer := f +let () = Hook.set Evd.print_constr_hook (fun env c -> !term_printer env c) let pr_var_decl env decl = let open NamedDecl in @@ -607,7 +609,10 @@ let vars_of_global_reference env gr = [m] is appropriately lifted through abstractions of [t] *) let dependent_main noevar univs m t = - let eqc x y = if univs then fst (Universes.eq_constr_universes x y) else eq_constr_nounivs x y in + let eqc x y = + if univs then not (Option.is_empty (Universes.eq_constr_universes x y)) + else eq_constr_nounivs x y + in let rec deprec m t = if eqc m t then raise Occur @@ -673,6 +678,21 @@ let rec subst_meta bl c = | Meta i -> (try Int.List.assoc i bl with Not_found -> c) | _ -> map_constr (subst_meta bl) c +let rec strip_outer_cast c = match kind_of_term c with + | Cast (c,_,_) -> strip_outer_cast c + | _ -> c + +(* flattens application lists throwing casts in-between *) +let collapse_appl c = match kind_of_term c with + | App (f,cl) -> + let rec collapse_rec f cl2 = + match kind_of_term (strip_outer_cast f) with + | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) + | _ -> mkApp (f,cl2) + in + collapse_rec f cl + | _ -> c + (* First utilities for avoiding telescope computation for subst_term *) let prefix_application eq_fun (k,c) (t : constr) = @@ -982,18 +1002,27 @@ let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init let mem_named_context_val id ctxt = try ignore(Environ.lookup_named_val id ctxt); true with Not_found -> false -let compact_named_context_reverse sign = +let compact_named_context sign = let compact l decl = - let (i1,c1,t1) = NamedDecl.to_tuple decl in - match l with - | [] -> [[i1],c1,t1] - | (l2,c2,t2)::q -> - if Option.equal Constr.equal c1 c2 && Constr.equal t1 t2 - then (i1::l2,c2,t2)::q - else ([i1],c1,t1)::l - in Context.Named.fold_inside compact ~init:[] sign - -let compact_named_context sign = List.rev (compact_named_context_reverse sign) + match decl, l with + | NamedDecl.LocalAssum (i,t), [] -> + [CompactedDecl.LocalAssum ([i],t)] + | NamedDecl.LocalDef (i,c,t), [] -> + [CompactedDecl.LocalDef ([i],c,t)] + | NamedDecl.LocalAssum (i1,t1), CompactedDecl.LocalAssum (li,t2) :: q -> + if Constr.equal t1 t2 + then CompactedDecl.LocalAssum (i1::li, t2) :: q + else CompactedDecl.LocalAssum ([i1],t1) :: CompactedDecl.LocalAssum (li,t2) :: q + | NamedDecl.LocalDef (i1,c1,t1), CompactedDecl.LocalDef (li,c2,t2) :: q -> + if Constr.equal c1 c2 && Constr.equal t1 t2 + then CompactedDecl.LocalDef (i1::li, c2, t2) :: q + else CompactedDecl.LocalDef ([i1],c1,t1) :: CompactedDecl.LocalDef (li,c2,t2) :: q + | NamedDecl.LocalAssum (i,t), q -> + CompactedDecl.LocalAssum ([i],t) :: q + | NamedDecl.LocalDef (i,c,t), q -> + CompactedDecl.LocalDef ([i],c,t) :: q + in + sign |> Context.Named.fold_inside compact ~init:[] |> List.rev let clear_named_body id env = let open NamedDecl in diff --git a/engine/termops.mli b/engine/termops.mli index fd8edafbc..78826f79a 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -164,6 +164,13 @@ val eq_constr : constr -> constr -> bool (* FIXME rename: erases universes*) val eta_reduce_head : constr -> constr +(** Flattens application lists *) +val collapse_appl : constr -> constr + +(** Remove recursively the casts around a term i.e. + [strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) +val strip_outer_cast : constr -> constr + exception CannotFilter (** Lightweight first-order filtering procedure. Unification @@ -239,8 +246,7 @@ val fold_named_context_both_sides : ('a -> Context.Named.Declaration.t -> Context.Named.Declaration.t list -> 'a) -> Context.Named.t -> init:'a -> 'a val mem_named_context_val : Id.t -> named_context_val -> bool -val compact_named_context : Context.Named.t -> Context.NamedList.t -val compact_named_context_reverse : Context.Named.t -> Context.NamedList.t +val compact_named_context : Context.Named.t -> Context.Compacted.t val clear_named_body : Id.t -> env -> env diff --git a/engine/uState.ml b/engine/uState.ml index c35f97b2e..c66af02bb 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -255,8 +255,8 @@ let universe_context ?names ctx = let l = try UNameMap.find (Id.to_string id) (fst ctx.uctx_names) with Not_found -> - user_err_loc (loc, "universe_context", - str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") + user_err ~loc ~hdr:"universe_context" + (str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc)) pl ([], [], levels) in @@ -269,8 +269,8 @@ let universe_context ?names ctx = Option.default Loc.ghost info.uloc with Not_found -> Loc.ghost in - user_err_loc (loc, "universe_context", - (str(CString.plural n "Universe") ++ spc () ++ + user_err ~loc ~hdr:"universe_context" + ((str(CString.plural n "Universe") ++ spc () ++ Univ.LSet.pr (pr_uctx_level ctx) left ++ spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")) diff --git a/library/universes.ml b/engine/universes.ml index 112b20a4c..30a9ef163 100644 --- a/library/universes.ml +++ b/engine/universes.ml @@ -15,19 +15,8 @@ open Univ open Globnames open Decl_kinds -(** Global universe names *) -type universe_names = - (polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t - -let global_universes = - Summary.ref ~name:"Global universe names" - ((Idmap.empty, Univ.LMap.empty) : universe_names) - -let global_universe_names () = !global_universes -let set_global_universe_names s = global_universes := s - let pr_with_global_universes l = - try Nameops.pr_id (LMap.find l (snd !global_universes)) + try Nameops.pr_id (LMap.find l (snd (Global.global_universe_names ()))) with Not_found -> Level.pr l (** Local universe names of polymorphic references *) @@ -143,11 +132,11 @@ let to_constraints g s = "to_constraints: non-trivial algebraic constraint between universes") in Constraints.fold tr s Constraint.empty -let eq_constr_univs_infer univs fold m n accu = +let test_constr_univs_infer leq univs fold m n accu = if m == n then Some accu else let cstrs = ref accu in - let eq_universes strict = UGraph.check_eq_instances univs in + let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else @@ -156,12 +145,34 @@ let eq_constr_univs_infer univs fold m n accu = | None -> false | Some accu -> cstrs := accu; true in + let leq_sorts s1 s2 = + if Sorts.equal s1 s2 then true + else + let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in + match fold (Constraints.singleton (u1, ULe, u2)) !cstrs with + | None -> false + | Some accu -> cstrs := accu; true + in let rec eq_constr' m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in - let res = Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in + let res = + if leq then + let rec compare_leq m n = + Constr.compare_head_gen_leq eq_universes leq_sorts + eq_constr' leq_constr' m n + and leq_constr' m n = m == n || compare_leq m n in + compare_leq m n + else Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n + in if res then Some !cstrs else None +let eq_constr_univs_infer univs fold m n accu = + test_constr_univs_infer false univs fold m n accu + +let leq_constr_univs_infer univs fold m n accu = + test_constr_univs_infer true univs fold m n accu + (** Variant of [eq_constr_univs_infer] taking kind-of-term functions, to expose subterms of [m] and [n], arguments. *) let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu = @@ -187,58 +198,8 @@ let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu = let res = Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n in if res then Some !cstrs else None -let leq_constr_univs_infer univs fold m n accu = - if m == n then Some accu - else - let cstrs = ref accu in - let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in - let eq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with - | None -> false - | Some accu -> cstrs := accu; true - in - let leq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - match fold (Constraints.singleton (u1, ULe, u2)) !cstrs with - | None -> false - | Some accu -> cstrs := accu; true - in - let rec eq_constr' m n = - m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n - in - let rec compare_leq m n = - Constr.compare_head_gen_leq eq_universes leq_sorts - eq_constr' leq_constr' m n - and leq_constr' m n = m == n || compare_leq m n in - let res = compare_leq m n in - if res then Some !cstrs else None - -let eq_constr_universes m n = - if m == n then true, Constraints.empty - else - let cstrs = ref Constraints.empty in - let eq_universes strict l l' = - cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in - let eq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - (cstrs := Constraints.add - (Sorts.univ_of_sort s1, UEq, Sorts.univ_of_sort s2) !cstrs; - true) - in - let rec eq_constr' m n = - m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n - in - let res = Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in - res, !cstrs - -let leq_constr_universes m n = - if m == n then true, Constraints.empty +let test_constr_universes leq m n = + if m == n then Some Constraints.empty else let cstrs = ref Constraints.empty in let eq_universes strict l l' = @@ -259,11 +220,19 @@ let leq_constr_universes m n = let rec eq_constr' m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in - let rec compare_leq m n = - Constr.compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n - and leq_constr' m n = m == n || compare_leq m n in - let res = compare_leq m n in - res, !cstrs + let res = + if leq then + let rec compare_leq m n = + Constr.compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n + and leq_constr' m n = m == n || compare_leq m n in + compare_leq m n + else + Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n + in + if res then Some !cstrs else None + +let eq_constr_universes m n = test_constr_universes false m n +let leq_constr_universes m n = test_constr_universes true m n let compare_head_gen_proj env equ eqs eqc' m n = match kind_of_term m, kind_of_term n with @@ -337,7 +306,7 @@ let existing_instance ctx inst = and a2 = Instance.to_array (UContext.instance ctx) in let len1 = Array.length a1 and len2 = Array.length a2 in if not (len1 == len2) then - CErrors.errorlabstrm "Universes" + CErrors.user_err ~hdr:"Universes" (str "Polymorphic constant expected " ++ int len2 ++ str" levels but was given " ++ int len1) else () @@ -447,10 +416,9 @@ let constr_of_global gr = (* Should be an error as we might forget constraints, allow for now to make firstorder work with "using" clauses *) c - else raise (Invalid_argument - ("constr_of_global: globalization of polymorphic reference " ^ - Pp.string_of_ppcmds (Nametab.pr_global_env Id.Set.empty gr) ^ - " would forget universes.")) + else CErrors.user_err ~hdr:"constr_of_global" + Pp.(str "globalization of polymorphic reference " ++ Nametab.pr_global_env Id.Set.empty gr ++ + str " would forget universes.") else c let constr_of_reference = constr_of_global diff --git a/library/universes.mli b/engine/universes.mli index d3a271b8d..725c21d29 100644 --- a/library/universes.mli +++ b/engine/universes.mli @@ -17,13 +17,6 @@ val is_set_minimization : unit -> bool (** Universes *) -(** Global universe name <-> level mapping *) -type universe_names = - (Decl_kinds.polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t - -val global_universe_names : unit -> universe_names -val set_global_universe_names : universe_names -> unit - val pr_with_global_universes : Level.t -> Pp.std_ppcmds (** Local universe name <-> level mapping *) @@ -95,11 +88,11 @@ val leq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator -> (** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and the universe constraints in [c]. *) -val eq_constr_universes : constr -> constr -> bool universe_constrained +val eq_constr_universes : constr -> constr -> universe_constraints option (** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe constraints in [c]. *) -val leq_constr_universes : constr -> constr -> bool universe_constrained +val leq_constr_universes : constr -> constr -> universe_constraints option (** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and the universe constraints in [c]. *) diff --git a/grammar/q_util.mli b/grammar/q_util.mli index a5e36e47b..37ec1d56a 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -41,6 +41,8 @@ val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr +val mlexpr_of_name : ('a -> MLast.expr) -> 'a option -> MLast.expr + val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.expr val type_of_user_symbol : user_symbol -> argument_type diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp index 2d5c40894..0dd096ef7 100644 --- a/grammar/q_util.mlp +++ b/grammar/q_util.mlp @@ -58,6 +58,10 @@ let mlexpr_of_option f = function | None -> <:expr< None >> | Some e -> <:expr< Some $f e$ >> +let mlexpr_of_name f = function + | None -> <:expr< Anonymous >> + | Some e -> <:expr< Name $f e$ >> + let symbol_of_string s = <:expr< Extend.Atoken (CLexer.terminal $str:s$) >> let rec mlexpr_of_prod_entry_key f = function @@ -70,8 +74,8 @@ let rec mlexpr_of_prod_entry_key f = function | Uentryl (e, l) -> (** Keep in sync with Pcoq! *) assert (e = "tactic"); - if l = 5 then <:expr< Extend.Aentry (Pcoq.Tactic.binder_tactic) >> - else <:expr< Extend.Aentryl (Pcoq.Tactic.tactic_expr) $mlexpr_of_int l$ >> + if l = 5 then <:expr< Extend.Aentry (Pltac.binder_tactic) >> + else <:expr< Extend.Aentryl (Pltac.tactic_expr) $mlexpr_of_int l$ >> let rec type_of_user_symbol = function | Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) -> diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index 683a7e2f7..8c0614a7b 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -61,7 +61,7 @@ let rec mlexpr_of_symbol = function <:expr< Extend.Uentry (Genarg.ArgT.Any $arg$) >> | Uentryl (e, l) -> assert (e = "tactic"); - let arg = get_argt <:expr< Constrarg.wit_tactic >> in + let arg = get_argt <:expr< Tacarg.wit_tactic >> in <:expr< Extend.Uentryl (Genarg.ArgT.Any $arg$) $mlexpr_of_int l$>> let make_prod_item = function @@ -82,14 +82,14 @@ let make_var = function | ExtNonTerminal (_, p) -> Some p | _ -> assert false -let declare_tactic loc s c cl = match cl with +let declare_tactic loc tacname ~level classification clause = match clause with | [(ExtTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem -> (** The extension is only made of a name followed by constr entries: we do not add any grammar nor printing rule and add it as a true Ltac definition. *) let patt = make_patt rem in let vars = List.map make_var rem in - let vars = mlexpr_of_list (mlexpr_of_option mlexpr_of_ident) vars in - let entry = mlexpr_of_string s in + let vars = mlexpr_of_list (mlexpr_of_name mlexpr_of_ident) vars in + let entry = mlexpr_of_string tacname 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 @@ -117,13 +117,14 @@ let declare_tactic loc s c cl = match cl with | _ -> (** Otherwise we add parsing and printing rules to generate a call to a TacML tactic. *) - let entry = mlexpr_of_string s in + let entry = mlexpr_of_string tacname in let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in - let gl = mlexpr_of_clause cl in - let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $gl$ >> in + let gl = mlexpr_of_clause clause in + let level = mlexpr_of_int level in + let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $level$ $gl$ >> in declare_str_items loc [ <:str_item< do { - Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc s cl$); + Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc tacname clause$); Mltop.declare_cache_obj $obj$ $plugin_name$; } >> ] @@ -134,20 +135,17 @@ EXTEND GLOBAL: str_item; str_item: [ [ "TACTIC"; "EXTEND"; s = tac_name; + level = OPT [ "AT"; UIDENT "LEVEL"; level = INT -> level ]; c = OPT [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >> ]; OPT "|"; l = LIST1 tacrule SEP "|"; "END" -> - declare_tactic loc s c l ] ] + let level = match level with Some i -> int_of_string i | None -> 0 in + declare_tactic loc s ~level c l ] ] ; tacrule: [ [ "["; l = LIST1 tacargs; "]"; c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> c ]; - "->"; "["; e = Pcaml.expr; "]" -> - (match l with - | ExtNonTerminal _ :: _ -> - (* En attendant la syntaxe de tacticielles *) - failwith "Tactic syntax must start with an identifier" - | _ -> (l,c,e)) + "->"; "["; e = Pcaml.expr; "]" -> (l,c,e) ] ] ; tacargs: diff --git a/ide/coq.ml b/ide/coq.ml index 6d44ca59e..3a1d87787 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -205,7 +205,7 @@ type handle = { proc : CoqTop.process; xml_oc : Xml_printer.t; mutable alive : bool; - mutable waiting_for : (ccb * logger) option; (* last call + callback + log *) + mutable waiting_for : ccb option; (* last call + callback *) } (** Coqtop process status : @@ -290,18 +290,6 @@ let rec check_errors = function | `NVAL :: _ -> raise (TubeError "NVAL") | `OUT :: _ -> raise (TubeError "OUT") -let handle_intermediate_message handle level content = - let logger = match handle.waiting_for with - | Some (_, l) -> l - | None -> function - | Feedback.Error -> fun s -> Minilib.log ~level:`ERROR (xml_to_string s) - | Feedback.Info -> fun s -> Minilib.log ~level:`INFO (xml_to_string s) - | Feedback.Notice -> fun s -> Minilib.log ~level:`NOTICE (xml_to_string s) - | Feedback.Warning -> fun s -> Minilib.log ~level:`WARNING (xml_to_string s) - | Feedback.Debug -> fun s -> Minilib.log ~level:`DEBUG (xml_to_string s) - in - logger level content - let handle_feedback feedback_processor xml = let feedback = Xmlprotocol.to_feedback xml in feedback_processor feedback @@ -310,7 +298,7 @@ let handle_final_answer handle xml = let () = Minilib.log "Handling coqtop answer" in let ccb = match handle.waiting_for with | None -> raise (AnswerWithoutRequest (Xml_printer.to_string_fmt xml)) - | Some (c, _) -> c in + | Some c -> c in let () = handle.waiting_for <- None in with_ccb ccb { bind_ccb = fun (c, f) -> f (Xmlprotocol.to_answer c xml) } @@ -332,18 +320,13 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all = let l_end = Lexing.lexeme_end lex in state.fragment <- String.sub s l_end (String.length s - l_end); state.lexerror <- None; - match Xmlprotocol.is_message xml with - | Some (lvl, _loc, msg) -> - handle_intermediate_message handle lvl msg; + if Xmlprotocol.is_feedback xml then begin + handle_feedback feedback_processor xml; loop () - | None -> - if Xmlprotocol.is_feedback xml then begin - handle_feedback feedback_processor xml; - loop () - end else - begin - ignore (handle_final_answer handle xml) - end + end else + begin + ignore (handle_final_answer handle xml) + end in try loop () with Xml_parser.Error _ as e -> @@ -383,7 +366,7 @@ let bind_self_as f = (** This launches a fresh handle from its command line arguments. *) let spawn_handle args respawner feedback_processor = let prog = coqtop_path () in - let args = Array.of_list ("-async-proofs" :: "on" :: "-ideslave" :: args) in + let args = Array.of_list ("--xml_format=Ppcmds" :: "-async-proofs" :: "on" :: "-ideslave" :: args) in let env = match !Flags.ideslave_coqtop_flags with | None -> None @@ -493,20 +476,20 @@ let init_coqtop coqtop task = type 'a query = 'a Interface.value task -let eval_call ?(logger=default_logger) call handle k = +let eval_call call handle k = (** Send messages to coqtop and prepare the decoding of the answer *) Minilib.log ("Start eval_call " ^ Xmlprotocol.pr_call call); assert (handle.alive && handle.waiting_for = None); - handle.waiting_for <- Some (mk_ccb (call,k), logger); + handle.waiting_for <- Some (mk_ccb (call,k)); Xml_printer.print handle.xml_oc (Xmlprotocol.of_call call); Minilib.log "End eval_call"; Void -let add ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.add x) +let add x = eval_call (Xmlprotocol.add x) let edit_at i = eval_call (Xmlprotocol.edit_at i) -let query ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.query x) +let query x = eval_call (Xmlprotocol.query x) let mkcases s = eval_call (Xmlprotocol.mkcases s) -let status ?logger force = eval_call ?logger (Xmlprotocol.status force) +let status force = eval_call (Xmlprotocol.status force) let hints x = eval_call (Xmlprotocol.hints x) let search flags = eval_call (Xmlprotocol.search flags) let init x = eval_call (Xmlprotocol.init x) @@ -566,18 +549,11 @@ struct let _ = reset () - (** Integer option *) - - let width = ["Printing"; "Width"] - let width_state = ref None - let set_printing_width w = width_state := Some w - (** Transmitting options to coqtop *) let enforce h k = let mkopt o v acc = (o, Interface.BoolValue v) :: acc in let opts = Hashtbl.fold mkopt current_state [] in - let opts = (width, Interface.IntValue !width_state) :: opts in eval_call (Xmlprotocol.set_options opts) h (function | Interface.Good () -> k () @@ -585,8 +561,8 @@ struct end -let goals ?logger x h k = - PrintOpt.enforce h (fun () -> eval_call ?logger (Xmlprotocol.goals x) h k) +let goals x h k = + PrintOpt.enforce h (fun () -> eval_call (Xmlprotocol.goals x) h k) let evars x h k = PrintOpt.enforce h (fun () -> eval_call (Xmlprotocol.evars x) h k) diff --git a/ide/coq.mli b/ide/coq.mli index 8a1fa3ed1..ab8c12a6f 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -115,15 +115,11 @@ val try_grab : coqtop -> unit task -> (unit -> unit) -> unit type 'a query = 'a Interface.value task (** A type abbreviation for coqtop specific answers *) -val add : ?logger:Ideutils.logger -> - Interface.add_sty -> Interface.add_rty query +val add : Interface.add_sty -> Interface.add_rty query val edit_at : Interface.edit_at_sty -> Interface.edit_at_rty query -val query : ?logger:Ideutils.logger -> - Interface.query_sty -> Interface.query_rty query -val status : ?logger:Ideutils.logger -> - Interface.status_sty -> Interface.status_rty query -val goals : ?logger:Ideutils.logger -> - Interface.goals_sty -> Interface.goals_rty query +val query : Interface.query_sty -> Interface.query_rty query +val status : Interface.status_sty -> Interface.status_rty query +val goals : Interface.goals_sty -> Interface.goals_rty query val evars : Interface.evars_sty -> Interface.evars_rty query val hints : Interface.hints_sty -> Interface.hints_rty query val mkcases : Interface.mkcases_sty -> Interface.mkcases_rty query @@ -143,7 +139,6 @@ sig val bool_items : bool_descr list val set : t -> bool -> unit - val set_printing_width : int -> unit (** [enforce] transmits to coq the current option values. It is also called by [goals] and [evars] above. *) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 1563c7ffb..4a1d688f5 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -128,6 +128,9 @@ end = struct end open SentenceId +let log_pp msg : unit task = + Coq.lift (fun () -> Minilib.log_pp msg) + let log msg : unit task = Coq.lift (fun () -> Minilib.log msg) @@ -162,13 +165,16 @@ let flags_to_color f = else if List.mem `INCOMPLETE f then `NAME "gray" else `NAME Preferences.processed_color#get -let validate s = - let open Xml_datatype in - let rec validate = function - | PCData s -> Glib.Utf8.validate s - | Element (_, _, children) -> List.for_all validate children - in - validate (Richpp.repr s) +(* Move to utils? *) +let rec validate (s : Pp.std_ppcmds) = match Pp.repr s with + | Pp.Ppcmd_empty + | Pp.Ppcmd_print_break _ + | Pp.Ppcmd_force_newline -> true + | Pp.Ppcmd_glue l -> List.for_all validate l + | Pp.Ppcmd_string s -> Glib.Utf8.validate s + | Pp.Ppcmd_box (_,s) + | Pp.Ppcmd_tag (_,s) -> validate s + | Pp.Ppcmd_comment s -> List.for_all Glib.Utf8.validate s module Doc = Document @@ -305,7 +311,7 @@ object(self) method private print_stack = Minilib.log "document:"; - Minilib.log (Pp.string_of_ppcmds (Doc.print document (dbg_to_string buffer))) + Minilib.log_pp (Doc.print document (dbg_to_string buffer)) method private enter_focus start stop = let at id id' _ = Stateid.equal id' id in @@ -337,7 +343,6 @@ object(self) buffer#get_iter_at_mark `INSERT method private show_goals_aux ?(move_insert=false) () = - Coq.PrintOpt.set_printing_width proof#width; if move_insert then begin let dest = self#get_start_of_input in if (buffer#get_iter_at_mark `INSERT)#compare dest <= 0 then begin @@ -345,7 +350,7 @@ object(self) script#recenter_insert end end; - Coq.bind (Coq.goals ~logger:messages#push ()) (function + Coq.bind (Coq.goals ()) (function | Fail x -> self#handle_failure_aux ~move_insert x | Good goals -> Coq.bind (Coq.evars ()) (function @@ -368,7 +373,7 @@ object(self) else messages#add s; in let query = - Coq.query ~logger:messages#push (phrase,Stateid.dummy) in + Coq.query (phrase,Stateid.dummy) in let next = function | Fail (_, _, err) -> display_error err; Coq.return () | Good msg -> @@ -377,8 +382,7 @@ object(self) Coq.bind (Coq.seq action query) next method private mark_as_needed sentence = - Minilib.log("Marking " ^ - Pp.string_of_ppcmds (dbg_to_string buffer false None sentence)); + Minilib.log_pp Pp.(str "Marking " ++ dbg_to_string buffer false None sentence); let start = buffer#get_iter_at_mark sentence.start in let stop = buffer#get_iter_at_mark sentence.stop in let to_process = Tags.Script.to_process in @@ -418,9 +422,10 @@ object(self) | _ -> false method private enqueue_feedback msg = + (* Minilib.log ("Feedback received: " ^ Xml_printer.to_string_fmt (Xmlprotocol.of_feedback msg)); *) let id = msg.id in if self#is_dummy_id id then () else Queue.add msg feedbacks - + method private process_feedback () = let rec eat_feedback n = if n = 0 then true else @@ -434,9 +439,11 @@ object(self) | _ -> None in try Some (Doc.find_map document finder) with Not_found -> None in - let log s state_id = - Minilib.log ("Feedback " ^ s ^ " on " ^ Stateid.to_string - (Option.default Stateid.dummy state_id)) in + let log_pp s state_id = + Minilib.log_pp Pp.(seq + [str "Feedback "; s; str " on "; + str (Stateid.to_string (Option.default Stateid.dummy state_id))]) in + let log s state_id = log_pp (Pp.str s) state_id in begin match msg.contents, sentence with | AddedAxiom, Some (id,sentence) -> log "AddedAxiom" id; @@ -466,22 +473,24 @@ object(self) (Printf.sprintf "%s %s %s" filepath ident ty) | Message(Error, loc, msg), Some (id,sentence) -> let loc = Option.default Loc.ghost loc in - let msg = Richpp.raw_print msg in - log "ErrorMsg" id; + log_pp Pp.(str "ErrorMsg" ++ msg) id; remove_flag sentence `PROCESSING; - add_flag sentence (`ERROR (loc, msg)); + let rmsg = Pp.string_of_ppcmds msg in + add_flag sentence (`ERROR (loc, rmsg)); self#mark_as_needed sentence; - self#attach_tooltip sentence loc msg; + self#attach_tooltip sentence loc rmsg; if not (Loc.is_ghost loc) then self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc)) | Message(Warning, loc, msg), Some (id,sentence) -> let loc = Option.default Loc.ghost loc in - let msg = Richpp.raw_print msg in - log "WarningMsg" id; - add_flag sentence (`WARNING (loc, msg)); - self#attach_tooltip sentence loc msg; - self#position_warning_tag_at_sentence sentence loc - | Message((Info|Notice|Debug as lvl), _, msg), _ -> + log_pp Pp.(str "WarningMsg" ++ msg) id; + let rmsg = Pp.string_of_ppcmds msg in + add_flag sentence (`WARNING (loc, rmsg)); + self#attach_tooltip sentence loc rmsg; + self#position_warning_tag_at_sentence sentence loc; + messages#push Warning msg + | Message(lvl, loc, msg), Some (id,sentence) -> + log_pp Pp.(str "Msg" ++ msg) id; messages#push lvl msg | InProgress n, _ -> if n < 0 then processed <- processed + abs n @@ -628,10 +637,9 @@ object(self) if Queue.is_empty queue then conclude topstack else match Queue.pop queue, topstack with | `Skip(start,stop), [] -> - - logger Feedback.Error (Richpp.richpp_of_string "You must close the proof with Qed or Admitted"); + logger Feedback.Error (Pp.str "You must close the proof with Qed or Admitted"); self#discard_command_queue queue; - conclude [] + conclude [] | `Skip(start,stop), (_,s) :: topstack -> assert(start#equal (buffer#get_iter_at_mark s.start)); assert(stop#equal (buffer#get_iter_at_mark s.stop)); @@ -641,11 +649,11 @@ object(self) add_flag sentence `PROCESSING; Doc.push document sentence; let _, _, phrase = self#get_sentence sentence in - let coq_query = Coq.add ~logger ((phrase,edit_id),(tip,verbose)) in + let coq_query = Coq.add ((phrase,edit_id),(tip,verbose)) in let handle_answer = function | Good (id, (Util.Inl (* NewTip *) (), msg)) -> Doc.assign_tip_id document id; - logger Feedback.Notice (Richpp.richpp_of_string msg); + logger Feedback.Notice (Pp.str msg); self#commit_queue_transaction sentence; loop id [] | Good (id, (Util.Inr (* Unfocus *) tip, msg)) -> @@ -653,7 +661,7 @@ object(self) let topstack, _ = Doc.context document in self#exit_focus; self#cleanup (Doc.cut_at document tip); - logger Feedback.Notice (Richpp.richpp_of_string msg); + logger Feedback.Notice (Pp.str msg); self#mark_as_needed sentence; if Queue.is_empty queue then loop tip [] else loop tip (List.rev topstack) @@ -672,10 +680,10 @@ object(self) let next = function | Good _ -> messages#clear; - messages#push Feedback.Info (Richpp.richpp_of_string "All proof terms checked by the kernel"); + messages#push Feedback.Info (Pp.str "All proof terms checked by the kernel"); Coq.return () | Fail x -> self#handle_failure x in - Coq.bind (Coq.status ~logger:messages#push true) next + Coq.bind (Coq.status true) next method stop_worker n = Coq.bind (Coq.stop_worker n) (fun _ -> Coq.return ()) @@ -859,7 +867,7 @@ object(self) let next = function | Fail (_, l, str) -> (* FIXME: check *) display_error (l, str); - messages#add (Richpp.richpp_of_string ("Unsuccessfully tried: "^phrase)); + messages#add (Pp.str ("Unsuccessfully tried: "^phrase)); more | Good msg -> messages#add_string msg; @@ -905,7 +913,7 @@ object(self) let get_initial_state = let next = function | Fail (_, _, message) -> - let message = "Couldn't initialize coqtop\n\n" ^ (Richpp.raw_print message) in + let message = "Couldn't initialize coqtop\n\n" ^ (Pp.string_of_ppcmds message) in let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok ~message_type:`ERROR ~message () in ignore (popup#run ()); exit 1 | Good id -> initial_state <- id; Coq.return () in diff --git a/ide/coqide.ml b/ide/coqide.ml index 450bfcdfb..25858acce 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -318,7 +318,7 @@ let export kind sn = local_cd f ^ cmd_coqdoc#get ^ " --" ^ kind ^ " -o " ^ (Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1" in - sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd)); + sn.messages#set (Pp.str ("Running: "^cmd)); let finally st = flash_info (cmd ^ pr_exit_status st) in run_command (fun msg -> sn.messages#add_string msg) finally cmd @@ -431,7 +431,7 @@ let compile sn = ^ " " ^ (Filename.quote f) ^ " 2>&1" in let buf = Buffer.create 1024 in - sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd)); + sn.messages#set (Pp.str ("Running: "^cmd)); let display s = sn.messages#add_string s; Buffer.add_string buf s @@ -441,8 +441,8 @@ let compile sn = flash_info (f ^ " successfully compiled") else begin flash_info (f ^ " failed to compile"); - sn.messages#set (Richpp.richpp_of_string "Compilation output:\n"); - sn.messages#add (Richpp.richpp_of_string (Buffer.contents buf)); + sn.messages#set (Pp.str "Compilation output:\n"); + sn.messages#add (Pp.str (Buffer.contents buf)); end in run_command display finally cmd @@ -464,7 +464,7 @@ let make sn = |Some f -> File.saveall (); let cmd = local_cd f ^ cmd_make#get ^ " 2>&1" in - sn.messages#set (Richpp.richpp_of_string "Compilation output:\n"); + sn.messages#set (Pp.str "Compilation output:\n"); Buffer.reset last_make_buf; last_make := ""; last_make_index := 0; @@ -508,11 +508,11 @@ let next_error sn = let stopi = b#get_iter_at_byte ~line:(line-1) stop in b#apply_tag Tags.Script.error ~start:starti ~stop:stopi; b#place_cursor ~where:starti; - sn.messages#set (Richpp.richpp_of_string error_msg); + sn.messages#set (Pp.str error_msg); sn.script#misc#grab_focus () with Not_found -> last_make_index := 0; - sn.messages#set (Richpp.richpp_of_string "No more errors.\n") + sn.messages#set (Pp.str "No more errors.\n") let next_error = cb_on_current_term next_error @@ -536,7 +536,7 @@ let update_status sn = display ("Ready"^ (if nanoPG#get then ", [μPG]" else "") ^ path ^ name); Coq.return () in - Coq.bind (Coq.status ~logger:sn.messages#push false) next + Coq.bind (Coq.status false) next let find_next_occurrence ~backward sn = (** go to the next occurrence of the current word, forward or backward *) @@ -789,7 +789,7 @@ let coqtop_arguments sn = let args = String.concat " " args in let msg = Printf.sprintf "Invalid arguments: %s" args in let () = sn.messages#clear in - sn.messages#push Feedback.Error (Richpp.richpp_of_string msg) + sn.messages#push Feedback.Error (Pp.str msg) else dialog#destroy () in let _ = entry#connect#activate ok_cb in @@ -887,8 +887,8 @@ let alpha_items menu_name item_name l = | [] -> () | [s] -> mk_item s | s::_ as ll -> - let name = item_name^" "^(String.make 1 s.[0]) in - let label = "_@..." in label.[1] <- s.[0]; + let name = Printf.sprintf "%s %c" item_name s.[0] in + let label = Printf.sprintf "_%c..." s.[0] in item name ~label menu_name; List.iter mk_item ll in diff --git a/ide/coqidetop.mllib b/ide/coqidetop.mllib index ed1fa465d..043ad6008 100644 --- a/ide/coqidetop.mllib +++ b/ide/coqidetop.mllib @@ -2,7 +2,7 @@ Xml_lexer Xml_parser Xml_printer Serialize -Richprinter +Richpp Xmlprotocol Texmacspp Document diff --git a/ide/ide.mllib b/ide/ide.mllib index b2f32fcf7..78b4c01e8 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -1,12 +1,7 @@ Minilib -Okey -Config_file -Configwin_keys -Configwin_types Configwin_messages Configwin_ihm Configwin -Editable_cells Config_parser Tags Wg_Notebook @@ -14,11 +9,12 @@ Config_lexer Utf8_convert Preferences Project_file -Serialize -Richprinter Xml_lexer Xml_parser Xml_printer +Serialize +Richpp +Topfmt Xmlprotocol Ideutils Coq diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index c0c4131ac..8cadf1a26 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -13,6 +13,10 @@ open Util open Pp open Printer +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration +module CompactedDecl = Context.Compacted.Declaration + (** Ide_slave : an implementation of [Interface], i.e. mainly an interp function and a rewind function. This specialized loop is triggered when the -ideslave option is passed to Coqtop. Currently CoqIDE is @@ -28,24 +32,6 @@ let init_signal_handler () = let f _ = if !catch_break then raise Sys.Break else Control.interrupt := true in Sys.set_signal Sys.sigint (Sys.Signal_handle f) - -(** Redirection of standard output to a printable buffer *) - -let init_stdout, read_stdout = - let out_buff = Buffer.create 100 in - let out_ft = Format.formatter_of_buffer out_buff in - let deep_out_ft = Format.formatter_of_buffer out_buff in - let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in - (fun () -> - flush_all (); - Pp_control.std_ft := out_ft; - Pp_control.err_ft := out_ft; - Pp_control.deep_ft := deep_out_ft; - ), - (fun () -> Format.pp_print_flush out_ft (); - let r = Buffer.contents out_buff in - Buffer.clear out_buff; r) - let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s let pr_error s = pr_with_pid s @@ -93,47 +79,64 @@ let is_undo cmd = match cmd with | VernacUndo _ | VernacUndoTo _ -> true | _ -> false -(** Check whether a command is forbidden by CoqIDE *) +(** Check whether a command is forbidden in the IDE *) -let coqide_cmd_checks (loc,ast) = - let user_error s = CErrors.user_err_loc (loc, "CoqIde", str s) in +let ide_cmd_checks (loc,ast) = + let user_error s = CErrors.user_err ~loc ~hdr:"CoqIde" (str s) in if is_debug ast then - user_error "Debug mode not available within CoqIDE"; + user_error "Debug mode not available in the IDE"; if is_known_option ast then - Feedback.msg_warning (strbrk"This will not work. Use CoqIDE view menu instead"); + Feedback.msg_warning (strbrk "Set this option from the IDE menu instead"); if Vernac.is_navigation_vernac ast || is_undo ast then - Feedback.msg_warning (strbrk "Rather use CoqIDE navigation instead"); + Feedback.msg_warning (strbrk "Use IDE navigation instead"); if is_query ast then Feedback.msg_warning (strbrk "Query commands should not be inserted in scripts") (** Interpretation (cf. [Ide_intf.interp]) *) let add ((s,eid),(sid,verbose)) = - let newid, rc = Stm.add ~ontop:sid verbose ~check:coqide_cmd_checks eid s in + let newid, rc = Stm.add ~ontop:sid verbose ~check:ide_cmd_checks eid s in let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in - newid, (rc, read_stdout ()) + (* TODO: the "" parameter is a leftover of the times the protocol + * used to include stderr/stdout output. + * + * Currently, we force all the output meant for the to go via the + * feedback mechanism, and we don't manipulate stderr/stdout, which + * are left to the client's discrection. The parameter is still there + * as not to break the core protocol for this minor change, but it should + * be removed in the next version of the protocol. + *) + newid, (rc, "") let edit_at id = match Stm.edit_at id with | `NewTip -> CSig.Inl () | `Focus { Stm.start; stop; tip} -> CSig.Inr (start, (stop, tip)) -let query (s,id) = Stm.query ~at:id s; read_stdout () +(* TODO: the "" parameter is a leftover of the times the protocol + * used to include stderr/stdout output. + * + * Currently, we force all the output meant for the to go via the + * feedback mechanism, and we don't manipulate stderr/stdout, which + * are left to the client's discrection. The parameter is still there + * as not to break the core protocol for this minor change, but it should + * be removed in the next version of the protocol. + *) +let query (s,id) = Stm.query ~at:id s; "" let annotate phrase = let (loc, ast) = let pa = Pcoq.Gram.parsable (Stream.of_string phrase) in Vernac.parse_sentence (pa,None) in - let (_, xml) = - Richprinter.richpp_vernac ast - in - xml + (* XXX: Width should be a parameter of annotate... *) + Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast) (** Goal display *) let hyp_next_tac sigma env decl = - let (id,_,ast) = Context.Named.Declaration.to_tuple decl in + let id = NamedDecl.get_id decl in + let ast = NamedDecl.get_type decl in let id_s = Names.Id.to_string id in let type_s = string_of_ppcmds (pr_ltype_env env sigma ast) in [ @@ -187,19 +190,15 @@ let process_goal sigma g = let id = Goal.uid g in let ccl = let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in - Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr) + pr_goal_concl_style_env env sigma norm_constr in let process_hyp d (env,l) = - let d = Context.NamedList.Declaration.map_constr (Reductionops.nf_evar sigma) d in - let d' = List.map (fun name -> let open Context.Named.Declaration in - match pi2 d with - | None -> LocalAssum (name, pi3 d) - | Some value -> LocalDef (name, value, pi3 d)) - (pi1 d) in + let d = CompactedDecl.map_constr (Reductionops.nf_evar sigma) d in + let d' = CompactedDecl.to_named_context d in (List.fold_right Environ.push_named d' env, - (Richpp.richpp_of_pp (pr_var_list_decl env sigma d)) :: l) in + (pr_compacted_decl env sigma d) :: l) in let (_env, hyps) = - Context.NamedList.fold process_hyp + Context.Compacted.fold process_hyp (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in { Interface.goal_hyp = List.rev hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } @@ -213,8 +212,6 @@ let export_pre_goals pgs = let goals () = Stm.finish (); - let s = read_stdout () in - if not (String.is_empty s) then Feedback.msg_info (str s); try let pfts = Proof_global.give_me_the_proof () in Some (export_pre_goals (Proof.map_structured_proof pfts process_goal)) @@ -223,8 +220,6 @@ let goals () = let evars () = try Stm.finish (); - let s = read_stdout () in - if not (String.is_empty s) then Feedback.msg_info (str s); let pfts = Proof_global.give_me_the_proof () in let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in let exl = Evar.Map.bindings (Evarutil.non_instantiated sigma) in @@ -256,8 +251,6 @@ let status force = and display the other parts (opened sections and modules) *) Stm.finish (); if force then Stm.join (); - let s = read_stdout () in - if not (String.is_empty s) then Feedback.msg_info (str s); let path = let l = Names.DirPath.repr (Lib.cwd ()) in List.rev_map Names.Id.to_string l @@ -280,7 +273,7 @@ let status force = let export_coq_object t = { Interface.coq_object_prefix = t.Search.coq_object_prefix; Interface.coq_object_qualid = t.Search.coq_object_qualid; - Interface.coq_object_object = t.Search.coq_object_object + Interface.coq_object_object = Pp.string_of_ppcmds (pr_lconstr_env (Global.env ()) Evd.empty t.Search.coq_object_object) } let pattern_of_string ?env s = @@ -300,7 +293,7 @@ let dirpath_of_string_list s = let id = try Nametab.full_name_module qid with Not_found -> - CErrors.errorlabstrm "Search.interface_search" + CErrors.user_err ~hdr:"Search.interface_search" (str "Module " ++ str path ++ str " not found.") in id @@ -363,14 +356,10 @@ let handle_exn (e, info) = let loc_of e = match Loc.get_loc e with | Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc) | _ -> None in - let mk_msg () = - let msg = read_stdout () in - let msg = str msg ++ fnl () ++ CErrors.print ~info e in - Richpp.richpp_of_pp msg - in + let mk_msg () = CErrors.print ~info e in match e with - | CErrors.Drop -> dummy, None, Richpp.richpp_of_string "Drop is not allowed by coqide!" - | CErrors.Quit -> dummy, None, Richpp.richpp_of_string "Quit is not allowed by coqide!" + | CErrors.Drop -> dummy, None, Pp.str "Drop is not allowed by coqide!" + | CErrors.Quit -> dummy, None, Pp.str "Quit is not allowed by coqide!" | e -> match Stateid.get info with | Some (valid, _) -> valid, loc_of info, mk_msg () @@ -408,7 +397,16 @@ let interp ((_raw, verbose), s) = | Some ast -> ast) () in Stm.interp verbose (vernac_parse s); - Stm.get_current_state (), CSig.Inl (read_stdout ()) + (* TODO: the "" parameter is a leftover of the times the protocol + * used to include stderr/stdout output. + * + * Currently, we force all the output meant for the to go via the + * feedback mechanism, and we don't manipulate stderr/stdout, which + * are left to the client's discrection. The parameter is still there + * as not to break the core protocol for this minor change, but it should + * be removed in the next version of the protocol. + *) + Stm.get_current_state (), CSig.Inl "" (** When receiving the Quit call, we don't directly do an [exit 0], but rather set this reference, in order to send a final answer @@ -427,14 +425,12 @@ let print_ast id = (** Grouping all call handlers together + error handling *) -let eval_call xml_oc log c = +let eval_call c = let interruptible f x = catch_break := true; Control.check_for_interrupt (); let r = f x in catch_break := false; - let out = read_stdout () in - if not (String.is_empty out) then log (str out); r in let handler = { @@ -472,16 +468,8 @@ let print_xml = try Xml_printer.print oc xml; Mutex.unlock m with e -> let e = CErrors.push e in Mutex.unlock m; iraise e - -let slave_logger xml_oc ?loc level message = - (* convert the message into XML *) - let msg = hov 0 message in - let () = pr_debug (Printf.sprintf "-> %S" (string_of_ppcmds msg)) in - let xml = Xmlprotocol.of_message level loc (Richpp.richpp_of_pp message) in - print_xml xml_oc xml - -let slave_feeder xml_oc msg = - let xml = Xmlprotocol.of_feedback msg in +let slave_feeder fmt xml_oc msg = + let xml = Xmlprotocol.(of_feedback fmt msg) in print_xml xml_oc xml (** The main loop *) @@ -490,17 +478,22 @@ let slave_feeder xml_oc msg = messages by [handle_exn] above. Otherwise, we die badly, without trying to answer malformed requests. *) +let msg_format = ref (fun () -> + let margin = Option.default 72 (Topfmt.get_margin ()) in + Xmlprotocol.Richpp margin +) + let loop () = init_signal_handler (); catch_break := false; - let in_ch, out_ch = Spawned.get_channels () in - let xml_oc = Xml_printer.make (Xml_printer.TChannel out_ch) in - let in_lb = Lexing.from_function (fun s len -> - CThread.thread_friendly_read in_ch s ~off:0 ~len) in - let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in + let in_ch, out_ch = Spawned.get_channels () in + let xml_oc = Xml_printer.make (Xml_printer.TChannel out_ch) in + let in_lb = Lexing.from_function (fun s len -> + CThread.thread_friendly_read in_ch s ~off:0 ~len) in + (* SEXP parser make *) + let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in let () = Xml_parser.check_eof xml_ic false in - Feedback.set_logger (slave_logger xml_oc); - Feedback.add_feeder (slave_feeder xml_oc); + ignore (Feedback.add_feeder (slave_feeder (!msg_format ()) xml_oc)); (* We'll handle goal fetching and display in our own way *) Vernacentries.enable_goal_printing := false; Vernacentries.qed_display_script := false; @@ -510,10 +503,10 @@ let loop () = (* pr_with_pid (Xml_printer.to_string_fmt xml_query); *) let Xmlprotocol.Unknown q = Xmlprotocol.to_call xml_query in let () = pr_debug_call q in - let r = eval_call xml_oc (slave_logger xml_oc Feedback.Notice) q in + let r = eval_call q in let () = pr_debug_answer q r in (* pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *) - print_xml xml_oc (Xmlprotocol.of_answer q r); + print_xml xml_oc Xmlprotocol.(of_answer (!msg_format ()) q r); flush out_ch with | Xml_parser.Error (Xml_parser.Empty, _) -> @@ -535,16 +528,19 @@ let loop () = let rec parse = function | "--help-XML-protocol" :: rest -> Xmlprotocol.document Xml_printer.to_string_fmt; exit 0 + | "--xml_format=Ppcmds" :: rest -> + msg_format := (fun () -> Xmlprotocol.Ppcmds); parse rest | x :: rest -> x :: parse rest | [] -> [] let () = Coqtop.toploop_init := (fun args -> let args = parse args in Flags.make_silent true; - init_stdout (); CoqworkmgrApi.(init Flags.High); args) let () = Coqtop.toploop_run := loop -let () = Usage.add_to_usage "coqidetop" " --help-XML-protocol print the documentation of the XML protocol used by CoqIDE\n" +let () = Usage.add_to_usage "coqidetop" +" --xml_format=Ppcmds serialize pretty printing messages using the std_ppcmds format + --help-XML-protocol print the documentation of the XML protocol used by CoqIDE\n" diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 06a132732..da867e689 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -43,7 +43,7 @@ let xml_to_string xml = | Element (_, _, children) -> List.iter iter children in - let () = iter (Richpp.repr xml) in + let () = iter xml in Buffer.contents buf let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text = @@ -75,7 +75,7 @@ let insert_xml ?(mark = `INSERT) ?(tags = []) (buf : #GText.buffer_skel) msg = let tags = try tag t :: tags with Not_found -> tags in List.iter (fun xml -> insert tags xml) children in - let () = try insert tags (Richpp.repr msg) with _ -> () in + let () = try insert tags msg with _ -> () in buf#delete_mark rmark let set_location = ref (function s -> failwith "not ready") @@ -294,18 +294,20 @@ let coqtop_path () = match cmd_coqtop#get with | Some s -> s | None -> - let prog = String.copy Sys.executable_name in try - let pos = String.length prog - 6 in - let i = Str.search_backward (Str.regexp_string "coqide") prog pos + let old_prog = Sys.executable_name in + let pos = String.length old_prog - 6 in + let i = Str.search_backward (Str.regexp_string "coqide") old_prog pos in - String.blit "coqtop" 0 prog i 6; - if Sys.file_exists prog then prog + let new_prog = Bytes.of_string old_prog in + Bytes.blit_string "coqtop" 0 new_prog i 6; + let new_prog = Bytes.to_string new_prog in + if Sys.file_exists new_prog then new_prog else let in_macos_bundle = Filename.concat - (Filename.dirname prog) - (Filename.concat "../Resources/bin" (Filename.basename prog)) + (Filename.dirname new_prog) + (Filename.concat "../Resources/bin" (Filename.basename new_prog)) in if Sys.file_exists in_macos_bundle then in_macos_bundle else "coqtop" with Not_found -> "coqtop" @@ -325,7 +327,7 @@ let textview_width (view : #GText.view_skel) = let char_width = GPango.to_pixels metrics#approx_char_width in pixel_width / char_width -type logger = Feedback.level -> Richpp.richpp -> unit +type logger = Feedback.level -> Pp.std_ppcmds -> unit let default_logger level message = let level = match level with @@ -335,7 +337,7 @@ let default_logger level message = | Feedback.Warning -> `WARNING | Feedback.Error -> `ERROR in - Minilib.log ~level (xml_to_string message) + Minilib.log_pp ~level message (** {6 File operations} *) @@ -357,7 +359,7 @@ let stat f = let maxread = 4096 -let read_string = String.create maxread +let read_string = Bytes.create maxread let read_buffer = Buffer.create maxread (** Read the content of file [f] and add it to buffer [b]. @@ -368,7 +370,7 @@ let read_file name buf = let len = ref 0 in try while len := input ic read_string 0 maxread; !len > 0 do - Buffer.add_substring buf read_string 0 !len + Buffer.add_subbytes buf read_string 0 !len done; close_in ic with e -> close_in ic; raise e @@ -381,8 +383,9 @@ let read_file name buf = let io_read_all chan = Buffer.clear read_buffer; let read_once () = - let len = Glib.Io.read_chars ~buf:read_string ~pos:0 ~len:maxread chan in - Buffer.add_substring read_buffer read_string 0 len + (* XXX: Glib.Io must be converted to bytes / -safe-string upstream *) + let len = Glib.Io.read_chars ~buf:(Bytes.unsafe_to_string read_string) ~pos:0 ~len:maxread chan in + Buffer.add_subbytes read_buffer read_string 0 len in begin try while true do read_once () done diff --git a/ide/ideutils.mli b/ide/ideutils.mli index e32a4d9e3..4b4ba72b0 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -52,8 +52,6 @@ val pop_info : unit -> unit val clear_info : unit -> unit val flash_info : ?delay:int -> string -> unit -val xml_to_string : Richpp.richpp -> string - val insert_xml : ?mark:GText.mark -> ?tags:GText.tag list -> #GText.buffer_skel -> Richpp.richpp -> unit @@ -69,7 +67,7 @@ val requote : string -> string val textview_width : #GText.view_skel -> int (** Returns an approximate value of the character width of a textview *) -type logger = Feedback.level -> Richpp.richpp -> unit +type logger = Feedback.level -> Pp.std_ppcmds -> unit val default_logger : logger (** Default logger. It logs messages that the casual user should not see. *) diff --git a/ide/interface.mli b/ide/interface.mli index 123cac6c2..9ed606258 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -12,15 +12,14 @@ type raw = bool type verbose = bool -type richpp = Richpp.richpp (** The type of coqtop goals *) type goal = { goal_id : string; (** Unique goal identifier *) - goal_hyp : richpp list; + goal_hyp : Pp.std_ppcmds list; (** List of hypotheses *) - goal_ccl : richpp; + goal_ccl : Pp.std_ppcmds; (** Goal conclusion *) } @@ -119,7 +118,7 @@ type edit_id = Feedback.edit_id should probably retract to that point *) type 'a value = | Good of 'a - | Fail of (state_id * location * richpp) + | Fail of (state_id * location * Pp.std_ppcmds) type ('a, 'b) union = ('a, 'b) Util.union @@ -128,9 +127,13 @@ type ('a, 'b) union = ('a, 'b) Util.union (** [add ((s,eid),(sid,v))] adds the phrase [s] with edit id [eid] on top of the current edit position (that is asserted to be [sid]) verbosely if [v] is true. The response [(id,(rc,s)] is the new state - [id] assigned to the phrase, some output [s]. [rc] is [Inl] if the new + [id] assigned to the phrase. [rc] is [Inl] if the new state id is the tip of the edit point, or [Inr tip] if the new phrase - closes a focus and [tip] is the new edit tip *) + closes a focus and [tip] is the new edit tip + + [s] used to contain Coq's console output and has been deprecated + in favor of sending feedback, it will be removed in a future + version of the protocol. *) type add_sty = (string * edit_id) * (state_id * verbose) type add_rty = state_id * ((unit, state_id) union * string) @@ -143,8 +146,12 @@ type add_rty = state_id * ((unit, state_id) union * string) type edit_at_sty = state_id type edit_at_rty = (unit, state_id * (state_id * state_id)) union -(** [query s id] executes [s] at state [id] and does not record any state - change but for the printings that are sent in response *) +(** [query s id] executes [s] at state [id]. + + query used to reply with the contents of Coq's console output, and + has been deprecated in favor of sending the query answers as + feedback. It will be removed in a future version of the protocol. +*) type query_sty = string * state_id type query_rty = string @@ -203,7 +210,7 @@ type about_sty = unit type about_rty = coq_info type handle_exn_sty = Exninfo.iexn -type handle_exn_rty = state_id * location * richpp +type handle_exn_rty = state_id * location * Pp.std_ppcmds (* Retrocompatibility stuff *) type interp_sty = (raw * verbose) * string diff --git a/ide/minilib.ml b/ide/minilib.ml index d11e8c56b..2c24e46f8 100644 --- a/ide/minilib.ml +++ b/ide/minilib.ml @@ -30,7 +30,7 @@ let debug = ref false print in the response buffer. *) -let log ?(level = `DEBUG) msg = +let log_pp ?(level = `DEBUG) msg = let prefix = match level with | `DEBUG -> "DEBUG" | `INFO -> "INFO" @@ -40,10 +40,12 @@ let log ?(level = `DEBUG) msg = | `FATAL -> "FATAL" in if !debug then begin - try Printf.eprintf "[%s] %s\n%!" prefix msg + try Format.eprintf "[%s] @[%a@]\n%!" prefix Pp.pp_with msg with _ -> () end +let log ?level str = log_pp ?level (Pp.str str) + let coqify d = Filename.concat d "coq" let coqide_config_home () = diff --git a/ide/minilib.mli b/ide/minilib.mli index b7672c900..4517a2374 100644 --- a/ide/minilib.mli +++ b/ide/minilib.mli @@ -22,7 +22,8 @@ type level = [ (** debug printing *) val debug : bool ref -val log : ?level:level -> string -> unit +val log_pp : ?level:level -> Pp.std_ppcmds -> unit +val log : ?level:level -> string -> unit val coqide_config_home : unit -> string val coqide_config_dirs : unit -> string list diff --git a/lib/richpp.ml b/ide/richpp.ml index d1c6d158e..522a3e0b3 100644 --- a/lib/richpp.ml +++ b/ide/richpp.ml @@ -24,10 +24,6 @@ type 'a context = { (** Pending opened nodes *) mutable offset : int; (** Quantity of characters printed so far *) - mutable annotations : 'a option Int.Map.t; - (** Map associating annotations to indexes *) - mutable index : int; - (** Current index of annotations *) } (** We use Format to introduce tags inside the pretty-printed document. @@ -38,23 +34,13 @@ type 'a context = { marking functions. As those functions are called when actually writing to the device, the resulting tree is correct. *) -let rich_pp annotate ppcmds = +let rich_pp width ppcmds = let context = { stack = Leaf; offset = 0; - annotations = Int.Map.empty; - index = (-1); } in - let pp_tag obj = - let index = context.index + 1 in - let () = context.index <- index in - let obj = annotate obj in - let () = context.annotations <- Int.Map.add index obj context.annotations in - string_of_int index - in - let pp_buffer = Buffer.create 180 in let push_pcdata () = @@ -81,12 +67,8 @@ let rich_pp annotate ppcmds = | Leaf -> assert false | Node (node, child, pos, ctx) -> let () = assert (String.equal tag node) in - let annotation = - try Int.Map.find (int_of_string node) context.annotations - with _ -> None - in let annotation = { - annotation = annotation; + annotation = Some tag; startpos = pos; endpos = context.offset; } in @@ -113,18 +95,20 @@ let rich_pp annotate ppcmds = pp_set_formatter_tag_functions ft tag_functions; pp_set_mark_tags ft true; - (* Set formatter width. This is currently a hack and duplicate code - with Pp_control. Hopefully it will be fixed better in Coq 8.7 *) - let w = pp_get_margin str_formatter () in - let m = max (64 * w / 100) (w-30) in - pp_set_margin ft w; + (* Setting the formatter *) + pp_set_margin ft width; + let m = max (64 * width / 100) (width-30) in pp_set_max_indent ft m; + pp_set_max_boxes ft 50 ; + pp_set_ellipsis_text ft "..."; (** The whole output must be a valid document. To that end, we nest the document inside <pp> tags. *) + pp_open_box ft 0; pp_open_tag ft "pp"; - Pp.(pp_with ~pp_tag ft ppcmds); + Pp.(pp_with ft ppcmds); pp_close_tag ft (); + pp_close_box ft (); (** Get the resulting XML tree. *) let () = pp_print_flush ft () in @@ -172,32 +156,14 @@ let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml = type richpp = xml -let repr xml = xml -let richpp_of_xml xml = xml -let richpp_of_string s = PCData s - -let richpp_of_pp pp = - let annotate t = match Pp.Tag.prj t Ppstyle.tag with - | None -> None - | Some key -> Some (Ppstyle.repr key) - in +let richpp_of_pp width pp = let rec drop = function | PCData s -> [PCData s] | Element (_, annotation, cs) -> let cs = List.concat (List.map drop cs) in match annotation.annotation with | None -> cs - | Some s -> [Element (String.concat "." s, [], cs)] + | Some s -> [Element (s, [], cs)] in - let xml = rich_pp annotate pp in + let xml = rich_pp width pp in Element ("_", [], drop xml) - -let raw_print xml = - let buf = Buffer.create 1024 in - let rec print = function - | PCData s -> Buffer.add_string buf s - | Element (_, _, cs) -> List.iter print cs - in - let () = print xml in - Buffer.contents buf - diff --git a/lib/richpp.mli b/ide/richpp.mli index 287d265a8..ea4b189ba 100644 --- a/lib/richpp.mli +++ b/ide/richpp.mli @@ -16,14 +16,15 @@ type 'annotation located = { endpos : int } -(** [rich_pp get_annotations ppcmds] returns the interpretation +(* XXX: The width parameter should be moved to a `formatter_property` + record shared with Topfmt *) + +(** [rich_pp width ppcmds] returns the interpretation of [ppcmds] as a semi-structured document that represents (located) annotations of this string. The [get_annotations] function is used to convert tags into the desired - annotation. *) -val rich_pp : - (Pp.Tag.t -> 'annotation option) -> Pp.std_ppcmds -> - 'annotation located Xml_datatype.gxml + annotation. [width] sets the printing witdh of the formatter. *) +val rich_pp : int -> Pp.std_ppcmds -> Pp.pp_tag located Xml_datatype.gxml (** [annotations_positions ssdoc] returns a list associating each annotations with its position in the string from which [ssdoc] is @@ -42,23 +43,9 @@ val xml_of_rich_pp : (** {5 Enriched text} *) -type richpp +type richpp = Xml_datatype.xml + (** Type of text with style annotations *) -val richpp_of_pp : Pp.std_ppcmds -> richpp +val richpp_of_pp : int -> Pp.std_ppcmds -> richpp (** Extract style information from formatted text *) - -val richpp_of_xml : Xml_datatype.xml -> richpp -(** Do not use outside of dedicated areas *) - -val richpp_of_string : string -> richpp -(** Make a styled text out of a normal string *) - -val repr : richpp -> Xml_datatype.xml -(** Observe the styled text as XML *) - -(** {5 Debug/Compat} *) - -(** Represent the semi-structured document as a string, dropping any additional - information. *) -val raw_print : richpp -> string diff --git a/ide/richprinter.ml b/ide/richprinter.ml deleted file mode 100644 index 5f39f36ea..000000000 --- a/ide/richprinter.ml +++ /dev/null @@ -1,24 +0,0 @@ -open Richpp - -module RichppConstr = Ppconstr.Richpp -module RichppVernac = Ppvernac.Richpp -module RichppTactic = Pptactic.Richpp - -type rich_pp = - Ppannotation.t Richpp.located Xml_datatype.gxml - * Xml_datatype.xml - -let get_annotations obj = Pp.Tag.prj obj Ppannotation.tag - -let make_richpp pr ast = - let rich_pp = - rich_pp get_annotations (pr ast) - in - let xml = Ppannotation.( - xml_of_rich_pp tag_of_annotation attributes_of_annotation rich_pp - ) - in - (rich_pp, xml) - -let richpp_vernac = make_richpp RichppVernac.pr_vernac -let richpp_constr = make_richpp RichppConstr.pr_constr_expr diff --git a/ide/richprinter.mli b/ide/richprinter.mli deleted file mode 100644 index c9e84e3eb..000000000 --- a/ide/richprinter.mli +++ /dev/null @@ -1,36 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** This module provides an entry point to "rich" pretty-printers that - produce pretty-printing as done by {!Printer} but with additional - annotations represented as a semi-structured document. - - To understand what are these annotations and how they are represented - as standard XML attributes, please refer to {!Ppannotation}. - - In addition to these annotations, each node of the semi-structured - document contains a [startpos] and an [endpos] attribute that - relate this node to the raw pretty-printing. - Please refer to {!Richpp} for more details. *) - -(** A rich pretty-print is composed of: *) -type rich_pp = - - (** - a generalized semi-structured document whose attributes are - annotations ; *) - Ppannotation.t Richpp.located Xml_datatype.gxml - - (** - an XML document, representing annotations as usual textual - XML attributes. *) - * Xml_datatype.xml - -(** [richpp_vernac phrase] produces a rich pretty-printing of [phrase]. *) -val richpp_vernac : Vernacexpr.vernac_expr -> rich_pp - -(** [richpp_constr constr] produces a rich pretty-printing of [constr]. *) -val richpp_constr : Constrexpr.constr_expr -> rich_pp diff --git a/ide/texmacspp.ml b/ide/texmacspp.ml index 680da7f54..6fbed38fb 100644 --- a/ide/texmacspp.ml +++ b/ide/texmacspp.ml @@ -127,10 +127,6 @@ let xmlProofMode loc name = xmlWithLoc loc "proofmode" ["name",name] [] let xmlProof loc xml = xmlWithLoc loc "proof" [] xml -let xmlRawTactic name rtac = - Element("rawtactic", ["name",name], - [PCData (Pp.string_of_ppcmds (Pptactic.pr_raw_tactic rtac))]) - let xmlSectionSubsetDescr name ssd = Element("sectionsubsetdescr",["name",name], [PCData (Proof_using.to_string ssd)]) @@ -744,7 +740,7 @@ let rec tmpp v loc = | VernacShow _ as x -> xmlTODO loc x | VernacCheckGuard as x -> xmlTODO loc x | VernacProof (tac,using) -> - let tac = Option.map (xmlRawTactic "closingtactic") tac in + let tac = None (** FIXME *) in let using = Option.map (xmlSectionSubsetDescr "using") using in xmlProof loc (Option.List.(cons tac (cons using []))) | VernacProofMode name -> xmlProofMode loc name diff --git a/ide/utils/config_file.ml b/ide/utils/config_file.ml deleted file mode 100644 index 4d0aabeb6..000000000 --- a/ide/utils/config_file.ml +++ /dev/null @@ -1,640 +0,0 @@ -(*********************************************************************************) -(* Cameleon *) -(* *) -(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. *) -(* *) -(* This program is free software; you can redistribute it and/or modify *) -(* it under the terms of the GNU Library General Public License as *) -(* published by the Free Software Foundation; either version 2 of the *) -(* License, or any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU Library General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU Library General Public *) -(* License along with this program; if not, write to the Free Software *) -(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) -(* 02111-1307 USA *) -(* *) -(* Contact: Maxence.Guesdon@inria.fr *) -(* *) -(*********************************************************************************) - -(* TODO *) -(* section comments *) -(* better obsoletes: no "{}", line cuts *) - -(* possible improvements: *) -(* use lex/yacc instead of genlex to be more robust, efficient, allow arrays and other types, read comments. *) -(* description and help, level (beginner/advanced/...) for each cp *) -(* find an option from its name and group *) -(* class hooks *) -(* get the sections of a group / of a file *) -(* read file format from inifiles and ConfigParser *) - - -(* Read the mli before reading this file! *) - - -(* ******************************************************************************** *) -(* ******************************** misc utilities ******************************** *) -(* ******************************************************************************** *) -(* This code is intended to be usable without any dependencies. *) - -(* pipeline style, see for instance Raw.of_channel. *) -let (|>) x f = f x - -(* as List.assoc, but applies f to the element matching [key] and returns the list -where this element has been replaced by the result of f. *) -let rec list_assoc_remove key f = function - | [] -> raise Not_found - | (key',value) as elt :: tail -> - if key <> key' - then elt :: list_assoc_remove key f tail - else match f value with - | None -> tail - | Some a -> (key',a) :: tail - -(* reminiscent of String.concat. Same as [Queue.iter f1 queue] - but calls [f2 ()] between each calls to f1. - Does not call f2 before the first call nor after the last call to f2. - Could be more efficient with a richer module interface of Queue. -*) -let queue_iter_between f1 f2 queue = -(* let f flag elt = if flag then f2 (); (f1 elt:unit); true in *) - let f flag elt = if flag then f2 (); f1 elt; true in - ignore (Queue.fold f false queue) - -let list_iter_between f1 f2 = function - [] -> () - | a::[] -> f1 a - | a::tail -> f1 a; List.iter (fun elt -> (f2 ():unit); f1 elt) tail -(* | a::tail -> f1 a; List.iter (fun elt -> f2 (); f1 elt) tail *) -(* !! types ??? *) - -(* to ensure that strings will be parsed correctly by Genlex. -It's more comfortable not to have quotes around the string, but sometimes it's necessary. *) -exception Unsafe_string -let safe_string s = - if s = "" - then "\"\"" - else if ( - try match s.[0] with - | 'a'..'z' | 'A'..'Z' -> - for i = 1 to String.length s - 1 do - match s.[i] with - 'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> () - | _ -> raise Unsafe_string - done; - false - | _ -> - try - string_of_int (int_of_string s) <> s || - string_of_float (float_of_string s) <> s - with Failure "int_of_string" | Failure "float_of_string" -> true - with Unsafe_string -> true) - then Printf.sprintf "\"%s\"" (String.escaped s) - else s - - -(* ******************************************************************************** *) -(* ************************************* core ************************************* *) -(* ******************************************************************************** *) - -module Raw = struct - type cp = - | String of string - | Int of int - | Float of float - | List of cp list - | Tuple of cp list - | Section of (string * cp) list - -(* code generated by -camlp4 pa_o.cmo pa_op.cmo pr_o.cmo -- -o config_file_parser.ml -impl config_file_parser.ml4 -Unreadable on purpose, edit the file config_file_parser.ml4 rather than editing this (huge) lines. Then manually copy-paste here the content of config_file_parser.ml. -Could be one day rewritten with ocamllex/yacc to be more robust, efficient, allow arrays, read comments...*) - module Parse = struct - let lexer = Genlex.make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","] - let rec file l (strm__ : _ Stream.t) = match try Some (ident strm__) with Stream.Failure -> None with Some id -> begin match Stream.peek strm__ with Some (Genlex.Kwd "=") -> Stream.junk strm__; let v = try value strm__ with Stream.Failure -> raise (Stream.Error "") in begin try file ((id, v) :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> raise (Stream.Error "") end | _ -> List.rev l - and value (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd "{") -> Stream.junk strm__; let v = try file [] strm__ with Stream.Failure -> raise (Stream.Error "") in begin match Stream.peek strm__ with Some (Genlex.Kwd "}") -> Stream.junk strm__; Section v | _ -> raise (Stream.Error "") end | Some (Genlex.Ident s) -> Stream.junk strm__; String s | Some (Genlex.String s) -> Stream.junk strm__; String s | Some (Genlex.Int i) -> Stream.junk strm__; Int i | Some (Genlex.Float f) -> Stream.junk strm__; Float f | Some (Genlex.Char c) -> Stream.junk strm__; String (String.make 1 c) | Some (Genlex.Kwd "[") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in List v | Some (Genlex.Kwd "(") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in Tuple v | _ -> raise Stream.Failure - and ident (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Ident s) -> Stream.junk strm__; s | Some (Genlex.String s) -> Stream.junk strm__; s | _ -> raise Stream.Failure - and list l (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd ";") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | Some (Genlex.Kwd ",") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match try Some (value strm__) with Stream.Failure -> None with Some v -> begin try list (v :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match Stream.peek strm__ with Some (Genlex.Kwd "]") -> Stream.junk strm__; List.rev l | Some (Genlex.Kwd ")") -> Stream.junk strm__; List.rev l | _ -> raise Stream.Failure - end - - open Format - (* formating convention: the caller has to open the box, close it and flush the output *) - (* remarks on Format: - set_margin forces a call to set_max_indent - sprintf et bprintf are flushed at each call*) - - (* pretty print a Raw.cp *) - let rec save formatter = function - | String s -> fprintf formatter "%s" (safe_string s) (* How can I cut lines and *) - | Int i -> fprintf formatter "%d" i (* print backslashes just before the \n? *) - | Float f -> fprintf formatter "%g" f - | List l -> - fprintf formatter "[@[<b0>"; - list_iter_between - (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]") - (fun () -> fprintf formatter ";@ ") - l; - fprintf formatter "@]]" - | Tuple l -> - fprintf formatter "(@[<b0>"; - list_iter_between - (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]") - (fun () -> fprintf formatter ",@ ") - l; - fprintf formatter "@])" - | Section l -> - fprintf formatter "{@;<0 2>@[<hv0>"; - list_iter_between - (fun (name,value) -> - fprintf formatter "@[<hov2>%s =@ @[<b2>" name; - save formatter value; - fprintf formatter "@]@]";) - (fun () -> fprintf formatter "@;<2 0>") - l; - fprintf formatter "@]}" - -(* let to_string r = save str_formatter r; flush_str_formatter () *) - let to_channel out_channel r = - let f = formatter_of_out_channel out_channel in - fprintf f "@[<b2>"; save f r; fprintf f "@]@?" - - let of_string s = s |> Stream.of_string |> Parse.lexer |> Parse.value - - let of_channel in_channel = - let result = in_channel |> Stream.of_channel |> Parse.lexer |> Parse.file [] in - close_in in_channel; - result -end - -(* print the given string in a way compatible with Format. - Truncate the lines when needed, indent the newlines.*) -let print_help formatter = - String.iter (function - | ' ' -> Format.pp_print_space formatter () - | '\n' -> Format.pp_force_newline formatter () - | c -> Format.pp_print_char formatter c) - -type 'a wrappers = { - to_raw : 'a -> Raw.cp; - of_raw : Raw.cp -> 'a} - -class type ['a] cp = object -(* method private to_raw = wrappers.to_raw *) -(* method private of_raw = wrappers.of_raw *) -(* method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set *) - method add_hook : ('a -> 'a -> unit) -> unit - method get : 'a - method get_default : 'a - method set : 'a -> unit - method reset : unit - - method get_formatted : Format.formatter -> unit - method get_default_formatted : Format.formatter -> unit - method get_help_formatted : Format.formatter -> unit - - method get_name : string list - method get_short_name : string option - method set_short_name : string -> unit - method get_help : string - method get_spec : Arg.spec - - method set_raw : Raw.cp -> unit -end - -type groupable_cp = < - get_name : string list; - get_short_name : string option; - get_help : string; - - get_formatted : Format.formatter -> unit; - get_default_formatted : Format.formatter -> unit; - get_help_formatted : Format.formatter -> unit; - get_spec : Arg.spec; - - reset : unit; - set_raw : Raw.cp -> unit; > - -exception Double_name -exception Missing_cp of groupable_cp -exception Wrong_type of (out_channel -> unit) - -(* Two exceptions to stop the iteration on queues. *) -exception Found -exception Found_cp of groupable_cp - -(* The data structure to store the cps. -It's a tree, each node is a section, and a queue of sons with their name. -Each leaf contains a cp. *) -type 'a nametree = - | Immediate of 'a - | Subsection of ((string * 'a nametree) Queue.t) - (* this Queue must be nonempty for group.read.choose *) - -class group = object (self) - val mutable cps = Queue.create () (* hold all the added cps, in a nametree. *) - - method add : 'a. 'a cp -> unit = fun original_cp -> - let cp = (original_cp :> groupable_cp) in - (* function called when we reach the end of the list cp#get_name. *) - let add_immediate name cp queue = - Queue.iter (fun (name',_) -> if name = name' then raise Double_name) queue; - Queue.push (name, Immediate cp) queue in - (* adds the cp with name [first_name::last_name] in section [section]. *) - let rec add_in_section section first_name last_name cp queue = - let sub_add = match last_name with (* what to do once we have find the correct section *) - | [] -> add_immediate first_name - | middle_name :: last_name -> add_in_section first_name middle_name last_name in - try - Queue.iter - (function - | name, Subsection subsection when name = section -> - sub_add cp subsection; raise Found - | _ -> ()) - queue; - let sub_queue = Queue.create () in - sub_add cp sub_queue; - Queue.push (section, Subsection sub_queue) queue - with Found -> () in - (match cp#get_name with - | [] -> failwith "empty name" - | first_name :: [] -> add_immediate first_name cp cps - | first_name :: middle_name :: last_name -> - add_in_section first_name middle_name last_name cp cps) - - method write ?(with_help=true) filename = - let out_channel = open_out filename in - let formatter = Format.formatter_of_out_channel out_channel in - let print = Format.fprintf formatter in - print "@[<v>"; - let rec save_queue formatter = - queue_iter_between - (fun (name,nametree) -> save_nametree name nametree) - (Format.pp_print_cut formatter) - and save_nametree name = function - | Immediate cp -> - if with_help && cp#get_help <> "" then - (print "@[<hov3>(* "; cp#get_help_formatted formatter; - print "@ *)@]@,"); - Format.fprintf formatter "@[<hov2>%s =@ @[<b2>" (safe_string name); - cp#get_formatted formatter; - print "@]@]" - | Subsection queue -> - Format.fprintf formatter "%s = {@;<0 2>@[<v>" (safe_string name); - save_queue formatter queue; - print "@]@,}" in - save_queue formatter cps; - print "@]@."; close_out out_channel - - method read ?obsoletes ?(no_default=false) - ?(on_type_error = fun groupable_cp raw_cp output filename in_channel -> - close_in in_channel; - Printf.eprintf - "Type error while loading configuration parameter %s from file %s.\n%!" - (String.concat "." groupable_cp#get_name) filename; - output stderr; - exit 1) - filename = - (* [filename] is created if it doesn't exist. In this case there is no need to read it. *) - match Sys.file_exists filename with false -> self#write filename | true -> - let in_channel = open_in filename in - (* what to do when a cp is missing: *) - let missing cp default = if no_default then raise (Missing_cp cp) else default in - (* returns a cp contained in the nametree queue, which must be nonempty *) - let choose queue = - let rec iter q = Queue.iter (function - | _, Immediate cp -> raise (Found_cp cp) - | _, Subsection q -> iter q) q in - try iter queue; failwith "choose" with Found_cp cp -> cp in - (* [set_and_remove raw_cps nametree] sets the cp of [nametree] to their value - defined in [raw_cps] and returns the remaining raw_cps. *) - let set_cp cp value = - try cp#set_raw value - with Wrong_type output -> on_type_error cp value output filename in_channel in - let rec set_and_remove raw_cps = function - | name, Immediate cp -> - (try list_assoc_remove name (fun value -> set_cp cp value; None) raw_cps - with Not_found -> missing cp raw_cps) - | name, Subsection queue -> - (try list_assoc_remove name - (function - | Raw.Section l -> - (match remainings l queue with - | [] -> None - | l -> Some (Raw.Section l)) - | r -> missing (choose queue) (Some r)) - raw_cps - with Not_found -> missing (choose queue) raw_cps) - and remainings raw_cps queue = Queue.fold set_and_remove raw_cps queue in - let remainings = remainings (Raw.of_channel in_channel) cps in - (* Handling of cps defined in filename but not belonging to self. *) - if remainings <> [] then match obsoletes with - | Some filename -> - let out_channel = - open_out filename in -(* open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] 0o666 filename in *) - let formatter = Format.formatter_of_out_channel out_channel in - Format.fprintf formatter "@[<v>"; - Raw.save formatter (Raw.Section remainings); - Format.fprintf formatter "@]@."; - close_out out_channel - | None -> () - - method command_line_args ~section_separator = - let print = Format.fprintf Format.str_formatter in (* shortcut *) - let result = ref [] in let push x = result := x :: !result in - let rec iter = function - | _, Immediate cp -> - let key = "-" ^ String.concat section_separator cp#get_name in - let spec = cp#get_spec in - let doc = ( - print "@[<hv5>"; - Format.pp_print_as Format.str_formatter (String.length key +3) ""; - if cp#get_help <> "" - then (print "@,@[<b2>"; cp#get_help_formatted Format.str_formatter; print "@]@ ") - else print "@,"; - print "@[<hv>@[current:@;<1 2>@[<hov1>"; cp#get_formatted Format.str_formatter; - print "@]@],@ @[default:@;<1 2>@[<b2>"; cp#get_default_formatted Format.str_formatter; - print "@]@]@]@]"; - Format.flush_str_formatter ()) in - (match cp#get_short_name with - | None -> () - | Some short_name -> push ("-" ^ short_name,spec,"")); - push (key,spec,doc) - | _, Subsection queue -> Queue.iter iter queue in - Queue.iter iter cps; - List.rev !result -end - - -(* Given wrappers for the type 'a, cp_custom_type defines a class 'a cp. *) -class ['a] cp_custom_type wrappers - ?group:(group:group option) name ?short_name default help = -object (self) - method private to_raw = wrappers.to_raw - method private of_raw = wrappers.of_raw - - val mutable value = default - (* output *) - method get = value - method get_default = default - method get_formatted formatter = self#get |> self#to_raw |> Raw.save formatter - method get_default_formatted formatter = self#get_default |> self#to_raw |> Raw.save formatter - (* input *) - method set v = let v' = value in value <- v; self#exec_hooks v' v - method set_raw v = self#of_raw v |> self#set - method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set - method reset = self#set self#get_default - - (* name *) - val mutable shortname = short_name - method get_name = name - method get_short_name = shortname - method set_short_name s = shortname <- Some s - - (* help *) - method get_help = help - method get_help_formatted formatter = print_help formatter self#get_help - method get_spec = Arg.String self#set_string - - (* hooks *) - val mutable hooks = [] - method add_hook f = hooks <- (f:'a->'a->unit) :: hooks - method private exec_hooks v' v = List.iter (fun f -> f v' v) hooks - - initializer match group with Some g -> g#add (self :> 'a cp) | None -> () -end - - -(* ******************************************************************************** *) -(* ****************************** predefined classes ****************************** *) -(* ******************************************************************************** *) - -let int_wrappers = { - to_raw = (fun v -> Raw.Int v); - of_raw = function - | Raw.Int v -> v - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Int expected, got %a\n%!" Raw.to_channel r))} -class int_cp ?group name ?short_name default help = object (self) - inherit [int] cp_custom_type int_wrappers ?group name ?short_name default help - method get_spec = Arg.Int self#set -end - -let float_wrappers = { - to_raw = (fun v -> Raw.Float v); - of_raw = function - | Raw.Float v -> v - | Raw.Int v -> float v - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Float expected, got %a\n%!" Raw.to_channel r)) -} -class float_cp ?group name ?short_name default help = object (self) - inherit [float] cp_custom_type float_wrappers ?group name ?short_name default help - method get_spec = Arg.Float self#set -end - -(* The Pervasives version is too restrictive *) -let bool_of_string s = - match String.lowercase s with - | "false" | "no" | "n" | "0" -> false (* "0" and "1" aren't used. *) - | "true" | "yes" | "y" | "1" -> true - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Bool expected, got %s\n%!" r)) -let bool_wrappers = { - to_raw = (fun v -> Raw.String (string_of_bool v)); - of_raw = function - | Raw.String v -> bool_of_string v - | Raw.Int v -> v <> 0 - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Bool expected, got %a\n%!" Raw.to_channel r)) -} -class bool_cp ?group name ?short_name default help = object (self) - inherit [bool] cp_custom_type bool_wrappers ?group name ?short_name default help - method get_spec = Arg.Bool self#set -end - -let string_wrappers = { - to_raw = (fun v -> Raw.String v); - of_raw = function - | Raw.String v -> v - | Raw.Int v -> string_of_int v - | Raw.Float v -> string_of_float v - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.String expected, got %a\n%!" Raw.to_channel r)) -} -class string_cp ?group name ?short_name default help = object (self) - inherit [string] cp_custom_type string_wrappers ?group name ?short_name default help - method private of_string s = s - method get_spec = Arg.String self#set -end - -let list_wrappers wrappers = { - to_raw = (fun l -> Raw.List (List.map wrappers.to_raw l)); - of_raw = function - | Raw.List l -> List.map wrappers.of_raw l - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.List expected, got %a\n%!" Raw.to_channel r)) -} -class ['a] list_cp wrappers = ['a list] cp_custom_type (list_wrappers wrappers) - -let option_wrappers wrappers = { - to_raw = (function - | Some v -> wrappers.to_raw v - | None -> Raw.String ""); - of_raw = function - | Raw.String s as v -> ( - if s = "" || s = "None" then None - else if String.length s >= 5 && String.sub s 0 5 = "Some " - then Some (wrappers.of_raw (Raw.String (String.sub s 5 (String.length s -5)))) - else Some (wrappers.of_raw v)) - | r -> Some (wrappers.of_raw r)} -class ['a] option_cp wrappers = ['a option] cp_custom_type (option_wrappers wrappers) - -let enumeration_wrappers enum = - let switched = List.map (fun (string,cons) -> cons,string) enum in - {to_raw = (fun v -> Raw.String (List.assq v switched)); - of_raw = function - | Raw.String s -> - (try List.assoc s enum - with Not_found -> failwith (Printf.sprintf "%s isn't a known constructor" s)) - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw enumeration expected, got %a\n%!" Raw.to_channel r)) -} -class ['a] enumeration_cp enum ?group name ?short_name default help = object (self) - inherit ['a] cp_custom_type (enumeration_wrappers enum) - ?group name ?short_name default help - method get_spec = Arg.Symbol (List.map fst enum, (fun s -> self#set (List.assoc s enum))) -end - -let tuple2_wrappers wrapa wrapb = { - to_raw = (fun (a,b) -> Raw.Tuple [wrapa.to_raw a; wrapb.to_raw b]); - of_raw = function - | Raw.Tuple [a;b] -> wrapa.of_raw a, wrapb.of_raw b - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Tuple 2 expected, got %a\n%!" Raw.to_channel r)) -} -class ['a, 'b] tuple2_cp wrapa wrapb = ['a*'b] cp_custom_type (tuple2_wrappers wrapa wrapb) - -let tuple3_wrappers wrapa wrapb wrapc = { - to_raw = (fun (a,b,c) -> Raw.Tuple[wrapa.to_raw a; wrapb.to_raw b; wrapc.to_raw c]); - of_raw = function - | Raw.Tuple [a;b;c] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Tuple 3 expected, got %a\n%!" Raw.to_channel r)) -} -class ['a,'b,'c] tuple3_cp wrapa wrapb wrapc = - ['a*'b*'c] cp_custom_type (tuple3_wrappers wrapa wrapb wrapc) - -let tuple4_wrappers wrapa wrapb wrapc wrapd = { - to_raw=(fun (a,b,c,d)->Raw.Tuple[wrapa.to_raw a;wrapb.to_raw b;wrapc.to_raw c;wrapd.to_raw d]); - of_raw = function - | Raw.Tuple [a;b;c;d] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c, wrapd.of_raw d - | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan - "Raw.Tuple 4 expected, got %a\n%!" Raw.to_channel r)) -} -class ['a,'b,'c,'d] tuple4_cp wrapa wrapb wrapc wrapd = - ['a*'b*'c*'d] cp_custom_type (tuple4_wrappers wrapa wrapb wrapc wrapd) - -class string2_cp = [string,string] tuple2_cp string_wrappers string_wrappers -(* class color_cp = string_cp *) -class font_cp = string_cp -class filename_cp = string_cp - - -(* ******************************************************************************** *) -(******************** Backward compatibility with module Flags.****************** *) -(* ******************************************************************************** *) - -type 'a option_class = 'a wrappers -type 'a option_record = 'a cp -type options_file = {mutable filename:string; group:group} - -let create_options_file filename = {filename = filename; group = new group} -let set_options_file options_file filename = options_file.filename <- filename -let load {filename=f; group = g} = g#read f -let append {group=g} filename = g#read filename -let save {filename=f; group = g} = g#write ~with_help:false f -let save_with_help {filename=f; group = g} = g#write ~with_help:true f -let define_option {group=group} name help option_class default = - (new cp_custom_type option_class ~group name default help) -let option_hook cp f = cp#add_hook (fun _ _ -> f ()) - -let string_option = string_wrappers -let color_option = string_wrappers -let font_option = string_wrappers -let int_option = int_wrappers -let bool_option = bool_wrappers -let float_option = float_wrappers -let string2_option = tuple2_wrappers string_wrappers string_wrappers - -let option_option = option_wrappers -let list_option = list_wrappers -let sum_option = enumeration_wrappers -let tuple2_option (a,b) = tuple2_wrappers a b -let tuple3_option (a,b,c) = tuple3_wrappers a b c -let tuple4_option (a,b,c,d) = tuple4_wrappers a b c d - -let ( !! ) cp = cp#get -let ( =:= ) cp value = cp#set value - -let shortname cp = String.concat ":" cp#get_name -let get_help cp = cp#get_help - -type option_value = - Module of option_module -| StringValue of string -| IntValue of int -| FloatValue of float -| List of option_value list -| SmallList of option_value list -and option_module = (string * option_value) list - -let rec value_to_raw = function - | Module a -> Raw.Section (List.map (fun (name,value) -> name, value_to_raw value) a) - | StringValue a -> Raw.String a - | IntValue a -> Raw.Int a - | FloatValue a -> Raw.Float a - | List a -> Raw.List (List.map value_to_raw a) - | SmallList a -> Raw.Tuple (List.map value_to_raw a) -let rec raw_to_value = function - | Raw.String a -> StringValue a - | Raw.Int a -> IntValue a - | Raw.Float a -> FloatValue a - | Raw.List a -> List (List.map raw_to_value a) - | Raw.Tuple a -> SmallList (List.map raw_to_value a) - | Raw.Section a -> Module (List.map (fun (name,value) -> name, raw_to_value value) a) - -let define_option_class _ of_option_value to_option_value = - {to_raw = (fun a -> a |> to_option_value |> value_to_raw); - of_raw = (fun a -> a |> raw_to_value |> of_option_value)} - -let to_value {to_raw = to_raw} a = a |> to_raw |> raw_to_value -let from_value {of_raw = of_raw} a = a |> value_to_raw |> of_raw - -let of_value_w wrappers a = a |> value_to_raw |> wrappers.of_raw -let to_value_w wrappers a = a |> wrappers.to_raw |> raw_to_value -(* fancy indentation when finishing this stub code, not good style :-) *) -let value_to_string : option_value -> string = of_value_w string_option -let string_to_value = to_value_w string_option -let value_to_int = of_value_w int_option -let int_to_value = to_value_w int_option -let value_to_bool = of_value_w bool_option -let bool_to_value = to_value_w bool_option -let value_to_float = of_value_w float_option -let float_to_value = to_value_w float_option -let value_to_string2 = of_value_w string2_option -let string2_to_value = to_value_w string2_option -let value_to_list of_value = - let wrapper = define_option_class "" of_value (fun _ -> failwith "value_to_list") in - of_value_w (list_option wrapper) -let list_to_value to_value = - let wrapper = define_option_class "" (fun _ -> failwith "value_to_list") to_value in - to_value_w (list_option wrapper) diff --git a/ide/utils/config_file.mli b/ide/utils/config_file.mli deleted file mode 100644 index 22328e7f1..000000000 --- a/ide/utils/config_file.mli +++ /dev/null @@ -1,352 +0,0 @@ -(*********************************************************************************) -(* Cameleon *) -(* *) -(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. *) -(* *) -(* This program is free software; you can redistribute it and/or modify *) -(* it under the terms of the GNU Library General Public License as *) -(* published by the Free Software Foundation; either version 2 of the *) -(* License, or any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU Library General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU Library General Public *) -(* License along with this program; if not, write to the Free Software *) -(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) -(* 02111-1307 USA *) -(* *) -(* Contact: Maxence.Guesdon@inria.fr *) -(* *) -(*********************************************************************************) - -(** - This module implements a mechanism to handle configuration files. - A configuration file is defined as a set of [variable = value] lines, - where value can be - a simple string (types int, string, bool...), - a list of values between brackets (lists) or parentheses (tuples), - or a set of [variable = value] lines between braces. - The configuration file is automatically loaded and saved, - and configuration parameters are manipulated inside the program as easily as references. - - Object implementation by Jean-Baptiste Rouquier. -*) - -(** {1:lowlevelinterface Low level interface} *) -(** Skip this section on a first reading... *) - -(** The type of cp freshly parsed from configuration file, -not yet wrapped in their proper type. *) -module Raw : sig - type cp = - | String of string (** base types, reproducing the tokens of Genlex *) - | Int of int - | Float of float - | List of cp list (** compound types *) - | Tuple of cp list - | Section of (string * cp) list - - (** A parser. *) - val of_string : string -> cp - - (** Used to print the values into a log file for instance. *) - val to_channel : out_channel -> cp -> unit -end - -(** A type used to specialize polymorphics classes and define new classes. - {!Config_file.predefinedwrappers} are provided. - *) -type 'a wrappers = { to_raw : 'a -> Raw.cp; of_raw : Raw.cp -> 'a; } - -(** An exception raised by {!Config_file.cp.set_raw} - when the argument doesn't have a suitable {!Config_file.Raw.cp} type. - The function explains the problem and flush the output.*) -exception Wrong_type of (out_channel -> unit) - -(* (\** {2 Miscellaneous functions} *\) *) - -(* val bool_of_string : string -> bool *) - -(** {1 High level interface} *) -(** {2 The two main classes} *) - -(** A Configuration Parameter, in short cp, ie - a value we can store in and read from a configuration file. *) -class type ['a] cp = object - (** {1 Accessing methods} *) - - method get : 'a - method set : 'a -> unit - method get_default : 'a - method get_help : string - method get_name : string list - - (** Resets to the default value. *) - method reset : unit - - (** {1 Miscellaneous} *) - - (** All the hooks are executed each time the method set is called, - just after setting the new value.*) - method add_hook : ('a -> 'a -> unit) -> unit - - (** Used to generate command line arguments in {!Config_file.group.command_line_args} *) - method set_short_name : string -> unit - - (** [None] if no optional short_name was provided during object creation - and [set_short_name] was never called.*) - method get_short_name : string option - - (** {1 Methods for internal use} *) - - method get_formatted : Format.formatter -> unit - method get_default_formatted : Format.formatter -> unit - method get_help_formatted : Format.formatter -> unit - - method get_spec : Arg.spec - method set_raw : Raw.cp -> unit -end - -(** Unification over all possible ['a cp]: - contains the main methods of ['a cp] except the methods using the type ['a]. - A [group] manipulates only [groupable_cp] for homogeneity. *) -type groupable_cp = < - get_name : string list; - get_short_name : string option; - get_help : string; - - get_formatted : Format.formatter -> unit; - get_default_formatted : Format.formatter -> unit; - get_help_formatted : Format.formatter -> unit; - get_spec : Arg.spec; - - reset : unit; - set_raw : Raw.cp -> unit; > - -(** Raised in case a name is already used. - See {!Config_file.group.add} *) -exception Double_name - -(** An exception possibly raised if we want to check that - every cp is defined in a configuration file. - See {!Config_file.group.read}. -*) -exception Missing_cp of groupable_cp - -(** A group of cps, that can be loaded and saved, -or used to generate command line arguments. - -The basic usage is to have only one group and one configuration file, -but this mechanism allows having more, -for instance having another smaller group for the options to pass on the command line. -*) -class group : object - (** Adds a cp to the group. - Note that the type ['a] must be lost - to allow cps of different types to belong to the same group. - @raise Double_name if [cp#get_name] is already used. *) -(* method add : 'a cp -> 'a cp *) - method add : 'a cp -> unit - - (**[write filename] saves all the cps into the configuration file [filename].*) - method write : ?with_help:bool -> string -> unit - - (** [read filename] reads [filename] - and stores the values it specifies into the cps belonging to this group. - The file is created (and not read) if it doesn't exists. - In the default behaviour, no warning is issued - if not all cps are updated or if some values of [filename] aren't used. - - If [obsoletes] is specified, - then prints in this file all the values that are - in [filename] but not in this group. - Those cps are likely to be erroneous or obsolete. - Opens this file only if there is something to write in it. - - If [no_default] is [true], then raises [Missing_cp foo] if - the cp [foo] isn't defined in [filename] but belongs to this group. - - [on_type_error groupable_cp value output filename in_channel] - is called if the file doesn't give suitable value - (string instead of int for instance, or a string not belonging to the expected enumeration) - for the cp [groupable_cp]. - [value] is the value read from the file, - [output] is the argument of {!Config_file.Wrong_type}, - [filename] is the same argument as the one given to read, - and [in_channel] refers to [filename] to allow a function to close it if needed. - Default behaviour is to print an error message and call [exit 1]. -*) - method read : ?obsoletes:string -> ?no_default:bool -> - ?on_type_error : (groupable_cp -> Raw.cp -> (out_channel -> unit) -> - string -> in_channel -> unit) -> - string -> unit - - (** Interface with module Arg. - @param section_separator the string used to concatenate the name of a cp, - to get the command line option name. - ["-"] is a good default. - @return a list that can be used with [Arg.parse] and [Arg.usage].*) - method command_line_args : section_separator:string -> (string * Arg.spec * string) list - end - -(** {2 Predefined cp classes} *) - -(** The last three non-optional arguments are always - [name] (of type string list), [default_value] and [help] (of type string). - - [name] is the path to the cp: [["section";"subsection"; ...; "foo"]]. - It can consists of a single element but must not be empty. - - [short_name] will be added a "-" and used in - {!Config_file.group.command_line_args}. - - [group], if provided, adds the freshly defined option to it - (something like [initializer group#add self]). - - [help] needs not contain newlines, it will be automatically truncated where needed. - It is mandatory but can be [""]. -*) - -class int_cp : ?group:group -> string list -> ?short_name:string -> int -> string -> [int] cp -class float_cp : ?group:group -> string list -> ?short_name:string -> float -> string -> [float] cp -class bool_cp : ?group:group -> string list -> ?short_name:string -> bool -> string -> [bool] cp -class string_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> [string] cp -class ['a] list_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a list -> string -> ['a list] cp -class ['a] option_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a option -> string -> ['a option] cp -class ['a] enumeration_cp : (string * 'a) list -> ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp -class ['a, 'b] tuple2_cp : 'a wrappers -> 'b wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b -> string -> ['a * 'b] cp -class ['a, 'b, 'c] tuple3_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c -> string -> ['a * 'b * 'c] cp -class ['a, 'b, 'c, 'd] tuple4_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c * 'd -> string -> ['a * 'b * 'c * 'd] cp -class string2_cp : ?group:group -> string list -> ?short_name:string -> string * string -> string -> [string, string] tuple2_cp -(* class color_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp *) -class font_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp -class filename_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp - -(** {2:predefinedwrappers Predefined wrappers} *) - -val int_wrappers : int wrappers -val float_wrappers : float wrappers -val bool_wrappers : bool wrappers -val string_wrappers : string wrappers -val list_wrappers : 'a wrappers -> 'a list wrappers -val option_wrappers : 'a wrappers -> 'a option wrappers - -(** If you have a [type suit = Spades | Hearts | Diamond | Clubs], then -{[enumeration_wrappers ["spades",Spades; "hearts",Hearts; "diamond",Diamond; "clubs",Clubs]]} -will allow you to use cp of this type. -For sum types with not only constant constructors, -you will need to define your own cp class. *) -val enumeration_wrappers : (string * 'a) list -> 'a wrappers -val tuple2_wrappers : 'a wrappers -> 'b wrappers -> ('a * 'b) wrappers -val tuple3_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> ('a * 'b * 'c) wrappers -val tuple4_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ('a * 'b * 'c * 'd) wrappers - -(** {2 Defining new cp classes} *) - -(** To define a new cp class, you just have to provide an implementation for the wrappers -between your type [foo] and the type [Raw.cp]. -Once you have your wrappers [w], write -{[class foo_cp = [foo] cp_custom_type w]} - -For further details, have a look at the commented .ml file, -section "predefined cp classes". -*) -class ['a] cp_custom_type : 'a wrappers -> - ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp - - -(** {1 Backward compatibility} - -Deprecated. - -All the functions from the module Options are available, except: - -- [prune_file]: use [group#write ?obsoletes:"foo.ml"]. -- [smalllist_to_value], [smalllist_option]: use lists or tuples. -- [get_class]. -- [class_hook]: hooks are local to a cp. - If you want hooks global to a class, - define a new class that inherit from {!Config_file.cp_custom_type}. -- [set_simple_option], [get_simple_option], [simple_options], [simple_args]: - use {!Config_file.group.write}. -- [set_option_hook]: use {!Config_file.cp.add_hook}. -- [set_string_wrappers]: define a new class with {!Config_file.cp_custom_type}. - -The old configurations files are readable by this module. -*) - - - - - -(**/**) -type 'a option_class -type 'a option_record -type options_file - -val create_options_file : string -> options_file -val set_options_file : options_file -> string -> unit -val load : options_file -> unit -val append : options_file -> string -> unit -val save : options_file -> unit -val save_with_help : options_file -> unit -(* val define_option : options_file -> *) -(* string list -> string -> 'a option_class -> 'a -> 'a option_record *) -val option_hook : 'a option_record -> (unit -> unit) -> unit - -val string_option : string option_class -val color_option : string option_class -val font_option : string option_class -val int_option : int option_class -val bool_option : bool option_class -val float_option : float option_class -val string2_option : (string * string) option_class - -val option_option : 'a option_class -> 'a option option_class -val list_option : 'a option_class -> 'a list option_class -val sum_option : (string * 'a) list -> 'a option_class -val tuple2_option : - 'a option_class * 'b option_class -> ('a * 'b) option_class -val tuple3_option : 'a option_class * 'b option_class * 'c option_class -> - ('a * 'b * 'c) option_class -val tuple4_option : - 'a option_class * 'b option_class * 'c option_class * 'd option_class -> - ('a * 'b * 'c * 'd) option_class - -val ( !! ) : 'a option_record -> 'a -val ( =:= ) : 'a option_record -> 'a -> unit -val shortname : 'a option_record -> string -val get_help : 'a option_record -> string - -type option_value = - Module of option_module -| StringValue of string -| IntValue of int -| FloatValue of float -| List of option_value list -| SmallList of option_value list -and option_module = (string * option_value) list - -val define_option_class : - string -> (option_value -> 'a) -> ('a -> option_value) -> 'a option_class - -val to_value : 'a option_class -> 'a -> option_value -val from_value : 'a option_class -> option_value -> 'a - -val value_to_string : option_value -> string -val string_to_value : string -> option_value -val value_to_int : option_value -> int -val int_to_value : int -> option_value -val bool_of_string : string -> bool -val value_to_bool : option_value -> bool -val bool_to_value : bool -> option_value -val value_to_float : option_value -> float -val float_to_value : float -> option_value -val value_to_string2 : option_value -> string * string -val string2_to_value : string * string -> option_value -val value_to_list : (option_value -> 'a) -> option_value -> 'a list -val list_to_value : ('a -> option_value) -> 'a list -> option_value diff --git a/ide/utils/configwin.ml b/ide/utils/configwin.ml index 4606ef29f..69e8b647a 100644 --- a/ide/utils/configwin.ml +++ b/ide/utils/configwin.ml @@ -36,44 +36,16 @@ type return_button = | Return_ok | Return_cancel -let string_to_key = Configwin_types.string_to_key -let key_to_string = Configwin_types.key_to_string -let key_cp_wrapper = Configwin_types.key_cp_wrapper -class key_cp = Configwin_types.key_cp - - let string = Configwin_ihm.string -let text = Configwin_ihm.text let strings = Configwin_ihm.strings let list = Configwin_ihm.list let bool = Configwin_ihm.bool -let filename = Configwin_ihm.filename -let filenames = Configwin_ihm.filenames -let color = Configwin_ihm.color -let font = Configwin_ihm.font let combo = Configwin_ihm.combo let custom = Configwin_ihm.custom -let date = Configwin_ihm.date -let hotkey = Configwin_ihm.hotkey let modifiers = Configwin_ihm.modifiers -let html = Configwin_ihm.html let edit ?(apply=(fun () -> ())) title ?width ?height conf_struct_list = Configwin_ihm.edit ~with_apply: true ~apply title ?width ?height conf_struct_list - -let get = Configwin_ihm.edit ~with_apply: false ~apply: (fun () -> ()) - -let simple_edit - ?(apply=(fun () -> ())) - title ?width ?height - param_list = Configwin_ihm.simple_edit ~with_apply: true ~apply title ?width ?height param_list - -let simple_get = Configwin_ihm.simple_edit - ~with_apply: false ~apply: (fun () -> ()) - -let box = Configwin_ihm.box - -let tabbed_box = Configwin_ihm.tabbed_box diff --git a/ide/utils/configwin.mli b/ide/utils/configwin.mli index c5fbf39a0..7616e471d 100644 --- a/ide/utils/configwin.mli +++ b/ide/utils/configwin.mli @@ -50,22 +50,6 @@ type return_button = button or the window manager but never clicked on the apply button.*) - -(** {2 The key option class (to use with the {!Config_file} library)} *) - -val string_to_key : string -> Gdk.Tags.modifier list * int - -val key_to_string : Gdk.Tags.modifier list * int -> string - -val key_cp_wrapper : (Gdk.Tags.modifier list * int) Config_file.wrappers - -class key_cp : - ?group:Config_file.group -> - string list -> - ?short_name:string -> - Gdk.Tags.modifier list * int -> - string -> [Gdk.Tags.modifier list * int] Config_file.cp_custom_type - (** {2 Functions to create parameters} *) (** [string label value] creates a string parameter. @@ -136,24 +120,6 @@ val list : ?editable: bool -> ?help: string -> 'a list -> parameter_kind -(** [color label value] creates a color parameter. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the entry widget must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). -*) -val color : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** [font label value] creates a font parameter. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the entry widget must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). -*) -val font : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - (** [combo label choices value] creates a combo parameter. @param editable indicate if the value is editable (default is [true]). @param expand indicate if the entry widget must expand or not (default is [true]). @@ -169,69 +135,6 @@ val combo : ?editable: bool -> ?expand: bool -> ?help: string -> ?new_allowed: bool -> ?blank_allowed: bool -> string -> string list -> string -> parameter_kind -(** [text label value] creates a text parameter. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the box for the text must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). -*) -val text : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** Same as {!Configwin.text} but html bindings are available - in the text widget. Use the [configwin_html_config] utility - to edit your bindings. -*) -val html : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** [filename label value] creates a filename parameter. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the entry widget must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). -*) -val filename : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: (string -> unit) -> string -> string -> parameter_kind - -(** [filenames label value] creates a filename list parameter. - @param editable indicate if the value is editable (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). - @param eq the comparison function, used not to have doubles in list. Default - is [Pervasives.(=)]. If you want to allow doubles in the list, give a function - always returning false. -*) -val filenames : ?editable: bool -> ?help: string -> - ?f: (string list -> unit) -> - ?eq: (string -> string -> bool) -> - string -> string list -> parameter_kind - -(** [date label value] creates a date parameter. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the entry widget must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). - @param f_string the function used to display the date as a string. The parameter - is a tupe [(day,month,year)], where [month] is between [0] and [11]. The default - function creates the string [year/month/day]. -*) -val date : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: ((int * int * int) -> unit) -> - ?f_string: ((int * int * int -> string)) -> - string -> (int * int * int) -> parameter_kind - -(** [hotkey label value] creates a hot key parameter. - A hot key is defined by a list of modifiers and a key code. - @param editable indicate if the value is editable (default is [true]). - @param expand indicate if the entry widget must expand or not (default is [true]). - @param help an optional help message. - @param f the function called to apply the value (default function does nothing). -*) -val hotkey : ?editable: bool -> ?expand: bool -> ?help: string -> - ?f: ((Gdk.Tags.modifier list * int) -> unit) -> - string -> (Gdk.Tags.modifier list * int) -> parameter_kind - val modifiers : ?editable: bool -> ?expand: bool -> ?help: string -> ?allow:(Gdk.Tags.modifier list) -> ?f: (Gdk.Tags.modifier list -> unit) -> @@ -259,46 +162,3 @@ val edit : ?height:int -> configuration_structure list -> return_button - -(** This function takes a configuration structure and creates a window used - to get the various parameters from the user. It is the same window as edit but - there is no apply button.*) -val get : - string -> - ?width:int -> - ?height:int -> - configuration_structure list -> - return_button - -(** This function takes a list of parameter specifications and - creates a window to configure the various parameters. - @param apply this function is called when the apply button is clicked, after - giving new values to parameters.*) -val simple_edit : - ?apply: (unit -> unit) -> - string -> - ?width:int -> - ?height:int -> - parameter_kind list -> return_button - -(** This function takes a list of parameter specifications and - creates a window to configure the various parameters, - without Apply button.*) -val simple_get : - string -> - ?width:int -> - ?height:int -> - parameter_kind list -> return_button - -(** Create a [GPack.box] with the list of given parameters, - Return the box and the function to call to apply new values to parameters. -*) -val box : parameter_kind list -> GData.tooltips -> GPack.box * (unit -> unit) - -(** Create a [GPack.box] with the list of given configuration structure list, - and the given list of buttons (defined by their label and callback). - Before calling the callback of a button, the [apply] function - of each parameter is called. -*) -val tabbed_box : configuration_structure list -> - (string * (unit -> unit)) list -> GData.tooltips -> GPack.box diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml index c1062a9db..70133fb9f 100644 --- a/ide/utils/configwin_ihm.ml +++ b/ide/utils/configwin_ihm.ml @@ -27,7 +27,25 @@ open Configwin_types -module O = Config_file +let modifiers_to_string m = + let rec iter m s = + match m with + [] -> s + | c :: m -> + iter m (( + match c with + `CONTROL -> "<ctrl>" + | `SHIFT -> "<shft>" + | `LOCK -> "<lock>" + | `MOD1 -> "<alt>" + | `MOD2 -> "<mod2>" + | `MOD3 -> "<mod3>" + | `MOD4 -> "<mod4>" + | `MOD5 -> "<mod5>" + | _ -> raise Not_found + ) ^ s) + in + iter m "" class type widget = object @@ -35,112 +53,9 @@ class type widget = method apply : unit -> unit end -let file_html_config = Filename.concat Configwin_messages.home ".configwin_html" - let debug = false let dbg s = if debug then Minilib.log s else () -(** Return the config group for the html config file, - and the option for bindings. *) -let html_config_file_and_option () = - let ini = new O.group in - let bindings = new O.list_cp - Configwin_types.htmlbinding_cp_wrapper - ~group: ini - ["bindings"] - ~short_name: "bd" - [ { html_key = Configwin_types.string_to_key "A-b" ; - html_begin = "<b>"; - html_end = "</b>" ; - } ; - { html_key = Configwin_types.string_to_key "A-i" ; - html_begin = "<i>"; - html_end = "</i>" ; - } - ] - "" - in - ini#read file_html_config ; - (ini, bindings) - -(** This variable contains the last directory where the user selected a file.*) -let last_dir = ref "";; - -(** This function allows the user to select a file and returns the - selected file name. An optional function allows changing the - behaviour of the ok button. - A VOIR : mutli-selection ? *) -let select_files ?dir - ?(fok : (string -> unit) option) - the_title = - let files = ref ([] : string list) in - let fs = GWindow.file_selection ~modal:true - ~title: the_title () in - (* we set the previous directory, if no directory is given *) - ( - match dir with - None -> - if !last_dir <> "" then - let _ = fs#set_filename !last_dir in - () - else - () - | Some dir -> - let _ = fs#set_filename !last_dir in - () - ); - - let _ = fs # connect#destroy ~callback: GMain.Main.quit in - let _ = fs # ok_button # connect#clicked ~callback: - (match fok with - None -> - (fun () -> files := [fs#filename] ; fs#destroy ()) - | Some f -> - (fun () -> f fs#filename) - ) - in - let _ = fs # cancel_button # connect#clicked ~callback:fs#destroy in - fs # show (); - GMain.Main.main (); - match !files with - | [] -> - [] - | [""] -> - [] - | l -> - (* we keep the directory in last_dir *) - last_dir := Filename.dirname (List.hd l); - l -;; - -(** Make the user select a date. *) -let select_date title (day,mon,year) = - let v_opt = ref None in - let window = GWindow.dialog ~modal:true ~title () in - let hbox = GPack.hbox ~border_width:10 ~packing:window#vbox#add () in - let cal = GMisc.calendar ~packing: (hbox#pack ~expand: true) () in - cal#select_month ~month: mon ~year: year ; - cal#select_day day; - let bbox = window#action_area in - - let bok = GButton.button ~label: Configwin_messages.mOk - ~packing:(bbox#pack ~expand:true ~padding:4) () - in - let bcancel = GButton.button ~label: Configwin_messages.mCancel - ~packing:(bbox#pack ~expand:true ~padding:4) () - in - ignore (bok#connect#clicked ~callback: - (fun () -> v_opt := Some (cal#date); window#destroy ())); - ignore(bcancel#connect#clicked ~callback: window#destroy); - - bok#grab_default (); - ignore(window#connect#destroy ~callback: GMain.Main.quit); - window#set_position `CENTER; - window#show (); - GMain.Main.main (); - !v_opt - - (** This class builds a frame with a clist and two buttons : one to add items and one to remove the selected items. The class takes in parameter a function used to add items and @@ -460,164 +375,6 @@ class custom_param_box param (tt:GData.tooltips) = method apply = param.custom_f_apply () end -(** This class is used to build a box for a color parameter.*) -class color_param_box param (tt:GData.tooltips) = - let _ = dbg "color_param_box" in - let v = ref param.color_value in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.color_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let w_test = GMisc.arrow - ~kind: `RIGHT - ~shadow: `OUT - ~width: 20 - ~height: 20 - ~packing: (hbox#pack ~expand: false ~padding: 2 ) - () - in - let we = GEdit.entry - ~editable: param.color_editable - ~packing: (hbox#pack ~expand: param.color_expand ~padding: 2) - () - in - let _ = - match param.color_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - let set_color s = - let style = w_test#misc#style#copy in - ( - try style#set_fg [ (`NORMAL, `NAME s) ; ] - with _ -> () - ); - w_test#misc#set_style style; - in - let _ = set_color !v in - let _ = we#set_text !v in - let f_sel () = - let dialog = GWindow.color_selection_dialog - ~title: param.color_label - ~modal: true - ~show: true - () - in - let wb_ok = dialog#ok_button in - let wb_cancel = dialog#cancel_button in - let _ = dialog#connect#destroy ~callback:GMain.Main.quit in - let _ = wb_ok#connect#clicked - ~callback:(fun () -> -(* let color = dialog#colorsel#color in - let r = (Gdk.Color.red color) in - let g = (Gdk.Color.green color)in - let b = (Gdk.Color.blue color) in - let s = Printf.sprintf "#%4X%4X%4X" r g b in - let _ = - for i = 1 to (String.length s) - 1 do - if s.[i] = ' ' then s.[i] <- '0' - done - in - we#set_text s ; *) - dialog#destroy () - ) - in - let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in - GMain.Main.main () - in - let _ = - if param.color_editable then ignore (wb#connect#clicked ~callback:f_sel) - in - - object (self) - (** This method returns the main box ready to be packed. *) - method box = hbox#coerce - (** This method applies the new value of the parameter. *) - method apply = - let new_value = we#text in - if new_value <> param.color_value then - let _ = param.color_f_apply new_value in - param.color_value <- new_value - else - () - - initializer - ignore (we#connect#changed ~callback:(fun () -> set_color we#text)); - - end ;; - -(** This class is used to build a box for a font parameter.*) -class font_param_box param (tt:GData.tooltips) = - let _ = dbg "font_param_box" in - let v = ref param.font_value in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.font_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.font_expand ~padding: 2) - () - in - let _ = - match param.font_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - let set_entry_font font_opt = - match font_opt with - None -> () - | Some s -> - let style = we#misc#style#copy in - ( - try - let font = Gdk.Font.load_fontset s in - style#set_font font - with _ -> () - ); - we#misc#set_style style - in - let _ = set_entry_font (Some !v) in - let _ = we#set_text !v in - let f_sel () = - let dialog = GWindow.font_selection_dialog - ~title: param.font_label - ~modal: true - ~show: true - () - in - dialog#selection#set_font_name !v; - let wb_ok = dialog#ok_button in - let wb_cancel = dialog#cancel_button in - let _ = dialog#connect#destroy ~callback:GMain.Main.quit in - let _ = wb_ok#connect#clicked - ~callback:(fun () -> - let font = dialog#selection#font_name in - we#set_text font ; - set_entry_font (Some font); - dialog#destroy () - ) - in - let _ = wb_cancel#connect#clicked ~callback:dialog#destroy in - GMain.Main.main () - in - let _ = if param.font_editable then ignore (wb#connect#clicked ~callback:f_sel) in - - object (self) - (** This method returns the main box ready to be packed. *) - method box = hbox#coerce - (** This method applies the new value of the parameter. *) - method apply = - let new_value = we#text in - if new_value <> param.font_value then - let _ = param.font_f_apply new_value in - param.font_value <- new_value - else - () - end ;; - (** This class is used to build a box for a text parameter.*) class text_param_box param (tt:GData.tooltips) = let _ = dbg "text_param_box" in @@ -662,35 +419,6 @@ class text_param_box param (tt:GData.tooltips) = () end ;; -(** This class is used to build a box a html parameter. *) -class html_param_box param (tt:GData.tooltips) = - let _ = dbg "html_param_box" in - object (self) - inherit text_param_box param tt - - method private exec html_start html_end () = - let (i1,i2) = wview#buffer#selection_bounds in - let s = i1#get_text ~stop: i2 in - match s with - "" -> - wview#buffer#insert (html_start^html_end) - | _ -> - ignore (wview#buffer#insert ~iter: i2 html_end); - ignore (wview#buffer#insert ~iter: i1 html_start); - wview#buffer#place_cursor ~where: i2 - - initializer - dbg "html_param_box:initializer"; - let (_,html_bindings) = html_config_file_and_option () in - dbg "html_param_box:connecting key press events"; - let add_shortcut hb = - let (mods, k) = hb.html_key in - Okey.add wview ~mods k (self#exec hb.html_begin hb.html_end) - in - List.iter add_shortcut html_bindings#get; - dbg "html_param_box:end" - end - (** This class is used to build a box for a boolean parameter.*) class bool_param_box param (tt:GData.tooltips) = let _ = dbg "bool_param_box" in @@ -719,105 +447,6 @@ class bool_param_box param (tt:GData.tooltips) = () end ;; -(** This class is used to build a box for a file name parameter.*) -class filename_param_box param (tt:GData.tooltips) = - let _ = dbg "filename_param_box" in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.string_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let we = GEdit.entry - ~editable: param.string_editable - ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2) - () - in - let _ = - match param.string_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - let _ = we#set_text (param.string_to_string param.string_value) in - - let f_click () = - match select_files param.string_label with - [] -> - () - | f :: _ -> - we#set_text f - in - let _ = - if param.string_editable then - let _ = wb#connect#clicked ~callback:f_click in - () - else - () - in - - object (self) - (** This method returns the main box ready to be packed. *) - method box = hbox#coerce - (** This method applies the new value of the parameter. *) - method apply = - let new_value = param.string_of_string we#text in - if new_value <> param.string_value then - let _ = param.string_f_apply new_value in - param.string_value <- new_value - else - () - end ;; - -(** This class is used to build a box for a hot key parameter.*) -class hotkey_param_box param (tt:GData.tooltips) = - let _ = dbg "hotkey_param_box" in - let hbox = GPack.hbox () in - let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in - let _wl = GMisc.label ~text: param.hk_label ~packing: wev#add () in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.hk_expand ~padding: 2) - () - in - let value = ref param.hk_value in - let _ = - match param.hk_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in - let _ = we#set_text (Configwin_types.key_to_string param.hk_value) in - let mods_we_dont_care = [`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] in - let capture ev = - let key = GdkEvent.Key.keyval ev in - let modifiers = GdkEvent.Key.state ev in - let mods = List.filter - (fun m -> not (List.mem m mods_we_dont_care)) - modifiers - in - value := (mods, key); - we#set_text (Glib.Convert.locale_to_utf8 (Configwin_types.key_to_string !value)); - false - in - let _ = - if param.hk_editable then - ignore (we#event#connect#key_press ~callback:capture) - else - () - in - - object (self) - (** This method returns the main box ready to be packed. *) - method box = hbox#coerce - (** This method applies the new value of the parameter. *) - method apply = - let new_value = !value in - if new_value <> param.hk_value then - let _ = param.hk_f_apply new_value in - param.hk_value <- new_value - else - () - end ;; - class modifiers_param_box param = let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand:true ~fill:true ~padding: 2) () in @@ -825,7 +454,7 @@ class modifiers_param_box param = let value = ref param.md_value in let _ = List.map (fun modifier -> let but = GButton.toggle_button - ~label:(Configwin_types.modifiers_to_string [modifier]) + ~label:(modifiers_to_string [modifier]) ~active:(List.mem modifier param.md_value) ~packing:(hbox#pack ~expand:false) () in ignore (but#connect#toggled @@ -854,55 +483,6 @@ class modifiers_param_box param = () end ;; -(** This class is used to build a box for a date parameter.*) -class date_param_box param (tt:GData.tooltips) = - let _ = dbg "date_param_box" in - let v = ref param.date_value in - let hbox = GPack.hbox () in - let wb = GButton.button ~label: param.date_label - ~packing: (hbox#pack ~expand: false ~padding: 2) () - in - let we = GEdit.entry - ~editable: false - ~packing: (hbox#pack ~expand: param.date_expand ~padding: 2) - () - in - - let _ = - match param.date_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wb#coerce - in - - let _ = we#set_text (param.date_f_string param.date_value) in - let f_click () = - match select_date param.date_label !v with - None -> () - | Some (y,m,d) -> - v := (d,m,y) ; - we#set_text (param.date_f_string (d,m,y)) - in - let _ = - if param.date_editable then - let _ = wb#connect#clicked ~callback:f_click in - () - else - () - in - - object (self) - (** This method returns the main box ready to be packed. *) - method box = hbox#coerce - (** This method applies the new value of the parameter. *) - method apply = - if !v <> param.date_value then - let _ = param.date_f_apply !v in - param.date_value <- !v - else - () - end ;; - (** This class is used to build a box for a parameter whose values are a list.*) class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = let _ = dbg "list_param_box" in @@ -975,10 +555,6 @@ class configuration_box (tt : GData.tooltips) conf_struct = let box = new bool_param_box p tt in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box - | Filename_param p -> - let box = new filename_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box | List_param f -> let box = f tt in let _ = main_box#pack ~expand: true ~padding: 2 box#box in @@ -987,30 +563,10 @@ class configuration_box (tt : GData.tooltips) conf_struct = let box = new custom_param_box p tt in let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in box - | Color_param p -> - let box = new color_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Font_param p -> - let box = new font_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Date_param p -> - let box = new date_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Hotkey_param p -> - let box = new hotkey_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box | Modifiers_param p -> let box = new modifiers_param_box p in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box - | Html_param p -> - let box = new html_param_box p tt in - let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in - box in let set_icon iter = function @@ -1102,36 +658,6 @@ class configuration_box (tt : GData.tooltips) conf_struct = end -(** Create a vbox with the list of given configuration structure list, - and the given list of buttons (defined by their label and callback). - Before calling the callback of a button, the [apply] function - of each parameter is called. -*) -let tabbed_box conf_struct_list buttons tooltips = - let param_box = - new configuration_box tooltips conf_struct_list - in - let f_apply () = param_box#apply - in - let hbox_buttons = GPack.hbox ~packing: (param_box#box#pack ~expand: false ~padding: 4) () in - let rec iter_buttons ?(grab=false) = function - [] -> - () - | (label, callb) :: q -> - let b = GButton.button ~label: label - ~packing:(hbox_buttons#pack ~expand:true ~fill: true ~padding:4) () - in - ignore (b#connect#clicked ~callback: - (fun () -> f_apply (); callb ())); - (* If it's the first button then give it the focus *) - if grab then b#grab_default (); - - iter_buttons q - in - iter_buttons ~grab: true buttons; - - param_box#box - (** This function takes a configuration structure list and creates a window to configure the various parameters. *) let edit ?(with_apply=true) @@ -1174,110 +700,6 @@ let edit ?(with_apply=true) in iter Return_cancel -(** Create a vbox with the list of given parameters. *) -let box param_list tt = - let main_box = GPack.vbox () in - let f parameter = - match parameter with - String_param p -> - let box = new string_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Combo_param p -> - let box = new combo_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Text_param p -> - let box = new text_param_box p tt in - let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in - box - | Bool_param p -> - let box = new bool_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Filename_param p -> - let box = new filename_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | List_param f -> - let box = f tt in - let _ = main_box#pack ~expand: true ~padding: 2 box#box in - box - | Custom_param p -> - let box = new custom_param_box p tt in - let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in - box - | Color_param p -> - let box = new color_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Font_param p -> - let box = new font_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Date_param p -> - let box = new date_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Hotkey_param p -> - let box = new hotkey_param_box p tt in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Modifiers_param p -> - let box = new modifiers_param_box p in - let _ = main_box#pack ~expand: false ~padding: 2 box#box in - box - | Html_param p -> - let box = new html_param_box p tt in - let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in - box - in - let list_param_box = List.map f param_list in - let f_apply () = - List.iter (fun param_box -> param_box#apply) list_param_box - in - (main_box, f_apply) - -(** This function takes a list of parameter specifications and - creates a window to configure the various parameters.*) -let simple_edit ?(with_apply=true) - ?(apply=(fun () -> ())) - title ?width ?height - param_list = - let dialog = GWindow.dialog - ~modal: true ~title: title - ?height ?width - () - in - let tooltips = GData.tooltips () in - if with_apply then - dialog#add_button Configwin_messages.mApply `APPLY; - - dialog#add_button Configwin_messages.mOk `OK; - dialog#add_button Configwin_messages.mCancel `CANCEL; - - let (box, f_apply) = box param_list tooltips in - dialog#vbox#pack ~expand: true ~fill: true box#coerce; - - let destroy () = - tooltips#destroy () ; - dialog#destroy (); - in - let rec iter rep = - try - match dialog#run () with - | `APPLY -> f_apply (); apply (); iter Return_apply - | `OK -> f_apply () ; destroy () ; Return_ok - | _ -> destroy (); rep - with - Failure s -> - GToolbox.message_box ~title:"Error" s; iter rep - | e -> - GToolbox.message_box ~title:"Error" (Printexc.to_string e); iter rep - in - iter Return_cancel - - let edit_string l s = match GToolbox.input_string ~title: l ~text: s Configwin_messages.mValue with None -> s @@ -1342,30 +764,6 @@ let strings ?(editable=true) ?help ?(add=(fun () -> [])) label v = list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v -(** Create a color param. *) -let color ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Color_param - { - color_label = label ; - color_help = help ; - color_value = v ; - color_editable = editable ; - color_f_apply = f ; - color_expand = expand ; - } - -(** Create a font param. *) -let font ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Font_param - { - font_label = label ; - font_help = help ; - font_value = v ; - font_editable = editable ; - font_f_apply = f ; - font_expand = expand ; - } - (** Create a combo param. *) let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ?(new_allowed=false) @@ -1383,82 +781,6 @@ let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) combo_expand = expand ; } -(** Create a text param. *) -let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Text_param - { - string_label = label ; - string_help = help ; - string_value = v ; - string_editable = editable ; - string_f_apply = f ; - string_expand = expand ; - string_to_string = (fun x -> x) ; - string_of_string = (fun x -> x) ; - } - -(** Create a html param. *) -let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Html_param - { - string_label = label ; - string_help = help ; - string_value = v ; - string_editable = editable ; - string_f_apply = f ; - string_expand = expand ; - string_to_string = (fun x -> x) ; - string_of_string = (fun x -> x) ; - } - -(** Create a filename param. *) -let filename ?(editable=true) ?(expand=true)?help ?(f=(fun _ -> ())) label v = - Filename_param - { - string_label = label ; - string_help = help ; - string_value = v ; - string_editable = editable ; - string_f_apply = f ; - string_expand = expand ; - string_to_string = (fun x -> x) ; - string_of_string = (fun x -> x) ; - } - -(** Create a filenames param.*) -let filenames ?(editable=true) ?help ?(f=(fun _ -> ())) - ?(eq=Pervasives.(=)) - label v = - let add () = select_files label in - list ~editable ?help ~f ~eq ~add label (fun s -> [Glib.Convert.locale_to_utf8 s]) v - -(** Create a date param. *) -let date ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) - ?(f_string=(fun(d,m,y)-> Printf.sprintf "%d/%d/%d" y (m+1) d)) - label v = - Date_param - { - date_label = label ; - date_help = help ; - date_value = v ; - date_editable = editable ; - date_f_string = f_string ; - date_f_apply = f ; - date_expand = expand ; - } - -(** Create a hot key param. *) -let hotkey ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = - Hotkey_param - { - hk_label = label ; - hk_help = help ; - hk_value = v ; - hk_editable = editable ; - hk_f_apply = f ; - hk_expand = expand ; - } - let modifiers ?(editable=true) ?(expand=true) diff --git a/ide/utils/configwin_ihm.mli b/ide/utils/configwin_ihm.mli new file mode 100644 index 000000000..c867ad912 --- /dev/null +++ b/ide/utils/configwin_ihm.mli @@ -0,0 +1,66 @@ +(*********************************************************************************) +(* Cameleon *) +(* *) +(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. *) +(* *) +(* This program is free software; you can redistribute it and/or modify *) +(* it under the terms of the GNU Library General Public License as *) +(* published by the Free Software Foundation; either version 2 of the *) +(* License, or any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU Library General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU Library General Public *) +(* License along with this program; if not, write to the Free Software *) +(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) +(* 02111-1307 USA *) +(* *) +(* Contact: Maxence.Guesdon@inria.fr *) +(* *) +(*********************************************************************************) + +open Configwin_types + +val string : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: (string -> unit) -> string -> string -> parameter_kind +val bool : ?editable: bool -> ?help: string -> + ?f: (bool -> unit) -> string -> bool -> parameter_kind +val strings : ?editable: bool -> ?help: string -> + ?f: (string list -> unit) -> + ?eq: (string -> string -> bool) -> + ?add: (unit -> string list) -> + string -> string list -> parameter_kind +val list : ?editable: bool -> ?help: string -> + ?f: ('a list -> unit) -> + ?eq: ('a -> 'a -> bool) -> + ?edit: ('a -> 'a) -> + ?add: (unit -> 'a list) -> + ?titles: string list -> + ?color: ('a -> string option) -> + string -> + ('a -> string list) -> + 'a list -> + parameter_kind +val combo : ?editable: bool -> ?expand: bool -> ?help: string -> + ?f: (string -> unit) -> + ?new_allowed: bool -> ?blank_allowed: bool -> + string -> string list -> string -> parameter_kind + +val modifiers : ?editable: bool -> ?expand: bool -> ?help: string -> + ?allow:(Gdk.Tags.modifier list) -> + ?f: (Gdk.Tags.modifier list -> unit) -> + string -> Gdk.Tags.modifier list -> parameter_kind +val custom : ?label: string -> GPack.box -> (unit -> unit) -> bool -> parameter_kind + +val edit : + ?with_apply:bool -> + ?apply:(unit -> unit) -> + string -> + ?width:int -> + ?height:int -> + configuration_structure list -> + return_button diff --git a/ide/utils/configwin_keys.ml b/ide/utils/configwin_keys.ml deleted file mode 100644 index e9b19da62..000000000 --- a/ide/utils/configwin_keys.ml +++ /dev/null @@ -1,4176 +0,0 @@ -(*********************************************************************************) -(* Cameleon *) -(* *) -(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. *) -(* *) -(* This program is free software; you can redistribute it and/or modify *) -(* it under the terms of the GNU Library General Public License as *) -(* published by the Free Software Foundation; either version 2 of the *) -(* License, or any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU Library General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU Library General Public *) -(* License along with this program; if not, write to the Free Software *) -(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) -(* 02111-1307 USA *) -(* *) -(* Contact: Maxence.Guesdon@inria.fr *) -(* *) -(*********************************************************************************) - -(** Key codes - - Ce fichier provient de X11/keysymdef.h - les noms des symboles deviennent : XK_ -> xk_ - - Thanks to Fabrice Le Fessant. -*) - -let xk_VoidSymbol = 0xFFFFFF (** void symbol *) - - -(** TTY Functions, cleverly chosen to map to ascii, for convenience of - programming, but could have been arbitrary (at the cost of lookup - tables in client code. -*) - -let xk_BackSpace = 0xFF08 (** back space, back char *) -let xk_Tab = 0xFF09 -let xk_Linefeed = 0xFF0A (** Linefeed, LF *) -let xk_Clear = 0xFF0B -let xk_Return = 0xFF0D (** Return, enter *) -let xk_Pause = 0xFF13 (** Pause, hold *) -let xk_Scroll_Lock = 0xFF14 -let xk_Sys_Req = 0xFF15 -let xk_Escape = 0xFF1B -let xk_Delete = 0xFFFF (** Delete, rubout *) - - - -(** International & multi-key character composition *) - -let xk_Multi_key = 0xFF20 (** Multi-key character compose *) - -(** Japanese keyboard support *) - -let xk_Kanji = 0xFF21 (** Kanji, Kanji convert *) -let xk_Muhenkan = 0xFF22 (** Cancel Conversion *) -let xk_Henkan_Mode = 0xFF23 (** Start/Stop Conversion *) -let xk_Henkan = 0xFF23 (** Alias for Henkan_Mode *) -let xk_Romaji = 0xFF24 (** to Romaji *) -let xk_Hiragana = 0xFF25 (** to Hiragana *) -let xk_Katakana = 0xFF26 (** to Katakana *) -let xk_Hiragana_Katakana = 0xFF27 (** Hiragana/Katakana toggle *) -let xk_Zenkaku = 0xFF28 (** to Zenkaku *) -let xk_Hankaku = 0xFF29 (** to Hankaku *) -let xk_Zenkaku_Hankaku = 0xFF2A (** Zenkaku/Hankaku toggle *) -let xk_Touroku = 0xFF2B (** Add to Dictionary *) -let xk_Massyo = 0xFF2C (** Delete from Dictionary *) -let xk_Kana_Lock = 0xFF2D (** Kana Lock *) -let xk_Kana_Shift = 0xFF2E (** Kana Shift *) -let xk_Eisu_Shift = 0xFF2F (** Alphanumeric Shift *) -let xk_Eisu_toggle = 0xFF30 (** Alphanumeric toggle *) - -(** = 0xFF31 thru = 0xFF3F are under xk_KOREAN *) - -(** Cursor control & motion *) - -let xk_Home = 0xFF50 -let xk_Left = 0xFF51 (** Move left, left arrow *) -let xk_Up = 0xFF52 (** Move up, up arrow *) -let xk_Right = 0xFF53 (** Move right, right arrow *) -let xk_Down = 0xFF54 (** Move down, down arrow *) -let xk_Prior = 0xFF55 (** Prior, previous *) -let xk_Page_Up = 0xFF55 -let xk_Next = 0xFF56 (** Next *) -let xk_Page_Down = 0xFF56 -let xk_End = 0xFF57 (** EOL *) -let xk_Begin = 0xFF58 (** BOL *) - - -(** Misc Functions *) - -let xk_Select = 0xFF60 (** Select, mark *) -let xk_Print = 0xFF61 -let xk_Execute = 0xFF62 (** Execute, run, do *) -let xk_Insert = 0xFF63 (** Insert, insert here *) -let xk_Undo = 0xFF65 (** Undo, oops *) -let xk_Redo = 0xFF66 (** redo, again *) -let xk_Menu = 0xFF67 -let xk_Find = 0xFF68 (** Find, search *) -let xk_Cancel = 0xFF69 (** Cancel, stop, abort, exit *) -let xk_Help = 0xFF6A (** Help *) -let xk_Break = 0xFF6B -let xk_Mode_switch = 0xFF7E (** Character set switch *) -let xk_script_switch = 0xFF7E (** Alias for mode_switch *) -let xk_Num_Lock = 0xFF7F - -(** Keypad Functions, keypad numbers cleverly chosen to map to ascii *) - -let xk_KP_Space = 0xFF80 (** space *) -let xk_KP_Tab = 0xFF89 -let xk_KP_Enter = 0xFF8D (** enter *) -let xk_KP_F1 = 0xFF91 (** PF1, KP_A, ... *) -let xk_KP_F2 = 0xFF92 -let xk_KP_F3 = 0xFF93 -let xk_KP_F4 = 0xFF94 -let xk_KP_Home = 0xFF95 -let xk_KP_Left = 0xFF96 -let xk_KP_Up = 0xFF97 -let xk_KP_Right = 0xFF98 -let xk_KP_Down = 0xFF99 -let xk_KP_Prior = 0xFF9A -let xk_KP_Page_Up = 0xFF9A -let xk_KP_Next = 0xFF9B -let xk_KP_Page_Down = 0xFF9B -let xk_KP_End = 0xFF9C -let xk_KP_Begin = 0xFF9D -let xk_KP_Insert = 0xFF9E -let xk_KP_Delete = 0xFF9F -let xk_KP_Equal = 0xFFBD (** equals *) -let xk_KP_Multiply = 0xFFAA -let xk_KP_Add = 0xFFAB -let xk_KP_Separator = 0xFFAC (** separator, often comma *) -let xk_KP_Subtract = 0xFFAD -let xk_KP_Decimal = 0xFFAE -let xk_KP_Divide = 0xFFAF - -let xk_KP_0 = 0xFFB0 -let xk_KP_1 = 0xFFB1 -let xk_KP_2 = 0xFFB2 -let xk_KP_3 = 0xFFB3 -let xk_KP_4 = 0xFFB4 -let xk_KP_5 = 0xFFB5 -let xk_KP_6 = 0xFFB6 -let xk_KP_7 = 0xFFB7 -let xk_KP_8 = 0xFFB8 -let xk_KP_9 = 0xFFB9 - - - -(* - * Auxiliary Functions; note the duplicate definitions for left and right - * function keys; Sun keyboards and a few other manufactures have such - * function key groups on the left and/or right sides of the keyboard. - * We've not found a keyboard with more than 35 function keys total. - *) - -let xk_F1 = 0xFFBE -let xk_F2 = 0xFFBF -let xk_F3 = 0xFFC0 -let xk_F4 = 0xFFC1 -let xk_F5 = 0xFFC2 -let xk_F6 = 0xFFC3 -let xk_F7 = 0xFFC4 -let xk_F8 = 0xFFC5 -let xk_F9 = 0xFFC6 -let xk_F10 = 0xFFC7 -let xk_F11 = 0xFFC8 -let xk_L1 = 0xFFC8 -let xk_F12 = 0xFFC9 -let xk_L2 = 0xFFC9 -let xk_F13 = 0xFFCA -let xk_L3 = 0xFFCA -let xk_F14 = 0xFFCB -let xk_L4 = 0xFFCB -let xk_F15 = 0xFFCC -let xk_L5 = 0xFFCC -let xk_F16 = 0xFFCD -let xk_L6 = 0xFFCD -let xk_F17 = 0xFFCE -let xk_L7 = 0xFFCE -let xk_F18 = 0xFFCF -let xk_L8 = 0xFFCF -let xk_F19 = 0xFFD0 -let xk_L9 = 0xFFD0 -let xk_F20 = 0xFFD1 -let xk_L10 = 0xFFD1 -let xk_F21 = 0xFFD2 -let xk_R1 = 0xFFD2 -let xk_F22 = 0xFFD3 -let xk_R2 = 0xFFD3 -let xk_F23 = 0xFFD4 -let xk_R3 = 0xFFD4 -let xk_F24 = 0xFFD5 -let xk_R4 = 0xFFD5 -let xk_F25 = 0xFFD6 -let xk_R5 = 0xFFD6 -let xk_F26 = 0xFFD7 -let xk_R6 = 0xFFD7 -let xk_F27 = 0xFFD8 -let xk_R7 = 0xFFD8 -let xk_F28 = 0xFFD9 -let xk_R8 = 0xFFD9 -let xk_F29 = 0xFFDA -let xk_R9 = 0xFFDA -let xk_F30 = 0xFFDB -let xk_R10 = 0xFFDB -let xk_F31 = 0xFFDC -let xk_R11 = 0xFFDC -let xk_F32 = 0xFFDD -let xk_R12 = 0xFFDD -let xk_F33 = 0xFFDE -let xk_R13 = 0xFFDE -let xk_F34 = 0xFFDF -let xk_R14 = 0xFFDF -let xk_F35 = 0xFFE0 -let xk_R15 = 0xFFE0 - -(** Modifiers *) - -let xk_Shift_L = 0xFFE1 (** Left shift *) -let xk_Shift_R = 0xFFE2 (** Right shift *) -let xk_Control_L = 0xFFE3 (** Left control *) -let xk_Control_R = 0xFFE4 (** Right control *) -let xk_Caps_Lock = 0xFFE5 (** Caps lock *) -let xk_Shift_Lock = 0xFFE6 (** Shift lock *) - -let xk_Meta_L = 0xFFE7 (** Left meta *) -let xk_Meta_R = 0xFFE8 (** Right meta *) -let xk_Alt_L = 0xFFE9 (** Left alt *) -let xk_Alt_R = 0xFFEA (** Right alt *) -let xk_Super_L = 0xFFEB (** Left super *) -let xk_Super_R = 0xFFEC (** Right super *) -let xk_Hyper_L = 0xFFED (** Left hyper *) -let xk_Hyper_R = 0xFFEE (** Right hyper *) - - -(* - * ISO 9995 Function and Modifier Keys - * Byte 3 = = 0xFE - *) - - -let xk_ISO_Lock = 0xFE01 -let xk_ISO_Level2_Latch = 0xFE02 -let xk_ISO_Level3_Shift = 0xFE03 -let xk_ISO_Level3_Latch = 0xFE04 -let xk_ISO_Level3_Lock = 0xFE05 -let xk_ISO_Group_Shift = 0xFF7E (** Alias for mode_switch *) -let xk_ISO_Group_Latch = 0xFE06 -let xk_ISO_Group_Lock = 0xFE07 -let xk_ISO_Next_Group = 0xFE08 -let xk_ISO_Next_Group_Lock = 0xFE09 -let xk_ISO_Prev_Group = 0xFE0A -let xk_ISO_Prev_Group_Lock = 0xFE0B -let xk_ISO_First_Group = 0xFE0C -let xk_ISO_First_Group_Lock = 0xFE0D -let xk_ISO_Last_Group = 0xFE0E -let xk_ISO_Last_Group_Lock = 0xFE0F - -let xk_ISO_Left_Tab = 0xFE20 -let xk_ISO_Move_Line_Up = 0xFE21 -let xk_ISO_Move_Line_Down = 0xFE22 -let xk_ISO_Partial_Line_Up = 0xFE23 -let xk_ISO_Partial_Line_Down = 0xFE24 -let xk_ISO_Partial_Space_Left = 0xFE25 -let xk_ISO_Partial_Space_Right = 0xFE26 -let xk_ISO_Set_Margin_Left = 0xFE27 -let xk_ISO_Set_Margin_Right = 0xFE28 -let xk_ISO_Release_Margin_Left = 0xFE29 -let xk_ISO_Release_Margin_Right = 0xFE2A -let xk_ISO_Release_Both_Margins = 0xFE2B -let xk_ISO_Fast_Cursor_Left = 0xFE2C -let xk_ISO_Fast_Cursor_Right = 0xFE2D -let xk_ISO_Fast_Cursor_Up = 0xFE2E -let xk_ISO_Fast_Cursor_Down = 0xFE2F -let xk_ISO_Continuous_Underline = 0xFE30 -let xk_ISO_Discontinuous_Underline = 0xFE31 -let xk_ISO_Emphasize = 0xFE32 -let xk_ISO_Center_Object = 0xFE33 -let xk_ISO_Enter = 0xFE34 - -let xk_dead_grave = 0xFE50 -let xk_dead_acute = 0xFE51 -let xk_dead_circumflex = 0xFE52 -let xk_dead_tilde = 0xFE53 -let xk_dead_macron = 0xFE54 -let xk_dead_breve = 0xFE55 -let xk_dead_abovedot = 0xFE56 -let xk_dead_diaeresis = 0xFE57 -let xk_dead_abovering = 0xFE58 -let xk_dead_doubleacute = 0xFE59 -let xk_dead_caron = 0xFE5A -let xk_dead_cedilla = 0xFE5B -let xk_dead_ogonek = 0xFE5C -let xk_dead_iota = 0xFE5D -let xk_dead_voiced_sound = 0xFE5E -let xk_dead_semivoiced_sound = 0xFE5F -let xk_dead_belowdot = 0xFE60 - -let xk_First_Virtual_Screen = 0xFED0 -let xk_Prev_Virtual_Screen = 0xFED1 -let xk_Next_Virtual_Screen = 0xFED2 -let xk_Last_Virtual_Screen = 0xFED4 -let xk_Terminate_Server = 0xFED5 - -let xk_AccessX_Enable = 0xFE70 -let xk_AccessX_Feedback_Enable = 0xFE71 -let xk_RepeatKeys_Enable = 0xFE72 -let xk_SlowKeys_Enable = 0xFE73 -let xk_BounceKeys_Enable = 0xFE74 -let xk_StickyKeys_Enable = 0xFE75 -let xk_MouseKeys_Enable = 0xFE76 -let xk_MouseKeys_Accel_Enable = 0xFE77 -let xk_Overlay1_Enable = 0xFE78 -let xk_Overlay2_Enable = 0xFE79 -let xk_AudibleBell_Enable = 0xFE7A - -let xk_Pointer_Left = 0xFEE0 -let xk_Pointer_Right = 0xFEE1 -let xk_Pointer_Up = 0xFEE2 -let xk_Pointer_Down = 0xFEE3 -let xk_Pointer_UpLeft = 0xFEE4 -let xk_Pointer_UpRight = 0xFEE5 -let xk_Pointer_DownLeft = 0xFEE6 -let xk_Pointer_DownRight = 0xFEE7 -let xk_Pointer_Button_Dflt = 0xFEE8 -let xk_Pointer_Button1 = 0xFEE9 -let xk_Pointer_Button2 = 0xFEEA -let xk_Pointer_Button3 = 0xFEEB -let xk_Pointer_Button4 = 0xFEEC -let xk_Pointer_Button5 = 0xFEED -let xk_Pointer_DblClick_Dflt = 0xFEEE -let xk_Pointer_DblClick1 = 0xFEEF -let xk_Pointer_DblClick2 = 0xFEF0 -let xk_Pointer_DblClick3 = 0xFEF1 -let xk_Pointer_DblClick4 = 0xFEF2 -let xk_Pointer_DblClick5 = 0xFEF3 -let xk_Pointer_Drag_Dflt = 0xFEF4 -let xk_Pointer_Drag1 = 0xFEF5 -let xk_Pointer_Drag2 = 0xFEF6 -let xk_Pointer_Drag3 = 0xFEF7 -let xk_Pointer_Drag4 = 0xFEF8 -let xk_Pointer_Drag5 = 0xFEFD - -let xk_Pointer_EnableKeys = 0xFEF9 -let xk_Pointer_Accelerate = 0xFEFA -let xk_Pointer_DfltBtnNext = 0xFEFB -let xk_Pointer_DfltBtnPrev = 0xFEFC - - - -(* - * 3270 Terminal Keys - * Byte 3 = = 0xFD - *) - - -let xk_3270_Duplicate = 0xFD01 -let xk_3270_FieldMark = 0xFD02 -let xk_3270_Right2 = 0xFD03 -let xk_3270_Left2 = 0xFD04 -let xk_3270_BackTab = 0xFD05 -let xk_3270_EraseEOF = 0xFD06 -let xk_3270_EraseInput = 0xFD07 -let xk_3270_Reset = 0xFD08 -let xk_3270_Quit = 0xFD09 -let xk_3270_PA1 = 0xFD0A -let xk_3270_PA2 = 0xFD0B -let xk_3270_PA3 = 0xFD0C -let xk_3270_Test = 0xFD0D -let xk_3270_Attn = 0xFD0E -let xk_3270_CursorBlink = 0xFD0F -let xk_3270_AltCursor = 0xFD10 -let xk_3270_KeyClick = 0xFD11 -let xk_3270_Jump = 0xFD12 -let xk_3270_Ident = 0xFD13 -let xk_3270_Rule = 0xFD14 -let xk_3270_Copy = 0xFD15 -let xk_3270_Play = 0xFD16 -let xk_3270_Setup = 0xFD17 -let xk_3270_Record = 0xFD18 -let xk_3270_ChangeScreen = 0xFD19 -let xk_3270_DeleteWord = 0xFD1A -let xk_3270_ExSelect = 0xFD1B -let xk_3270_CursorSelect = 0xFD1C -let xk_3270_PrintScreen = 0xFD1D -let xk_3270_Enter = 0xFD1E - - -(* - * Latin 1 - * Byte 3 = 0 - *) - -let xk_space = 0x020 -let xk_exclam = 0x021 -let xk_quotedbl = 0x022 -let xk_numbersign = 0x023 -let xk_dollar = 0x024 -let xk_percent = 0x025 -let xk_ampersand = 0x026 -let xk_apostrophe = 0x027 -let xk_quoteright = 0x027 (** deprecated *) -let xk_parenleft = 0x028 -let xk_parenright = 0x029 -let xk_asterisk = 0x02a -let xk_plus = 0x02b -let xk_comma = 0x02c -let xk_minus = 0x02d -let xk_period = 0x02e -let xk_slash = 0x02f -let xk_0 = 0x030 -let xk_1 = 0x031 -let xk_2 = 0x032 -let xk_3 = 0x033 -let xk_4 = 0x034 -let xk_5 = 0x035 -let xk_6 = 0x036 -let xk_7 = 0x037 -let xk_8 = 0x038 -let xk_9 = 0x039 -let xk_colon = 0x03a -let xk_semicolon = 0x03b -let xk_less = 0x03c -let xk_equal = 0x03d -let xk_greater = 0x03e -let xk_question = 0x03f -let xk_at = 0x040 -let xk_A = 0x041 -let xk_B = 0x042 -let xk_C = 0x043 -let xk_D = 0x044 -let xk_E = 0x045 -let xk_F = 0x046 -let xk_G = 0x047 -let xk_H = 0x048 -let xk_I = 0x049 -let xk_J = 0x04a -let xk_K = 0x04b -let xk_L = 0x04c -let xk_M = 0x04d -let xk_N = 0x04e -let xk_O = 0x04f -let xk_P = 0x050 -let xk_Q = 0x051 -let xk_R = 0x052 -let xk_S = 0x053 -let xk_T = 0x054 -let xk_U = 0x055 -let xk_V = 0x056 -let xk_W = 0x057 -let xk_X = 0x058 -let xk_Y = 0x059 -let xk_Z = 0x05a -let xk_bracketleft = 0x05b -let xk_backslash = 0x05c -let xk_bracketright = 0x05d -let xk_asciicircum = 0x05e -let xk_underscore = 0x05f -let xk_grave = 0x060 -let xk_quoteleft = 0x060 (** deprecated *) -let xk_a = 0x061 -let xk_b = 0x062 -let xk_c = 0x063 -let xk_d = 0x064 -let xk_e = 0x065 -let xk_f = 0x066 -let xk_g = 0x067 -let xk_h = 0x068 -let xk_i = 0x069 -let xk_j = 0x06a -let xk_k = 0x06b -let xk_l = 0x06c -let xk_m = 0x06d -let xk_n = 0x06e -let xk_o = 0x06f -let xk_p = 0x070 -let xk_q = 0x071 -let xk_r = 0x072 -let xk_s = 0x073 -let xk_t = 0x074 -let xk_u = 0x075 -let xk_v = 0x076 -let xk_w = 0x077 -let xk_x = 0x078 -let xk_y = 0x079 -let xk_z = 0x07a -let xk_braceleft = 0x07b -let xk_bar = 0x07c -let xk_braceright = 0x07d -let xk_asciitilde = 0x07e - -let xk_nobreakspace = 0x0a0 -let xk_exclamdown = 0x0a1 -let xk_cent = 0x0a2 -let xk_sterling = 0x0a3 -let xk_currency = 0x0a4 -let xk_yen = 0x0a5 -let xk_brokenbar = 0x0a6 -let xk_section = 0x0a7 -let xk_diaeresis = 0x0a8 -let xk_copyright = 0x0a9 -let xk_ordfeminine = 0x0aa -let xk_guillemotleft = 0x0ab (** left angle quotation mark *) -let xk_notsign = 0x0ac -let xk_hyphen = 0x0ad -let xk_registered = 0x0ae -let xk_macron = 0x0af -let xk_degree = 0x0b0 -let xk_plusminus = 0x0b1 -let xk_twosuperior = 0x0b2 -let xk_threesuperior = 0x0b3 -let xk_acute = 0x0b4 -let xk_mu = 0x0b5 -let xk_paragraph = 0x0b6 -let xk_periodcentered = 0x0b7 -let xk_cedilla = 0x0b8 -let xk_onesuperior = 0x0b9 -let xk_masculine = 0x0ba -let xk_guillemotright = 0x0bb (** right angle quotation mark *) -let xk_onequarter = 0x0bc -let xk_onehalf = 0x0bd -let xk_threequarters = 0x0be -let xk_questiondown = 0x0bf -let xk_Agrave = 0x0c0 -let xk_Aacute = 0x0c1 -let xk_Acircumflex = 0x0c2 -let xk_Atilde = 0x0c3 -let xk_Adiaeresis = 0x0c4 -let xk_Aring = 0x0c5 -let xk_AE = 0x0c6 -let xk_Ccedilla = 0x0c7 -let xk_Egrave = 0x0c8 -let xk_Eacute = 0x0c9 -let xk_Ecircumflex = 0x0ca -let xk_Ediaeresis = 0x0cb -let xk_Igrave = 0x0cc -let xk_Iacute = 0x0cd -let xk_Icircumflex = 0x0ce -let xk_Idiaeresis = 0x0cf -let xk_ETH = 0x0d0 -let xk_Eth = 0x0d0 (** deprecated *) -let xk_Ntilde = 0x0d1 -let xk_Ograve = 0x0d2 -let xk_Oacute = 0x0d3 -let xk_Ocircumflex = 0x0d4 -let xk_Otilde = 0x0d5 -let xk_Odiaeresis = 0x0d6 -let xk_multiply = 0x0d7 -let xk_Ooblique = 0x0d8 -let xk_Ugrave = 0x0d9 -let xk_Uacute = 0x0da -let xk_Ucircumflex = 0x0db -let xk_Udiaeresis = 0x0dc -let xk_Yacute = 0x0dd -let xk_THORN = 0x0de -let xk_Thorn = 0x0de (** deprecated *) -let xk_ssharp = 0x0df -let xk_agrave = 0x0e0 -let xk_aacute = 0x0e1 -let xk_acircumflex = 0x0e2 -let xk_atilde = 0x0e3 -let xk_adiaeresis = 0x0e4 -let xk_aring = 0x0e5 -let xk_ae = 0x0e6 -let xk_ccedilla = 0x0e7 -let xk_egrave = 0x0e8 -let xk_eacute = 0x0e9 -let xk_ecircumflex = 0x0ea -let xk_ediaeresis = 0x0eb -let xk_igrave = 0x0ec -let xk_iacute = 0x0ed -let xk_icircumflex = 0x0ee -let xk_idiaeresis = 0x0ef -let xk_eth = 0x0f0 -let xk_ntilde = 0x0f1 -let xk_ograve = 0x0f2 -let xk_oacute = 0x0f3 -let xk_ocircumflex = 0x0f4 -let xk_otilde = 0x0f5 -let xk_odiaeresis = 0x0f6 -let xk_division = 0x0f7 -let xk_oslash = 0x0f8 -let xk_ugrave = 0x0f9 -let xk_uacute = 0x0fa -let xk_ucircumflex = 0x0fb -let xk_udiaeresis = 0x0fc -let xk_yacute = 0x0fd -let xk_thorn = 0x0fe -let xk_ydiaeresis = 0x0ff - - -(* - * Latin 2 - * Byte 3 = 1 - *) - - -let xk_Aogonek = 0x1a1 -let xk_breve = 0x1a2 -let xk_Lstroke = 0x1a3 -let xk_Lcaron = 0x1a5 -let xk_Sacute = 0x1a6 -let xk_Scaron = 0x1a9 -let xk_Scedilla = 0x1aa -let xk_Tcaron = 0x1ab -let xk_Zacute = 0x1ac -let xk_Zcaron = 0x1ae -let xk_Zabovedot = 0x1af -let xk_aogonek = 0x1b1 -let xk_ogonek = 0x1b2 -let xk_lstroke = 0x1b3 -let xk_lcaron = 0x1b5 -let xk_sacute = 0x1b6 -let xk_caron = 0x1b7 -let xk_scaron = 0x1b9 -let xk_scedilla = 0x1ba -let xk_tcaron = 0x1bb -let xk_zacute = 0x1bc -let xk_doubleacute = 0x1bd -let xk_zcaron = 0x1be -let xk_zabovedot = 0x1bf -let xk_Racute = 0x1c0 -let xk_Abreve = 0x1c3 -let xk_Lacute = 0x1c5 -let xk_Cacute = 0x1c6 -let xk_Ccaron = 0x1c8 -let xk_Eogonek = 0x1ca -let xk_Ecaron = 0x1cc -let xk_Dcaron = 0x1cf -let xk_Dstroke = 0x1d0 -let xk_Nacute = 0x1d1 -let xk_Ncaron = 0x1d2 -let xk_Odoubleacute = 0x1d5 -let xk_Rcaron = 0x1d8 -let xk_Uring = 0x1d9 -let xk_Udoubleacute = 0x1db -let xk_Tcedilla = 0x1de -let xk_racute = 0x1e0 -let xk_abreve = 0x1e3 -let xk_lacute = 0x1e5 -let xk_cacute = 0x1e6 -let xk_ccaron = 0x1e8 -let xk_eogonek = 0x1ea -let xk_ecaron = 0x1ec -let xk_dcaron = 0x1ef -let xk_dstroke = 0x1f0 -let xk_nacute = 0x1f1 -let xk_ncaron = 0x1f2 -let xk_odoubleacute = 0x1f5 -let xk_udoubleacute = 0x1fb -let xk_rcaron = 0x1f8 -let xk_uring = 0x1f9 -let xk_tcedilla = 0x1fe -let xk_abovedot = 0x1ff - - -(* - * Latin 3 - * Byte 3 = 2 - *) - - -let xk_Hstroke = 0x2a1 -let xk_Hcircumflex = 0x2a6 -let xk_Iabovedot = 0x2a9 -let xk_Gbreve = 0x2ab -let xk_Jcircumflex = 0x2ac -let xk_hstroke = 0x2b1 -let xk_hcircumflex = 0x2b6 -let xk_idotless = 0x2b9 -let xk_gbreve = 0x2bb -let xk_jcircumflex = 0x2bc -let xk_Cabovedot = 0x2c5 -let xk_Ccircumflex = 0x2c6 -let xk_Gabovedot = 0x2d5 -let xk_Gcircumflex = 0x2d8 -let xk_Ubreve = 0x2dd -let xk_Scircumflex = 0x2de -let xk_cabovedot = 0x2e5 -let xk_ccircumflex = 0x2e6 -let xk_gabovedot = 0x2f5 -let xk_gcircumflex = 0x2f8 -let xk_ubreve = 0x2fd -let xk_scircumflex = 0x2fe - - - -(* - * Latin 4 - * Byte 3 = 3 - *) - - -let xk_kra = 0x3a2 -let xk_kappa = 0x3a2 (** deprecated *) -let xk_Rcedilla = 0x3a3 -let xk_Itilde = 0x3a5 -let xk_Lcedilla = 0x3a6 -let xk_Emacron = 0x3aa -let xk_Gcedilla = 0x3ab -let xk_Tslash = 0x3ac -let xk_rcedilla = 0x3b3 -let xk_itilde = 0x3b5 -let xk_lcedilla = 0x3b6 -let xk_emacron = 0x3ba -let xk_gcedilla = 0x3bb -let xk_tslash = 0x3bc -let xk_ENG = 0x3bd -let xk_eng = 0x3bf -let xk_Amacron = 0x3c0 -let xk_Iogonek = 0x3c7 -let xk_Eabovedot = 0x3cc -let xk_Imacron = 0x3cf -let xk_Ncedilla = 0x3d1 -let xk_Omacron = 0x3d2 -let xk_Kcedilla = 0x3d3 -let xk_Uogonek = 0x3d9 -let xk_Utilde = 0x3dd -let xk_Umacron = 0x3de -let xk_amacron = 0x3e0 -let xk_iogonek = 0x3e7 -let xk_eabovedot = 0x3ec -let xk_imacron = 0x3ef -let xk_ncedilla = 0x3f1 -let xk_omacron = 0x3f2 -let xk_kcedilla = 0x3f3 -let xk_uogonek = 0x3f9 -let xk_utilde = 0x3fd -let xk_umacron = 0x3fe - - -(* - * Katakana - * Byte 3 = 4 - *) - - -let xk_overline = 0x47e -let xk_kana_fullstop = 0x4a1 -let xk_kana_openingbracket = 0x4a2 -let xk_kana_closingbracket = 0x4a3 -let xk_kana_comma = 0x4a4 -let xk_kana_conjunctive = 0x4a5 -let xk_kana_middledot = 0x4a5 (** deprecated *) -let xk_kana_WO = 0x4a6 -let xk_kana_a = 0x4a7 -let xk_kana_i = 0x4a8 -let xk_kana_u = 0x4a9 -let xk_kana_e = 0x4aa -let xk_kana_o = 0x4ab -let xk_kana_ya = 0x4ac -let xk_kana_yu = 0x4ad -let xk_kana_yo = 0x4ae -let xk_kana_tsu = 0x4af -let xk_kana_tu = 0x4af (** deprecated *) -let xk_prolongedsound = 0x4b0 -let xk_kana_A = 0x4b1 -let xk_kana_I = 0x4b2 -let xk_kana_U = 0x4b3 -let xk_kana_E = 0x4b4 -let xk_kana_O = 0x4b5 -let xk_kana_KA = 0x4b6 -let xk_kana_KI = 0x4b7 -let xk_kana_KU = 0x4b8 -let xk_kana_KE = 0x4b9 -let xk_kana_KO = 0x4ba -let xk_kana_SA = 0x4bb -let xk_kana_SHI = 0x4bc -let xk_kana_SU = 0x4bd -let xk_kana_SE = 0x4be -let xk_kana_SO = 0x4bf -let xk_kana_TA = 0x4c0 -let xk_kana_CHI = 0x4c1 -let xk_kana_TI = 0x4c1 (** deprecated *) -let xk_kana_TSU = 0x4c2 -let xk_kana_TU = 0x4c2 (** deprecated *) -let xk_kana_TE = 0x4c3 -let xk_kana_TO = 0x4c4 -let xk_kana_NA = 0x4c5 -let xk_kana_NI = 0x4c6 -let xk_kana_NU = 0x4c7 -let xk_kana_NE = 0x4c8 -let xk_kana_NO = 0x4c9 -let xk_kana_HA = 0x4ca -let xk_kana_HI = 0x4cb -let xk_kana_FU = 0x4cc -let xk_kana_HU = 0x4cc (** deprecated *) -let xk_kana_HE = 0x4cd -let xk_kana_HO = 0x4ce -let xk_kana_MA = 0x4cf -let xk_kana_MI = 0x4d0 -let xk_kana_MU = 0x4d1 -let xk_kana_ME = 0x4d2 -let xk_kana_MO = 0x4d3 -let xk_kana_YA = 0x4d4 -let xk_kana_YU = 0x4d5 -let xk_kana_YO = 0x4d6 -let xk_kana_RA = 0x4d7 -let xk_kana_RI = 0x4d8 -let xk_kana_RU = 0x4d9 -let xk_kana_RE = 0x4da -let xk_kana_RO = 0x4db -let xk_kana_WA = 0x4dc -let xk_kana_N = 0x4dd -let xk_voicedsound = 0x4de -let xk_semivoicedsound = 0x4df -let xk_kana_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Arabic - * Byte 3 = 5 - *) - - -let xk_Arabic_comma = 0x5ac -let xk_Arabic_semicolon = 0x5bb -let xk_Arabic_question_mark = 0x5bf -let xk_Arabic_hamza = 0x5c1 -let xk_Arabic_maddaonalef = 0x5c2 -let xk_Arabic_hamzaonalef = 0x5c3 -let xk_Arabic_hamzaonwaw = 0x5c4 -let xk_Arabic_hamzaunderalef = 0x5c5 -let xk_Arabic_hamzaonyeh = 0x5c6 -let xk_Arabic_alef = 0x5c7 -let xk_Arabic_beh = 0x5c8 -let xk_Arabic_tehmarbuta = 0x5c9 -let xk_Arabic_teh = 0x5ca -let xk_Arabic_theh = 0x5cb -let xk_Arabic_jeem = 0x5cc -let xk_Arabic_hah = 0x5cd -let xk_Arabic_khah = 0x5ce -let xk_Arabic_dal = 0x5cf -let xk_Arabic_thal = 0x5d0 -let xk_Arabic_ra = 0x5d1 -let xk_Arabic_zain = 0x5d2 -let xk_Arabic_seen = 0x5d3 -let xk_Arabic_sheen = 0x5d4 -let xk_Arabic_sad = 0x5d5 -let xk_Arabic_dad = 0x5d6 -let xk_Arabic_tah = 0x5d7 -let xk_Arabic_zah = 0x5d8 -let xk_Arabic_ain = 0x5d9 -let xk_Arabic_ghain = 0x5da -let xk_Arabic_tatweel = 0x5e0 -let xk_Arabic_feh = 0x5e1 -let xk_Arabic_qaf = 0x5e2 -let xk_Arabic_kaf = 0x5e3 -let xk_Arabic_lam = 0x5e4 -let xk_Arabic_meem = 0x5e5 -let xk_Arabic_noon = 0x5e6 -let xk_Arabic_ha = 0x5e7 -let xk_Arabic_heh = 0x5e7 (** deprecated *) -let xk_Arabic_waw = 0x5e8 -let xk_Arabic_alefmaksura = 0x5e9 -let xk_Arabic_yeh = 0x5ea -let xk_Arabic_fathatan = 0x5eb -let xk_Arabic_dammatan = 0x5ec -let xk_Arabic_kasratan = 0x5ed -let xk_Arabic_fatha = 0x5ee -let xk_Arabic_damma = 0x5ef -let xk_Arabic_kasra = 0x5f0 -let xk_Arabic_shadda = 0x5f1 -let xk_Arabic_sukun = 0x5f2 -let xk_Arabic_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Cyrillic - * Byte 3 = 6 - *) - -let xk_Serbian_dje = 0x6a1 -let xk_Macedonia_gje = 0x6a2 -let xk_Cyrillic_io = 0x6a3 -let xk_Ukrainian_ie = 0x6a4 -let xk_Ukranian_je = 0x6a4 (** deprecated *) -let xk_Macedonia_dse = 0x6a5 -let xk_Ukrainian_i = 0x6a6 -let xk_Ukranian_i = 0x6a6 (** deprecated *) -let xk_Ukrainian_yi = 0x6a7 -let xk_Ukranian_yi = 0x6a7 (** deprecated *) -let xk_Cyrillic_je = 0x6a8 -let xk_Serbian_je = 0x6a8 (** deprecated *) -let xk_Cyrillic_lje = 0x6a9 -let xk_Serbian_lje = 0x6a9 (** deprecated *) -let xk_Cyrillic_nje = 0x6aa -let xk_Serbian_nje = 0x6aa (** deprecated *) -let xk_Serbian_tshe = 0x6ab -let xk_Macedonia_kje = 0x6ac -let xk_Byelorussian_shortu = 0x6ae -let xk_Cyrillic_dzhe = 0x6af -let xk_Serbian_dze = 0x6af (** deprecated *) -let xk_numerosign = 0x6b0 -let xk_Serbian_DJE = 0x6b1 -let xk_Macedonia_GJE = 0x6b2 -let xk_Cyrillic_IO = 0x6b3 -let xk_Ukrainian_IE = 0x6b4 -let xk_Ukranian_JE = 0x6b4 (** deprecated *) -let xk_Macedonia_DSE = 0x6b5 -let xk_Ukrainian_I = 0x6b6 -let xk_Ukranian_I = 0x6b6 (** deprecated *) -let xk_Ukrainian_YI = 0x6b7 -let xk_Ukranian_YI = 0x6b7 (** deprecated *) -let xk_Cyrillic_JE = 0x6b8 -let xk_Serbian_JE = 0x6b8 (** deprecated *) -let xk_Cyrillic_LJE = 0x6b9 -let xk_Serbian_LJE = 0x6b9 (** deprecated *) -let xk_Cyrillic_NJE = 0x6ba -let xk_Serbian_NJE = 0x6ba (** deprecated *) -let xk_Serbian_TSHE = 0x6bb -let xk_Macedonia_KJE = 0x6bc -let xk_Byelorussian_SHORTU = 0x6be -let xk_Cyrillic_DZHE = 0x6bf -let xk_Serbian_DZE = 0x6bf (** deprecated *) -let xk_Cyrillic_yu = 0x6c0 -let xk_Cyrillic_a = 0x6c1 -let xk_Cyrillic_be = 0x6c2 -let xk_Cyrillic_tse = 0x6c3 -let xk_Cyrillic_de = 0x6c4 -let xk_Cyrillic_ie = 0x6c5 -let xk_Cyrillic_ef = 0x6c6 -let xk_Cyrillic_ghe = 0x6c7 -let xk_Cyrillic_ha = 0x6c8 -let xk_Cyrillic_i = 0x6c9 -let xk_Cyrillic_shorti = 0x6ca -let xk_Cyrillic_ka = 0x6cb -let xk_Cyrillic_el = 0x6cc -let xk_Cyrillic_em = 0x6cd -let xk_Cyrillic_en = 0x6ce -let xk_Cyrillic_o = 0x6cf -let xk_Cyrillic_pe = 0x6d0 -let xk_Cyrillic_ya = 0x6d1 -let xk_Cyrillic_er = 0x6d2 -let xk_Cyrillic_es = 0x6d3 -let xk_Cyrillic_te = 0x6d4 -let xk_Cyrillic_u = 0x6d5 -let xk_Cyrillic_zhe = 0x6d6 -let xk_Cyrillic_ve = 0x6d7 -let xk_Cyrillic_softsign = 0x6d8 -let xk_Cyrillic_yeru = 0x6d9 -let xk_Cyrillic_ze = 0x6da -let xk_Cyrillic_sha = 0x6db -let xk_Cyrillic_e = 0x6dc -let xk_Cyrillic_shcha = 0x6dd -let xk_Cyrillic_che = 0x6de -let xk_Cyrillic_hardsign = 0x6df -let xk_Cyrillic_YU = 0x6e0 -let xk_Cyrillic_A = 0x6e1 -let xk_Cyrillic_BE = 0x6e2 -let xk_Cyrillic_TSE = 0x6e3 -let xk_Cyrillic_DE = 0x6e4 -let xk_Cyrillic_IE = 0x6e5 -let xk_Cyrillic_EF = 0x6e6 -let xk_Cyrillic_GHE = 0x6e7 -let xk_Cyrillic_HA = 0x6e8 -let xk_Cyrillic_I = 0x6e9 -let xk_Cyrillic_SHORTI = 0x6ea -let xk_Cyrillic_KA = 0x6eb -let xk_Cyrillic_EL = 0x6ec -let xk_Cyrillic_EM = 0x6ed -let xk_Cyrillic_EN = 0x6ee -let xk_Cyrillic_O = 0x6ef -let xk_Cyrillic_PE = 0x6f0 -let xk_Cyrillic_YA = 0x6f1 -let xk_Cyrillic_ER = 0x6f2 -let xk_Cyrillic_ES = 0x6f3 -let xk_Cyrillic_TE = 0x6f4 -let xk_Cyrillic_U = 0x6f5 -let xk_Cyrillic_ZHE = 0x6f6 -let xk_Cyrillic_VE = 0x6f7 -let xk_Cyrillic_SOFTSIGN = 0x6f8 -let xk_Cyrillic_YERU = 0x6f9 -let xk_Cyrillic_ZE = 0x6fa -let xk_Cyrillic_SHA = 0x6fb -let xk_Cyrillic_E = 0x6fc -let xk_Cyrillic_SHCHA = 0x6fd -let xk_Cyrillic_CHE = 0x6fe -let xk_Cyrillic_HARDSIGN = 0x6ff - - -(* - * Greek - * Byte 3 = 7 - *) - - -let xk_Greek_ALPHAaccent = 0x7a1 -let xk_Greek_EPSILONaccent = 0x7a2 -let xk_Greek_ETAaccent = 0x7a3 -let xk_Greek_IOTAaccent = 0x7a4 -let xk_Greek_IOTAdiaeresis = 0x7a5 -let xk_Greek_OMICRONaccent = 0x7a7 -let xk_Greek_UPSILONaccent = 0x7a8 -let xk_Greek_UPSILONdieresis = 0x7a9 -let xk_Greek_OMEGAaccent = 0x7ab -let xk_Greek_accentdieresis = 0x7ae -let xk_Greek_horizbar = 0x7af -let xk_Greek_alphaaccent = 0x7b1 -let xk_Greek_epsilonaccent = 0x7b2 -let xk_Greek_etaaccent = 0x7b3 -let xk_Greek_iotaaccent = 0x7b4 -let xk_Greek_iotadieresis = 0x7b5 -let xk_Greek_iotaaccentdieresis = 0x7b6 -let xk_Greek_omicronaccent = 0x7b7 -let xk_Greek_upsilonaccent = 0x7b8 -let xk_Greek_upsilondieresis = 0x7b9 -let xk_Greek_upsilonaccentdieresis = 0x7ba -let xk_Greek_omegaaccent = 0x7bb -let xk_Greek_ALPHA = 0x7c1 -let xk_Greek_BETA = 0x7c2 -let xk_Greek_GAMMA = 0x7c3 -let xk_Greek_DELTA = 0x7c4 -let xk_Greek_EPSILON = 0x7c5 -let xk_Greek_ZETA = 0x7c6 -let xk_Greek_ETA = 0x7c7 -let xk_Greek_THETA = 0x7c8 -let xk_Greek_IOTA = 0x7c9 -let xk_Greek_KAPPA = 0x7ca -let xk_Greek_LAMDA = 0x7cb -let xk_Greek_LAMBDA = 0x7cb -let xk_Greek_MU = 0x7cc -let xk_Greek_NU = 0x7cd -let xk_Greek_XI = 0x7ce -let xk_Greek_OMICRON = 0x7cf -let xk_Greek_PI = 0x7d0 -let xk_Greek_RHO = 0x7d1 -let xk_Greek_SIGMA = 0x7d2 -let xk_Greek_TAU = 0x7d4 -let xk_Greek_UPSILON = 0x7d5 -let xk_Greek_PHI = 0x7d6 -let xk_Greek_CHI = 0x7d7 -let xk_Greek_PSI = 0x7d8 -let xk_Greek_OMEGA = 0x7d9 -let xk_Greek_alpha = 0x7e1 -let xk_Greek_beta = 0x7e2 -let xk_Greek_gamma = 0x7e3 -let xk_Greek_delta = 0x7e4 -let xk_Greek_epsilon = 0x7e5 -let xk_Greek_zeta = 0x7e6 -let xk_Greek_eta = 0x7e7 -let xk_Greek_theta = 0x7e8 -let xk_Greek_iota = 0x7e9 -let xk_Greek_kappa = 0x7ea -let xk_Greek_lamda = 0x7eb -let xk_Greek_lambda = 0x7eb -let xk_Greek_mu = 0x7ec -let xk_Greek_nu = 0x7ed -let xk_Greek_xi = 0x7ee -let xk_Greek_omicron = 0x7ef -let xk_Greek_pi = 0x7f0 -let xk_Greek_rho = 0x7f1 -let xk_Greek_sigma = 0x7f2 -let xk_Greek_finalsmallsigma = 0x7f3 -let xk_Greek_tau = 0x7f4 -let xk_Greek_upsilon = 0x7f5 -let xk_Greek_phi = 0x7f6 -let xk_Greek_chi = 0x7f7 -let xk_Greek_psi = 0x7f8 -let xk_Greek_omega = 0x7f9 -let xk_Greek_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Technical - * Byte 3 = 8 - *) - - -let xk_leftradical = 0x8a1 -let xk_topleftradical = 0x8a2 -let xk_horizconnector = 0x8a3 -let xk_topintegral = 0x8a4 -let xk_botintegral = 0x8a5 -let xk_vertconnector = 0x8a6 -let xk_topleftsqbracket = 0x8a7 -let xk_botleftsqbracket = 0x8a8 -let xk_toprightsqbracket = 0x8a9 -let xk_botrightsqbracket = 0x8aa -let xk_topleftparens = 0x8ab -let xk_botleftparens = 0x8ac -let xk_toprightparens = 0x8ad -let xk_botrightparens = 0x8ae -let xk_leftmiddlecurlybrace = 0x8af -let xk_rightmiddlecurlybrace = 0x8b0 -let xk_topleftsummation = 0x8b1 -let xk_botleftsummation = 0x8b2 -let xk_topvertsummationconnector = 0x8b3 -let xk_botvertsummationconnector = 0x8b4 -let xk_toprightsummation = 0x8b5 -let xk_botrightsummation = 0x8b6 -let xk_rightmiddlesummation = 0x8b7 -let xk_lessthanequal = 0x8bc -let xk_notequal = 0x8bd -let xk_greaterthanequal = 0x8be -let xk_integral = 0x8bf -let xk_therefore = 0x8c0 -let xk_variation = 0x8c1 -let xk_infinity = 0x8c2 -let xk_nabla = 0x8c5 -let xk_approximate = 0x8c8 -let xk_similarequal = 0x8c9 -let xk_ifonlyif = 0x8cd -let xk_implies = 0x8ce -let xk_identical = 0x8cf -let xk_radical = 0x8d6 -let xk_includedin = 0x8da -let xk_includes = 0x8db -let xk_intersection = 0x8dc -let xk_union = 0x8dd -let xk_logicaland = 0x8de -let xk_logicalor = 0x8df -let xk_partialderivative = 0x8ef -let xk_function = 0x8f6 -let xk_leftarrow = 0x8fb -let xk_uparrow = 0x8fc -let xk_rightarrow = 0x8fd -let xk_downarrow = 0x8fe - - -(* - * Special - * Byte 3 = 9 - *) - - -let xk_blank = 0x9df -let xk_soliddiamond = 0x9e0 -let xk_checkerboard = 0x9e1 -let xk_ht = 0x9e2 -let xk_ff = 0x9e3 -let xk_cr = 0x9e4 -let xk_lf = 0x9e5 -let xk_nl = 0x9e8 -let xk_vt = 0x9e9 -let xk_lowrightcorner = 0x9ea -let xk_uprightcorner = 0x9eb -let xk_upleftcorner = 0x9ec -let xk_lowleftcorner = 0x9ed -let xk_crossinglines = 0x9ee -let xk_horizlinescan1 = 0x9ef -let xk_horizlinescan3 = 0x9f0 -let xk_horizlinescan5 = 0x9f1 -let xk_horizlinescan7 = 0x9f2 -let xk_horizlinescan9 = 0x9f3 -let xk_leftt = 0x9f4 -let xk_rightt = 0x9f5 -let xk_bott = 0x9f6 -let xk_topt = 0x9f7 -let xk_vertbar = 0x9f8 - - -(* - * Publishing - * Byte 3 = a - *) - - -let xk_emspace = 0xaa1 -let xk_enspace = 0xaa2 -let xk_em3space = 0xaa3 -let xk_em4space = 0xaa4 -let xk_digitspace = 0xaa5 -let xk_punctspace = 0xaa6 -let xk_thinspace = 0xaa7 -let xk_hairspace = 0xaa8 -let xk_emdash = 0xaa9 -let xk_endash = 0xaaa -let xk_signifblank = 0xaac -let xk_ellipsis = 0xaae -let xk_doubbaselinedot = 0xaaf -let xk_onethird = 0xab0 -let xk_twothirds = 0xab1 -let xk_onefifth = 0xab2 -let xk_twofifths = 0xab3 -let xk_threefifths = 0xab4 -let xk_fourfifths = 0xab5 -let xk_onesixth = 0xab6 -let xk_fivesixths = 0xab7 -let xk_careof = 0xab8 -let xk_figdash = 0xabb -let xk_leftanglebracket = 0xabc -let xk_decimalpoint = 0xabd -let xk_rightanglebracket = 0xabe -let xk_marker = 0xabf -let xk_oneeighth = 0xac3 -let xk_threeeighths = 0xac4 -let xk_fiveeighths = 0xac5 -let xk_seveneighths = 0xac6 -let xk_trademark = 0xac9 -let xk_signaturemark = 0xaca -let xk_trademarkincircle = 0xacb -let xk_leftopentriangle = 0xacc -let xk_rightopentriangle = 0xacd -let xk_emopencircle = 0xace -let xk_emopenrectangle = 0xacf -let xk_leftsinglequotemark = 0xad0 -let xk_rightsinglequotemark = 0xad1 -let xk_leftdoublequotemark = 0xad2 -let xk_rightdoublequotemark = 0xad3 -let xk_prescription = 0xad4 -let xk_minutes = 0xad6 -let xk_seconds = 0xad7 -let xk_latincross = 0xad9 -let xk_hexagram = 0xada -let xk_filledrectbullet = 0xadb -let xk_filledlefttribullet = 0xadc -let xk_filledrighttribullet = 0xadd -let xk_emfilledcircle = 0xade -let xk_emfilledrect = 0xadf -let xk_enopencircbullet = 0xae0 -let xk_enopensquarebullet = 0xae1 -let xk_openrectbullet = 0xae2 -let xk_opentribulletup = 0xae3 -let xk_opentribulletdown = 0xae4 -let xk_openstar = 0xae5 -let xk_enfilledcircbullet = 0xae6 -let xk_enfilledsqbullet = 0xae7 -let xk_filledtribulletup = 0xae8 -let xk_filledtribulletdown = 0xae9 -let xk_leftpointer = 0xaea -let xk_rightpointer = 0xaeb -let xk_club = 0xaec -let xk_diamond = 0xaed -let xk_heart = 0xaee -let xk_maltesecross = 0xaf0 -let xk_dagger = 0xaf1 -let xk_doubledagger = 0xaf2 -let xk_checkmark = 0xaf3 -let xk_ballotcross = 0xaf4 -let xk_musicalsharp = 0xaf5 -let xk_musicalflat = 0xaf6 -let xk_malesymbol = 0xaf7 -let xk_femalesymbol = 0xaf8 -let xk_telephone = 0xaf9 -let xk_telephonerecorder = 0xafa -let xk_phonographcopyright = 0xafb -let xk_caret = 0xafc -let xk_singlelowquotemark = 0xafd -let xk_doublelowquotemark = 0xafe -let xk_cursor = 0xaff - - -(* - * APL - * Byte 3 = b - *) - - -let xk_leftcaret = 0xba3 -let xk_rightcaret = 0xba6 -let xk_downcaret = 0xba8 -let xk_upcaret = 0xba9 -let xk_overbar = 0xbc0 -let xk_downtack = 0xbc2 -let xk_upshoe = 0xbc3 -let xk_downstile = 0xbc4 -let xk_underbar = 0xbc6 -let xk_jot = 0xbca -let xk_quad = 0xbcc -let xk_uptack = 0xbce -let xk_circle = 0xbcf -let xk_upstile = 0xbd3 -let xk_downshoe = 0xbd6 -let xk_rightshoe = 0xbd8 -let xk_leftshoe = 0xbda -let xk_lefttack = 0xbdc -let xk_righttack = 0xbfc - - -(* - * Hebrew - * Byte 3 = c - *) - - -let xk_hebrew_doublelowline = 0xcdf -let xk_hebrew_aleph = 0xce0 -let xk_hebrew_bet = 0xce1 -let xk_hebrew_beth = 0xce1 (** deprecated *) -let xk_hebrew_gimel = 0xce2 -let xk_hebrew_gimmel = 0xce2 (** deprecated *) -let xk_hebrew_dalet = 0xce3 -let xk_hebrew_daleth = 0xce3 (** deprecated *) -let xk_hebrew_he = 0xce4 -let xk_hebrew_waw = 0xce5 -let xk_hebrew_zain = 0xce6 -let xk_hebrew_zayin = 0xce6 (** deprecated *) -let xk_hebrew_chet = 0xce7 -let xk_hebrew_het = 0xce7 (** deprecated *) -let xk_hebrew_tet = 0xce8 -let xk_hebrew_teth = 0xce8 (** deprecated *) -let xk_hebrew_yod = 0xce9 -let xk_hebrew_finalkaph = 0xcea -let xk_hebrew_kaph = 0xceb -let xk_hebrew_lamed = 0xcec -let xk_hebrew_finalmem = 0xced -let xk_hebrew_mem = 0xcee -let xk_hebrew_finalnun = 0xcef -let xk_hebrew_nun = 0xcf0 -let xk_hebrew_samech = 0xcf1 -let xk_hebrew_samekh = 0xcf1 (** deprecated *) -let xk_hebrew_ayin = 0xcf2 -let xk_hebrew_finalpe = 0xcf3 -let xk_hebrew_pe = 0xcf4 -let xk_hebrew_finalzade = 0xcf5 -let xk_hebrew_finalzadi = 0xcf5 (** deprecated *) -let xk_hebrew_zade = 0xcf6 -let xk_hebrew_zadi = 0xcf6 (** deprecated *) -let xk_hebrew_qoph = 0xcf7 -let xk_hebrew_kuf = 0xcf7 (** deprecated *) -let xk_hebrew_resh = 0xcf8 -let xk_hebrew_shin = 0xcf9 -let xk_hebrew_taw = 0xcfa -let xk_hebrew_taf = 0xcfa (** deprecated *) -let xk_Hebrew_switch = 0xFF7E (** Alias for mode_switch *) - - -(* - * Thai - * Byte 3 = d - *) - - -let xk_Thai_kokai = 0xda1 -let xk_Thai_khokhai = 0xda2 -let xk_Thai_khokhuat = 0xda3 -let xk_Thai_khokhwai = 0xda4 -let xk_Thai_khokhon = 0xda5 -let xk_Thai_khorakhang = 0xda6 -let xk_Thai_ngongu = 0xda7 -let xk_Thai_chochan = 0xda8 -let xk_Thai_choching = 0xda9 -let xk_Thai_chochang = 0xdaa -let xk_Thai_soso = 0xdab -let xk_Thai_chochoe = 0xdac -let xk_Thai_yoying = 0xdad -let xk_Thai_dochada = 0xdae -let xk_Thai_topatak = 0xdaf -let xk_Thai_thothan = 0xdb0 -let xk_Thai_thonangmontho = 0xdb1 -let xk_Thai_thophuthao = 0xdb2 -let xk_Thai_nonen = 0xdb3 -let xk_Thai_dodek = 0xdb4 -let xk_Thai_totao = 0xdb5 -let xk_Thai_thothung = 0xdb6 -let xk_Thai_thothahan = 0xdb7 -let xk_Thai_thothong = 0xdb8 -let xk_Thai_nonu = 0xdb9 -let xk_Thai_bobaimai = 0xdba -let xk_Thai_popla = 0xdbb -let xk_Thai_phophung = 0xdbc -let xk_Thai_fofa = 0xdbd -let xk_Thai_phophan = 0xdbe -let xk_Thai_fofan = 0xdbf -let xk_Thai_phosamphao = 0xdc0 -let xk_Thai_moma = 0xdc1 -let xk_Thai_yoyak = 0xdc2 -let xk_Thai_rorua = 0xdc3 -let xk_Thai_ru = 0xdc4 -let xk_Thai_loling = 0xdc5 -let xk_Thai_lu = 0xdc6 -let xk_Thai_wowaen = 0xdc7 -let xk_Thai_sosala = 0xdc8 -let xk_Thai_sorusi = 0xdc9 -let xk_Thai_sosua = 0xdca -let xk_Thai_hohip = 0xdcb -let xk_Thai_lochula = 0xdcc -let xk_Thai_oang = 0xdcd -let xk_Thai_honokhuk = 0xdce -let xk_Thai_paiyannoi = 0xdcf -let xk_Thai_saraa = 0xdd0 -let xk_Thai_maihanakat = 0xdd1 -let xk_Thai_saraaa = 0xdd2 -let xk_Thai_saraam = 0xdd3 -let xk_Thai_sarai = 0xdd4 -let xk_Thai_saraii = 0xdd5 -let xk_Thai_saraue = 0xdd6 -let xk_Thai_sarauee = 0xdd7 -let xk_Thai_sarau = 0xdd8 -let xk_Thai_sarauu = 0xdd9 -let xk_Thai_phinthu = 0xdda -let xk_Thai_maihanakat_maitho = 0xdde -let xk_Thai_baht = 0xddf -let xk_Thai_sarae = 0xde0 -let xk_Thai_saraae = 0xde1 -let xk_Thai_sarao = 0xde2 -let xk_Thai_saraaimaimuan = 0xde3 -let xk_Thai_saraaimaimalai = 0xde4 -let xk_Thai_lakkhangyao = 0xde5 -let xk_Thai_maiyamok = 0xde6 -let xk_Thai_maitaikhu = 0xde7 -let xk_Thai_maiek = 0xde8 -let xk_Thai_maitho = 0xde9 -let xk_Thai_maitri = 0xdea -let xk_Thai_maichattawa = 0xdeb -let xk_Thai_thanthakhat = 0xdec -let xk_Thai_nikhahit = 0xded -let xk_Thai_leksun = 0xdf0 -let xk_Thai_leknung = 0xdf1 -let xk_Thai_leksong = 0xdf2 -let xk_Thai_leksam = 0xdf3 -let xk_Thai_leksi = 0xdf4 -let xk_Thai_lekha = 0xdf5 -let xk_Thai_lekhok = 0xdf6 -let xk_Thai_lekchet = 0xdf7 -let xk_Thai_lekpaet = 0xdf8 -let xk_Thai_lekkao = 0xdf9 - - -(* - * Korean - * Byte 3 = e - *) - - - -let xk_Hangul = 0xff31 (** Hangul start/stop(toggle) *) -let xk_Hangul_Start = 0xff32 (** Hangul start *) -let xk_Hangul_End = 0xff33 (** Hangul end, English start *) -let xk_Hangul_Hanja = 0xff34 (** Start Hangul->Hanja Conversion *) -let xk_Hangul_Jamo = 0xff35 (** Hangul Jamo mode *) -let xk_Hangul_Romaja = 0xff36 (** Hangul Romaja mode *) -let xk_Hangul_Codeinput = 0xff37 (** Hangul code input mode *) -let xk_Hangul_Jeonja = 0xff38 (** Jeonja mode *) -let xk_Hangul_Banja = 0xff39 (** Banja mode *) -let xk_Hangul_PreHanja = 0xff3a (** Pre Hanja conversion *) -let xk_Hangul_PostHanja = 0xff3b (** Post Hanja conversion *) -let xk_Hangul_SingleCandidate = 0xff3c (** Single candidate *) -let xk_Hangul_MultipleCandidate = 0xff3d (** Multiple candidate *) -let xk_Hangul_PreviousCandidate = 0xff3e (** Previous candidate *) -let xk_Hangul_Special = 0xff3f (** Special symbols *) -let xk_Hangul_switch = 0xFF7E (** Alias for mode_switch *) - -(** Hangul Consonant Characters *) -let xk_Hangul_Kiyeog = 0xea1 -let xk_Hangul_SsangKiyeog = 0xea2 -let xk_Hangul_KiyeogSios = 0xea3 -let xk_Hangul_Nieun = 0xea4 -let xk_Hangul_NieunJieuj = 0xea5 -let xk_Hangul_NieunHieuh = 0xea6 -let xk_Hangul_Dikeud = 0xea7 -let xk_Hangul_SsangDikeud = 0xea8 -let xk_Hangul_Rieul = 0xea9 -let xk_Hangul_RieulKiyeog = 0xeaa -let xk_Hangul_RieulMieum = 0xeab -let xk_Hangul_RieulPieub = 0xeac -let xk_Hangul_RieulSios = 0xead -let xk_Hangul_RieulTieut = 0xeae -let xk_Hangul_RieulPhieuf = 0xeaf -let xk_Hangul_RieulHieuh = 0xeb0 -let xk_Hangul_Mieum = 0xeb1 -let xk_Hangul_Pieub = 0xeb2 -let xk_Hangul_SsangPieub = 0xeb3 -let xk_Hangul_PieubSios = 0xeb4 -let xk_Hangul_Sios = 0xeb5 -let xk_Hangul_SsangSios = 0xeb6 -let xk_Hangul_Ieung = 0xeb7 -let xk_Hangul_Jieuj = 0xeb8 -let xk_Hangul_SsangJieuj = 0xeb9 -let xk_Hangul_Cieuc = 0xeba -let xk_Hangul_Khieuq = 0xebb -let xk_Hangul_Tieut = 0xebc -let xk_Hangul_Phieuf = 0xebd -let xk_Hangul_Hieuh = 0xebe - -(** Hangul Vowel Characters *) -let xk_Hangul_A = 0xebf -let xk_Hangul_AE = 0xec0 -let xk_Hangul_YA = 0xec1 -let xk_Hangul_YAE = 0xec2 -let xk_Hangul_EO = 0xec3 -let xk_Hangul_E = 0xec4 -let xk_Hangul_YEO = 0xec5 -let xk_Hangul_YE = 0xec6 -let xk_Hangul_O = 0xec7 -let xk_Hangul_WA = 0xec8 -let xk_Hangul_WAE = 0xec9 -let xk_Hangul_OE = 0xeca -let xk_Hangul_YO = 0xecb -let xk_Hangul_U = 0xecc -let xk_Hangul_WEO = 0xecd -let xk_Hangul_WE = 0xece -let xk_Hangul_WI = 0xecf -let xk_Hangul_YU = 0xed0 -let xk_Hangul_EU = 0xed1 -let xk_Hangul_YI = 0xed2 -let xk_Hangul_I = 0xed3 - -(** Hangul syllable-final (JongSeong) Characters *) -let xk_Hangul_J_Kiyeog = 0xed4 -let xk_Hangul_J_SsangKiyeog = 0xed5 -let xk_Hangul_J_KiyeogSios = 0xed6 -let xk_Hangul_J_Nieun = 0xed7 -let xk_Hangul_J_NieunJieuj = 0xed8 -let xk_Hangul_J_NieunHieuh = 0xed9 -let xk_Hangul_J_Dikeud = 0xeda -let xk_Hangul_J_Rieul = 0xedb -let xk_Hangul_J_RieulKiyeog = 0xedc -let xk_Hangul_J_RieulMieum = 0xedd -let xk_Hangul_J_RieulPieub = 0xede -let xk_Hangul_J_RieulSios = 0xedf -let xk_Hangul_J_RieulTieut = 0xee0 -let xk_Hangul_J_RieulPhieuf = 0xee1 -let xk_Hangul_J_RieulHieuh = 0xee2 -let xk_Hangul_J_Mieum = 0xee3 -let xk_Hangul_J_Pieub = 0xee4 -let xk_Hangul_J_PieubSios = 0xee5 -let xk_Hangul_J_Sios = 0xee6 -let xk_Hangul_J_SsangSios = 0xee7 -let xk_Hangul_J_Ieung = 0xee8 -let xk_Hangul_J_Jieuj = 0xee9 -let xk_Hangul_J_Cieuc = 0xeea -let xk_Hangul_J_Khieuq = 0xeeb -let xk_Hangul_J_Tieut = 0xeec -let xk_Hangul_J_Phieuf = 0xeed -let xk_Hangul_J_Hieuh = 0xeee - -(** Ancient Hangul Consonant Characters *) -let xk_Hangul_RieulYeorinHieuh = 0xeef -let xk_Hangul_SunkyeongeumMieum = 0xef0 -let xk_Hangul_SunkyeongeumPieub = 0xef1 -let xk_Hangul_PanSios = 0xef2 -let xk_Hangul_KkogjiDalrinIeung = 0xef3 -let xk_Hangul_SunkyeongeumPhieuf = 0xef4 -let xk_Hangul_YeorinHieuh = 0xef5 - -(** Ancient Hangul Vowel Characters *) -let xk_Hangul_AraeA = 0xef6 -let xk_Hangul_AraeAE = 0xef7 - -(** Ancient Hangul syllable-final (JongSeong) Characters *) -let xk_Hangul_J_PanSios = 0xef8 -let xk_Hangul_J_KkogjiDalrinIeung = 0xef9 -let xk_Hangul_J_YeorinHieuh = 0xefa - -(** Korean currency symbol *) -let xk_Korean_Won = 0xeff - - - -let name_to_keysym = [ -"VoidSymbol",0xFFFFFF; -"BackSpace",0xFF08; -"Tab",0xFF09; -"Linefeed",0xFF0A; -"Clear",0xFF0B; -"Return",0xFF0D; -"Pause",0xFF13; -"Scroll_Lock",0xFF14; -"Sys_Req",0xFF15; -"Escape",0xFF1B; -"Delete",0xFFFF; -"Multi_key",0xFF20; -"Kanji",0xFF21; -"Muhenkan",0xFF22; -"Henkan_Mode",0xFF23; -"Henkan",0xFF23; -"Romaji",0xFF24; -"Hiragana",0xFF25; -"Katakana",0xFF26; -"Hiragana_Katakana",0xFF27; -"Zenkaku",0xFF28; -"Hankaku",0xFF29; -"Zenkaku_Hankaku",0xFF2A; -"Touroku",0xFF2B; -"Massyo",0xFF2C; -"Kana_Lock",0xFF2D; -"Kana_Shift",0xFF2E; -"Eisu_Shift",0xFF2F; -"Eisu_toggle",0xFF30; -"Home",0xFF50; -"Left",0xFF51; -"Up",0xFF52; -"Right",0xFF53; -"Down",0xFF54; -"Prior",0xFF55; -"Page_Up",0xFF55; -"Next",0xFF56; -"Page_Down",0xFF56; -"End",0xFF57; -"Begin",0xFF58; -"Select",0xFF60; -"Print",0xFF61; -"Execute",0xFF62; -"Insert",0xFF63; -"Undo",0xFF65; -"Redo",0xFF66; -"Menu",0xFF67; -"Find",0xFF68; -"Cancel",0xFF69; -"Help",0xFF6A; -"Break",0xFF6B; -"Mode_switch",0xFF7E; -"script_switch",0xFF7E; -"Num_Lock",0xFF7F; -"KP_Space",0xFF80; -"KP_Tab",0xFF89; -"KP_Enter",0xFF8D; -"KP_F1",0xFF91; -"KP_F2",0xFF92; -"KP_F3",0xFF93; -"KP_F4",0xFF94; -"KP_Home",0xFF95; -"KP_Left",0xFF96; -"KP_Up",0xFF97; -"KP_Right",0xFF98; -"KP_Down",0xFF99; -"KP_Prior",0xFF9A; -"KP_Page_Up",0xFF9A; -"KP_Next",0xFF9B; -"KP_Page_Down",0xFF9B; -"KP_End",0xFF9C; -"KP_Begin",0xFF9D; -"KP_Insert",0xFF9E; -"KP_Delete",0xFF9F; -"KP_Equal",0xFFBD; -"KP_Multiply",0xFFAA; -"KP_Add",0xFFAB; -"KP_Separator",0xFFAC; -"KP_Subtract",0xFFAD; -"KP_Decimal",0xFFAE; -"KP_Divide",0xFFAF; -"KP_0",0xFFB0; -"KP_1",0xFFB1; -"KP_2",0xFFB2; -"KP_3",0xFFB3; -"KP_4",0xFFB4; -"KP_5",0xFFB5; -"KP_6",0xFFB6; -"KP_7",0xFFB7; -"KP_8",0xFFB8; -"KP_9",0xFFB9; -"F1",0xFFBE; -"F2",0xFFBF; -"F3",0xFFC0; -"F4",0xFFC1; -"F5",0xFFC2; -"F6",0xFFC3; -"F7",0xFFC4; -"F8",0xFFC5; -"F9",0xFFC6; -"F10",0xFFC7; -"F11",0xFFC8; -"L1",0xFFC8; -"F12",0xFFC9; -"L2",0xFFC9; -"F13",0xFFCA; -"L3",0xFFCA; -"F14",0xFFCB; -"L4",0xFFCB; -"F15",0xFFCC; -"L5",0xFFCC; -"F16",0xFFCD; -"L6",0xFFCD; -"F17",0xFFCE; -"L7",0xFFCE; -"F18",0xFFCF; -"L8",0xFFCF; -"F19",0xFFD0; -"L9",0xFFD0; -"F20",0xFFD1; -"L10",0xFFD1; -"F21",0xFFD2; -"R1",0xFFD2; -"F22",0xFFD3; -"R2",0xFFD3; -"F23",0xFFD4; -"R3",0xFFD4; -"F24",0xFFD5; -"R4",0xFFD5; -"F25",0xFFD6; -"R5",0xFFD6; -"F26",0xFFD7; -"R6",0xFFD7; -"F27",0xFFD8; -"R7",0xFFD8; -"F28",0xFFD9; -"R8",0xFFD9; -"F29",0xFFDA; -"R9",0xFFDA; -"F30",0xFFDB; -"R10",0xFFDB; -"F31",0xFFDC; -"R11",0xFFDC; -"F32",0xFFDD; -"R12",0xFFDD; -"F33",0xFFDE; -"R13",0xFFDE; -"F34",0xFFDF; -"R14",0xFFDF; -"F35",0xFFE0; -"R15",0xFFE0; -"Shift_L",0xFFE1; -"Shift_R",0xFFE2; -"Control_L",0xFFE3; -"Control_R",0xFFE4; -"Caps_Lock",0xFFE5; -"Shift_Lock",0xFFE6; -"Meta_L",0xFFE7; -"Meta_R",0xFFE8; -"Alt_L",0xFFE9; -"Alt_R",0xFFEA; -"Super_L",0xFFEB; -"Super_R",0xFFEC; -"Hyper_L",0xFFED; -"Hyper_R",0xFFEE; -"ISO_Lock",0xFE01; -"ISO_Level2_Latch",0xFE02; -"ISO_Level3_Shift",0xFE03; -"ISO_Level3_Latch",0xFE04; -"ISO_Level3_Lock",0xFE05; -"ISO_Group_Shift",0xFF7E; -"ISO_Group_Latch",0xFE06; -"ISO_Group_Lock",0xFE07; -"ISO_Next_Group",0xFE08; -"ISO_Next_Group_Lock",0xFE09; -"ISO_Prev_Group",0xFE0A; -"ISO_Prev_Group_Lock",0xFE0B; -"ISO_First_Group",0xFE0C; -"ISO_First_Group_Lock",0xFE0D; -"ISO_Last_Group",0xFE0E; -"ISO_Last_Group_Lock",0xFE0F; -"ISO_Left_Tab",0xFE20; -"ISO_Move_Line_Up",0xFE21; -"ISO_Move_Line_Down",0xFE22; -"ISO_Partial_Line_Up",0xFE23; -"ISO_Partial_Line_Down",0xFE24; -"ISO_Partial_Space_Left",0xFE25; -"ISO_Partial_Space_Right",0xFE26; -"ISO_Set_Margin_Left",0xFE27; -"ISO_Set_Margin_Right",0xFE28; -"ISO_Release_Margin_Left",0xFE29; -"ISO_Release_Margin_Right",0xFE2A; -"ISO_Release_Both_Margins",0xFE2B; -"ISO_Fast_Cursor_Left",0xFE2C; -"ISO_Fast_Cursor_Right",0xFE2D; -"ISO_Fast_Cursor_Up",0xFE2E; -"ISO_Fast_Cursor_Down",0xFE2F; -"ISO_Continuous_Underline",0xFE30; -"ISO_Discontinuous_Underline",0xFE31; -"ISO_Emphasize",0xFE32; -"ISO_Center_Object",0xFE33; -"ISO_Enter",0xFE34; -"dead_grave",0xFE50; -"dead_acute",0xFE51; -"dead_circumflex",0xFE52; -"dead_tilde",0xFE53; -"dead_macron",0xFE54; -"dead_breve",0xFE55; -"dead_abovedot",0xFE56; -"dead_diaeresis",0xFE57; -"dead_abovering",0xFE58; -"dead_doubleacute",0xFE59; -"dead_caron",0xFE5A; -"dead_cedilla",0xFE5B; -"dead_ogonek",0xFE5C; -"dead_iota",0xFE5D; -"dead_voiced_sound",0xFE5E; -"dead_semivoiced_sound",0xFE5F; -"dead_belowdot",0xFE60; -"First_Virtual_Screen",0xFED0; -"Prev_Virtual_Screen",0xFED1; -"Next_Virtual_Screen",0xFED2; -"Last_Virtual_Screen",0xFED4; -"Terminate_Server",0xFED5; -"AccessX_Enable",0xFE70; -"AccessX_Feedback_Enable",0xFE71; -"RepeatKeys_Enable",0xFE72; -"SlowKeys_Enable",0xFE73; -"BounceKeys_Enable",0xFE74; -"StickyKeys_Enable",0xFE75; -"MouseKeys_Enable",0xFE76; -"MouseKeys_Accel_Enable",0xFE77; -"Overlay1_Enable",0xFE78; -"Overlay2_Enable",0xFE79; -"AudibleBell_Enable",0xFE7A; -"Pointer_Left",0xFEE0; -"Pointer_Right",0xFEE1; -"Pointer_Up",0xFEE2; -"Pointer_Down",0xFEE3; -"Pointer_UpLeft",0xFEE4; -"Pointer_UpRight",0xFEE5; -"Pointer_DownLeft",0xFEE6; -"Pointer_DownRight",0xFEE7; -"Pointer_Button_Dflt",0xFEE8; -"Pointer_Button1",0xFEE9; -"Pointer_Button2",0xFEEA; -"Pointer_Button3",0xFEEB; -"Pointer_Button4",0xFEEC; -"Pointer_Button5",0xFEED; -"Pointer_DblClick_Dflt",0xFEEE; -"Pointer_DblClick1",0xFEEF; -"Pointer_DblClick2",0xFEF0; -"Pointer_DblClick3",0xFEF1; -"Pointer_DblClick4",0xFEF2; -"Pointer_DblClick5",0xFEF3; -"Pointer_Drag_Dflt",0xFEF4; -"Pointer_Drag1",0xFEF5; -"Pointer_Drag2",0xFEF6; -"Pointer_Drag3",0xFEF7; -"Pointer_Drag4",0xFEF8; -"Pointer_Drag5",0xFEFD; -"Pointer_EnableKeys",0xFEF9; -"Pointer_Accelerate",0xFEFA; -"Pointer_DfltBtnNext",0xFEFB; -"Pointer_DfltBtnPrev",0xFEFC; -"3270_Duplicate",0xFD01; -"3270_FieldMark",0xFD02; -"3270_Right2",0xFD03; -"3270_Left2",0xFD04; -"3270_BackTab",0xFD05; -"3270_EraseEOF",0xFD06; -"3270_EraseInput",0xFD07; -"3270_Reset",0xFD08; -"3270_Quit",0xFD09; -"3270_PA1",0xFD0A; -"3270_PA2",0xFD0B; -"3270_PA3",0xFD0C; -"3270_Test",0xFD0D; -"3270_Attn",0xFD0E; -"3270_CursorBlink",0xFD0F; -"3270_AltCursor",0xFD10; -"3270_KeyClick",0xFD11; -"3270_Jump",0xFD12; -"3270_Ident",0xFD13; -"3270_Rule",0xFD14; -"3270_Copy",0xFD15; -"3270_Play",0xFD16; -"3270_Setup",0xFD17; -"3270_Record",0xFD18; -"3270_ChangeScreen",0xFD19; -"3270_DeleteWord",0xFD1A; -"3270_ExSelect",0xFD1B; -"3270_CursorSelect",0xFD1C; -"3270_PrintScreen",0xFD1D; -"3270_Enter",0xFD1E; -"space",0x020; -"exclam",0x021; -"quotedbl",0x022; -"numbersign",0x023; -"dollar",0x024; -"percent",0x025; -"ampersand",0x026; -"apostrophe",0x027; -"quoteright",0x027; -"parenleft",0x028; -"parenright",0x029; -"asterisk",0x02a; -"plus",0x02b; -"comma",0x02c; -"minus",0x02d; -"period",0x02e; -"slash",0x02f; -"0",0x030; -"1",0x031; -"2",0x032; -"3",0x033; -"4",0x034; -"5",0x035; -"6",0x036; -"7",0x037; -"8",0x038; -"9",0x039; -"colon",0x03a; -"semicolon",0x03b; -"less",0x03c; -"equal",0x03d; -"greater",0x03e; -"question",0x03f; -"at",0x040; -"A",0x041; -"B",0x042; -"C",0x043; -"D",0x044; -"E",0x045; -"F",0x046; -"G",0x047; -"H",0x048; -"I",0x049; -"J",0x04a; -"K",0x04b; -"L",0x04c; -"M",0x04d; -"N",0x04e; -"O",0x04f; -"P",0x050; -"Q",0x051; -"R",0x052; -"S",0x053; -"T",0x054; -"U",0x055; -"V",0x056; -"W",0x057; -"X",0x058; -"Y",0x059; -"Z",0x05a; -"bracketleft",0x05b; -"backslash",0x05c; -"bracketright",0x05d; -"asciicircum",0x05e; -"underscore",0x05f; -"grave",0x060; -"quoteleft",0x060; -"a",0x061; -"b",0x062; -"c",0x063; -"d",0x064; -"e",0x065; -"f",0x066; -"g",0x067; -"h",0x068; -"i",0x069; -"j",0x06a; -"k",0x06b; -"l",0x06c; -"m",0x06d; -"n",0x06e; -"o",0x06f; -"p",0x070; -"q",0x071; -"r",0x072; -"s",0x073; -"t",0x074; -"u",0x075; -"v",0x076; -"w",0x077; -"x",0x078; -"y",0x079; -"z",0x07a; -"braceleft",0x07b; -"bar",0x07c; -"braceright",0x07d; -"asciitilde",0x07e; -"nobreakspace",0x0a0; -"exclamdown",0x0a1; -"cent",0x0a2; -"sterling",0x0a3; -"currency",0x0a4; -"yen",0x0a5; -"brokenbar",0x0a6; -"section",0x0a7; -"diaeresis",0x0a8; -"copyright",0x0a9; -"ordfeminine",0x0aa; -"guillemotleft",0x0ab; -"notsign",0x0ac; -"hyphen",0x0ad; -"registered",0x0ae; -"macron",0x0af; -"degree",0x0b0; -"plusminus",0x0b1; -"twosuperior",0x0b2; -"threesuperior",0x0b3; -"acute",0x0b4; -"mu",0x0b5; -"paragraph",0x0b6; -"periodcentered",0x0b7; -"cedilla",0x0b8; -"onesuperior",0x0b9; -"masculine",0x0ba; -"guillemotright",0x0bb; -"onequarter",0x0bc; -"onehalf",0x0bd; -"threequarters",0x0be; -"questiondown",0x0bf; -"Agrave",0x0c0; -"Aacute",0x0c1; -"Acircumflex",0x0c2; -"Atilde",0x0c3; -"Adiaeresis",0x0c4; -"Aring",0x0c5; -"AE",0x0c6; -"Ccedilla",0x0c7; -"Egrave",0x0c8; -"Eacute",0x0c9; -"Ecircumflex",0x0ca; -"Ediaeresis",0x0cb; -"Igrave",0x0cc; -"Iacute",0x0cd; -"Icircumflex",0x0ce; -"Idiaeresis",0x0cf; -"ETH",0x0d0; -"Eth",0x0d0; -"Ntilde",0x0d1; -"Ograve",0x0d2; -"Oacute",0x0d3; -"Ocircumflex",0x0d4; -"Otilde",0x0d5; -"Odiaeresis",0x0d6; -"multiply",0x0d7; -"Ooblique",0x0d8; -"Ugrave",0x0d9; -"Uacute",0x0da; -"Ucircumflex",0x0db; -"Udiaeresis",0x0dc; -"Yacute",0x0dd; -"THORN",0x0de; -"Thorn",0x0de; -"ssharp",0x0df; -"agrave",0x0e0; -"aacute",0x0e1; -"acircumflex",0x0e2; -"atilde",0x0e3; -"adiaeresis",0x0e4; -"aring",0x0e5; -"ae",0x0e6; -"ccedilla",0x0e7; -"egrave",0x0e8; -"eacute",0x0e9; -"ecircumflex",0x0ea; -"ediaeresis",0x0eb; -"igrave",0x0ec; -"iacute",0x0ed; -"icircumflex",0x0ee; -"idiaeresis",0x0ef; -"eth",0x0f0; -"ntilde",0x0f1; -"ograve",0x0f2; -"oacute",0x0f3; -"ocircumflex",0x0f4; -"otilde",0x0f5; -"odiaeresis",0x0f6; -"division",0x0f7; -"oslash",0x0f8; -"ugrave",0x0f9; -"uacute",0x0fa; -"ucircumflex",0x0fb; -"udiaeresis",0x0fc; -"yacute",0x0fd; -"thorn",0x0fe; -"ydiaeresis",0x0ff; -"Aogonek",0x1a1; -"breve",0x1a2; -"Lstroke",0x1a3; -"Lcaron",0x1a5; -"Sacute",0x1a6; -"Scaron",0x1a9; -"Scedilla",0x1aa; -"Tcaron",0x1ab; -"Zacute",0x1ac; -"Zcaron",0x1ae; -"Zabovedot",0x1af; -"aogonek",0x1b1; -"ogonek",0x1b2; -"lstroke",0x1b3; -"lcaron",0x1b5; -"sacute",0x1b6; -"caron",0x1b7; -"scaron",0x1b9; -"scedilla",0x1ba; -"tcaron",0x1bb; -"zacute",0x1bc; -"doubleacute",0x1bd; -"zcaron",0x1be; -"zabovedot",0x1bf; -"Racute",0x1c0; -"Abreve",0x1c3; -"Lacute",0x1c5; -"Cacute",0x1c6; -"Ccaron",0x1c8; -"Eogonek",0x1ca; -"Ecaron",0x1cc; -"Dcaron",0x1cf; -"Dstroke",0x1d0; -"Nacute",0x1d1; -"Ncaron",0x1d2; -"Odoubleacute",0x1d5; -"Rcaron",0x1d8; -"Uring",0x1d9; -"Udoubleacute",0x1db; -"Tcedilla",0x1de; -"racute",0x1e0; -"abreve",0x1e3; -"lacute",0x1e5; -"cacute",0x1e6; -"ccaron",0x1e8; -"eogonek",0x1ea; -"ecaron",0x1ec; -"dcaron",0x1ef; -"dstroke",0x1f0; -"nacute",0x1f1; -"ncaron",0x1f2; -"odoubleacute",0x1f5; -"udoubleacute",0x1fb; -"rcaron",0x1f8; -"uring",0x1f9; -"tcedilla",0x1fe; -"abovedot",0x1ff; -"Hstroke",0x2a1; -"Hcircumflex",0x2a6; -"Iabovedot",0x2a9; -"Gbreve",0x2ab; -"Jcircumflex",0x2ac; -"hstroke",0x2b1; -"hcircumflex",0x2b6; -"idotless",0x2b9; -"gbreve",0x2bb; -"jcircumflex",0x2bc; -"Cabovedot",0x2c5; -"Ccircumflex",0x2c6; -"Gabovedot",0x2d5; -"Gcircumflex",0x2d8; -"Ubreve",0x2dd; -"Scircumflex",0x2de; -"cabovedot",0x2e5; -"ccircumflex",0x2e6; -"gabovedot",0x2f5; -"gcircumflex",0x2f8; -"ubreve",0x2fd; -"scircumflex",0x2fe; -"kra",0x3a2; -"kappa",0x3a2; -"Rcedilla",0x3a3; -"Itilde",0x3a5; -"Lcedilla",0x3a6; -"Emacron",0x3aa; -"Gcedilla",0x3ab; -"Tslash",0x3ac; -"rcedilla",0x3b3; -"itilde",0x3b5; -"lcedilla",0x3b6; -"emacron",0x3ba; -"gcedilla",0x3bb; -"tslash",0x3bc; -"ENG",0x3bd; -"eng",0x3bf; -"Amacron",0x3c0; -"Iogonek",0x3c7; -"Eabovedot",0x3cc; -"Imacron",0x3cf; -"Ncedilla",0x3d1; -"Omacron",0x3d2; -"Kcedilla",0x3d3; -"Uogonek",0x3d9; -"Utilde",0x3dd; -"Umacron",0x3de; -"amacron",0x3e0; -"iogonek",0x3e7; -"eabovedot",0x3ec; -"imacron",0x3ef; -"ncedilla",0x3f1; -"omacron",0x3f2; -"kcedilla",0x3f3; -"uogonek",0x3f9; -"utilde",0x3fd; -"umacron",0x3fe; -"overline",0x47e; -"kana_fullstop",0x4a1; -"kana_openingbracket",0x4a2; -"kana_closingbracket",0x4a3; -"kana_comma",0x4a4; -"kana_conjunctive",0x4a5; -"kana_middledot",0x4a5; -"kana_WO",0x4a6; -"kana_a",0x4a7; -"kana_i",0x4a8; -"kana_u",0x4a9; -"kana_e",0x4aa; -"kana_o",0x4ab; -"kana_ya",0x4ac; -"kana_yu",0x4ad; -"kana_yo",0x4ae; -"kana_tsu",0x4af; -"kana_tu",0x4af; -"prolongedsound",0x4b0; -"kana_A",0x4b1; -"kana_I",0x4b2; -"kana_U",0x4b3; -"kana_E",0x4b4; -"kana_O",0x4b5; -"kana_KA",0x4b6; -"kana_KI",0x4b7; -"kana_KU",0x4b8; -"kana_KE",0x4b9; -"kana_KO",0x4ba; -"kana_SA",0x4bb; -"kana_SHI",0x4bc; -"kana_SU",0x4bd; -"kana_SE",0x4be; -"kana_SO",0x4bf; -"kana_TA",0x4c0; -"kana_CHI",0x4c1; -"kana_TI",0x4c1; -"kana_TSU",0x4c2; -"kana_TU",0x4c2; -"kana_TE",0x4c3; -"kana_TO",0x4c4; -"kana_NA",0x4c5; -"kana_NI",0x4c6; -"kana_NU",0x4c7; -"kana_NE",0x4c8; -"kana_NO",0x4c9; -"kana_HA",0x4ca; -"kana_HI",0x4cb; -"kana_FU",0x4cc; -"kana_HU",0x4cc; -"kana_HE",0x4cd; -"kana_HO",0x4ce; -"kana_MA",0x4cf; -"kana_MI",0x4d0; -"kana_MU",0x4d1; -"kana_ME",0x4d2; -"kana_MO",0x4d3; -"kana_YA",0x4d4; -"kana_YU",0x4d5; -"kana_YO",0x4d6; -"kana_RA",0x4d7; -"kana_RI",0x4d8; -"kana_RU",0x4d9; -"kana_RE",0x4da; -"kana_RO",0x4db; -"kana_WA",0x4dc; -"kana_N",0x4dd; -"voicedsound",0x4de; -"semivoicedsound",0x4df; -"kana_switch",0xFF7E; -"Arabic_comma",0x5ac; -"Arabic_semicolon",0x5bb; -"Arabic_question_mark",0x5bf; -"Arabic_hamza",0x5c1; -"Arabic_maddaonalef",0x5c2; -"Arabic_hamzaonalef",0x5c3; -"Arabic_hamzaonwaw",0x5c4; -"Arabic_hamzaunderalef",0x5c5; -"Arabic_hamzaonyeh",0x5c6; -"Arabic_alef",0x5c7; -"Arabic_beh",0x5c8; -"Arabic_tehmarbuta",0x5c9; -"Arabic_teh",0x5ca; -"Arabic_theh",0x5cb; -"Arabic_jeem",0x5cc; -"Arabic_hah",0x5cd; -"Arabic_khah",0x5ce; -"Arabic_dal",0x5cf; -"Arabic_thal",0x5d0; -"Arabic_ra",0x5d1; -"Arabic_zain",0x5d2; -"Arabic_seen",0x5d3; -"Arabic_sheen",0x5d4; -"Arabic_sad",0x5d5; -"Arabic_dad",0x5d6; -"Arabic_tah",0x5d7; -"Arabic_zah",0x5d8; -"Arabic_ain",0x5d9; -"Arabic_ghain",0x5da; -"Arabic_tatweel",0x5e0; -"Arabic_feh",0x5e1; -"Arabic_qaf",0x5e2; -"Arabic_kaf",0x5e3; -"Arabic_lam",0x5e4; -"Arabic_meem",0x5e5; -"Arabic_noon",0x5e6; -"Arabic_ha",0x5e7; -"Arabic_heh",0x5e7; -"Arabic_waw",0x5e8; -"Arabic_alefmaksura",0x5e9; -"Arabic_yeh",0x5ea; -"Arabic_fathatan",0x5eb; -"Arabic_dammatan",0x5ec; -"Arabic_kasratan",0x5ed; -"Arabic_fatha",0x5ee; -"Arabic_damma",0x5ef; -"Arabic_kasra",0x5f0; -"Arabic_shadda",0x5f1; -"Arabic_sukun",0x5f2; -"Arabic_switch",0xFF7E; -"Serbian_dje",0x6a1; -"Macedonia_gje",0x6a2; -"Cyrillic_io",0x6a3; -"Ukrainian_ie",0x6a4; -"Ukranian_je",0x6a4; -"Macedonia_dse",0x6a5; -"Ukrainian_i",0x6a6; -"Ukranian_i",0x6a6; -"Ukrainian_yi",0x6a7; -"Ukranian_yi",0x6a7; -"Cyrillic_je",0x6a8; -"Serbian_je",0x6a8; -"Cyrillic_lje",0x6a9; -"Serbian_lje",0x6a9; -"Cyrillic_nje",0x6aa; -"Serbian_nje",0x6aa; -"Serbian_tshe",0x6ab; -"Macedonia_kje",0x6ac; -"Byelorussian_shortu",0x6ae; -"Cyrillic_dzhe",0x6af; -"Serbian_dze",0x6af; -"numerosign",0x6b0; -"Serbian_DJE",0x6b1; -"Macedonia_GJE",0x6b2; -"Cyrillic_IO",0x6b3; -"Ukrainian_IE",0x6b4; -"Ukranian_JE",0x6b4; -"Macedonia_DSE",0x6b5; -"Ukrainian_I",0x6b6; -"Ukranian_I",0x6b6; -"Ukrainian_YI",0x6b7; -"Ukranian_YI",0x6b7; -"Cyrillic_JE",0x6b8; -"Serbian_JE",0x6b8; -"Cyrillic_LJE",0x6b9; -"Serbian_LJE",0x6b9; -"Cyrillic_NJE",0x6ba; -"Serbian_NJE",0x6ba; -"Serbian_TSHE",0x6bb; -"Macedonia_KJE",0x6bc; -"Byelorussian_SHORTU",0x6be; -"Cyrillic_DZHE",0x6bf; -"Serbian_DZE",0x6bf; -"Cyrillic_yu",0x6c0; -"Cyrillic_a",0x6c1; -"Cyrillic_be",0x6c2; -"Cyrillic_tse",0x6c3; -"Cyrillic_de",0x6c4; -"Cyrillic_ie",0x6c5; -"Cyrillic_ef",0x6c6; -"Cyrillic_ghe",0x6c7; -"Cyrillic_ha",0x6c8; -"Cyrillic_i",0x6c9; -"Cyrillic_shorti",0x6ca; -"Cyrillic_ka",0x6cb; -"Cyrillic_el",0x6cc; -"Cyrillic_em",0x6cd; -"Cyrillic_en",0x6ce; -"Cyrillic_o",0x6cf; -"Cyrillic_pe",0x6d0; -"Cyrillic_ya",0x6d1; -"Cyrillic_er",0x6d2; -"Cyrillic_es",0x6d3; -"Cyrillic_te",0x6d4; -"Cyrillic_u",0x6d5; -"Cyrillic_zhe",0x6d6; -"Cyrillic_ve",0x6d7; -"Cyrillic_softsign",0x6d8; -"Cyrillic_yeru",0x6d9; -"Cyrillic_ze",0x6da; -"Cyrillic_sha",0x6db; -"Cyrillic_e",0x6dc; -"Cyrillic_shcha",0x6dd; -"Cyrillic_che",0x6de; -"Cyrillic_hardsign",0x6df; -"Cyrillic_YU",0x6e0; -"Cyrillic_A",0x6e1; -"Cyrillic_BE",0x6e2; -"Cyrillic_TSE",0x6e3; -"Cyrillic_DE",0x6e4; -"Cyrillic_IE",0x6e5; -"Cyrillic_EF",0x6e6; -"Cyrillic_GHE",0x6e7; -"Cyrillic_HA",0x6e8; -"Cyrillic_I",0x6e9; -"Cyrillic_SHORTI",0x6ea; -"Cyrillic_KA",0x6eb; -"Cyrillic_EL",0x6ec; -"Cyrillic_EM",0x6ed; -"Cyrillic_EN",0x6ee; -"Cyrillic_O",0x6ef; -"Cyrillic_PE",0x6f0; -"Cyrillic_YA",0x6f1; -"Cyrillic_ER",0x6f2; -"Cyrillic_ES",0x6f3; -"Cyrillic_TE",0x6f4; -"Cyrillic_U",0x6f5; -"Cyrillic_ZHE",0x6f6; -"Cyrillic_VE",0x6f7; -"Cyrillic_SOFTSIGN",0x6f8; -"Cyrillic_YERU",0x6f9; -"Cyrillic_ZE",0x6fa; -"Cyrillic_SHA",0x6fb; -"Cyrillic_E",0x6fc; -"Cyrillic_SHCHA",0x6fd; -"Cyrillic_CHE",0x6fe; -"Cyrillic_HARDSIGN",0x6ff; -"Greek_ALPHAaccent",0x7a1; -"Greek_EPSILONaccent",0x7a2; -"Greek_ETAaccent",0x7a3; -"Greek_IOTAaccent",0x7a4; -"Greek_IOTAdiaeresis",0x7a5; -"Greek_OMICRONaccent",0x7a7; -"Greek_UPSILONaccent",0x7a8; -"Greek_UPSILONdieresis",0x7a9; -"Greek_OMEGAaccent",0x7ab; -"Greek_accentdieresis",0x7ae; -"Greek_horizbar",0x7af; -"Greek_alphaaccent",0x7b1; -"Greek_epsilonaccent",0x7b2; -"Greek_etaaccent",0x7b3; -"Greek_iotaaccent",0x7b4; -"Greek_iotadieresis",0x7b5; -"Greek_iotaaccentdieresis",0x7b6; -"Greek_omicronaccent",0x7b7; -"Greek_upsilonaccent",0x7b8; -"Greek_upsilondieresis",0x7b9; -"Greek_upsilonaccentdieresis",0x7ba; -"Greek_omegaaccent",0x7bb; -"Greek_ALPHA",0x7c1; -"Greek_BETA",0x7c2; -"Greek_GAMMA",0x7c3; -"Greek_DELTA",0x7c4; -"Greek_EPSILON",0x7c5; -"Greek_ZETA",0x7c6; -"Greek_ETA",0x7c7; -"Greek_THETA",0x7c8; -"Greek_IOTA",0x7c9; -"Greek_KAPPA",0x7ca; -"Greek_LAMDA",0x7cb; -"Greek_LAMBDA",0x7cb; -"Greek_MU",0x7cc; -"Greek_NU",0x7cd; -"Greek_XI",0x7ce; -"Greek_OMICRON",0x7cf; -"Greek_PI",0x7d0; -"Greek_RHO",0x7d1; -"Greek_SIGMA",0x7d2; -"Greek_TAU",0x7d4; -"Greek_UPSILON",0x7d5; -"Greek_PHI",0x7d6; -"Greek_CHI",0x7d7; -"Greek_PSI",0x7d8; -"Greek_OMEGA",0x7d9; -"Greek_alpha",0x7e1; -"Greek_beta",0x7e2; -"Greek_gamma",0x7e3; -"Greek_delta",0x7e4; -"Greek_epsilon",0x7e5; -"Greek_zeta",0x7e6; -"Greek_eta",0x7e7; -"Greek_theta",0x7e8; -"Greek_iota",0x7e9; -"Greek_kappa",0x7ea; -"Greek_lamda",0x7eb; -"Greek_lambda",0x7eb; -"Greek_mu",0x7ec; -"Greek_nu",0x7ed; -"Greek_xi",0x7ee; -"Greek_omicron",0x7ef; -"Greek_pi",0x7f0; -"Greek_rho",0x7f1; -"Greek_sigma",0x7f2; -"Greek_finalsmallsigma",0x7f3; -"Greek_tau",0x7f4; -"Greek_upsilon",0x7f5; -"Greek_phi",0x7f6; -"Greek_chi",0x7f7; -"Greek_psi",0x7f8; -"Greek_omega",0x7f9; -"Greek_switch",0xFF7E; -"leftradical",0x8a1; -"topleftradical",0x8a2; -"horizconnector",0x8a3; -"topintegral",0x8a4; -"botintegral",0x8a5; -"vertconnector",0x8a6; -"topleftsqbracket",0x8a7; -"botleftsqbracket",0x8a8; -"toprightsqbracket",0x8a9; -"botrightsqbracket",0x8aa; -"topleftparens",0x8ab; -"botleftparens",0x8ac; -"toprightparens",0x8ad; -"botrightparens",0x8ae; -"leftmiddlecurlybrace",0x8af; -"rightmiddlecurlybrace",0x8b0; -"topleftsummation",0x8b1; -"botleftsummation",0x8b2; -"topvertsummationconnector",0x8b3; -"botvertsummationconnector",0x8b4; -"toprightsummation",0x8b5; -"botrightsummation",0x8b6; -"rightmiddlesummation",0x8b7; -"lessthanequal",0x8bc; -"notequal",0x8bd; -"greaterthanequal",0x8be; -"integral",0x8bf; -"therefore",0x8c0; -"variation",0x8c1; -"infinity",0x8c2; -"nabla",0x8c5; -"approximate",0x8c8; -"similarequal",0x8c9; -"ifonlyif",0x8cd; -"implies",0x8ce; -"identical",0x8cf; -"radical",0x8d6; -"includedin",0x8da; -"includes",0x8db; -"intersection",0x8dc; -"union",0x8dd; -"logicaland",0x8de; -"logicalor",0x8df; -"partialderivative",0x8ef; -"function",0x8f6; -"leftarrow",0x8fb; -"uparrow",0x8fc; -"rightarrow",0x8fd; -"downarrow",0x8fe; -"blank",0x9df; -"soliddiamond",0x9e0; -"checkerboard",0x9e1; -"ht",0x9e2; -"ff",0x9e3; -"cr",0x9e4; -"lf",0x9e5; -"nl",0x9e8; -"vt",0x9e9; -"lowrightcorner",0x9ea; -"uprightcorner",0x9eb; -"upleftcorner",0x9ec; -"lowleftcorner",0x9ed; -"crossinglines",0x9ee; -"horizlinescan1",0x9ef; -"horizlinescan3",0x9f0; -"horizlinescan5",0x9f1; -"horizlinescan7",0x9f2; -"horizlinescan9",0x9f3; -"leftt",0x9f4; -"rightt",0x9f5; -"bott",0x9f6; -"topt",0x9f7; -"vertbar",0x9f8; -"emspace",0xaa1; -"enspace",0xaa2; -"em3space",0xaa3; -"em4space",0xaa4; -"digitspace",0xaa5; -"punctspace",0xaa6; -"thinspace",0xaa7; -"hairspace",0xaa8; -"emdash",0xaa9; -"endash",0xaaa; -"signifblank",0xaac; -"ellipsis",0xaae; -"doubbaselinedot",0xaaf; -"onethird",0xab0; -"twothirds",0xab1; -"onefifth",0xab2; -"twofifths",0xab3; -"threefifths",0xab4; -"fourfifths",0xab5; -"onesixth",0xab6; -"fivesixths",0xab7; -"careof",0xab8; -"figdash",0xabb; -"leftanglebracket",0xabc; -"decimalpoint",0xabd; -"rightanglebracket",0xabe; -"marker",0xabf; -"oneeighth",0xac3; -"threeeighths",0xac4; -"fiveeighths",0xac5; -"seveneighths",0xac6; -"trademark",0xac9; -"signaturemark",0xaca; -"trademarkincircle",0xacb; -"leftopentriangle",0xacc; -"rightopentriangle",0xacd; -"emopencircle",0xace; -"emopenrectangle",0xacf; -"leftsinglequotemark",0xad0; -"rightsinglequotemark",0xad1; -"leftdoublequotemark",0xad2; -"rightdoublequotemark",0xad3; -"prescription",0xad4; -"minutes",0xad6; -"seconds",0xad7; -"latincross",0xad9; -"hexagram",0xada; -"filledrectbullet",0xadb; -"filledlefttribullet",0xadc; -"filledrighttribullet",0xadd; -"emfilledcircle",0xade; -"emfilledrect",0xadf; -"enopencircbullet",0xae0; -"enopensquarebullet",0xae1; -"openrectbullet",0xae2; -"opentribulletup",0xae3; -"opentribulletdown",0xae4; -"openstar",0xae5; -"enfilledcircbullet",0xae6; -"enfilledsqbullet",0xae7; -"filledtribulletup",0xae8; -"filledtribulletdown",0xae9; -"leftpointer",0xaea; -"rightpointer",0xaeb; -"club",0xaec; -"diamond",0xaed; -"heart",0xaee; -"maltesecross",0xaf0; -"dagger",0xaf1; -"doubledagger",0xaf2; -"checkmark",0xaf3; -"ballotcross",0xaf4; -"musicalsharp",0xaf5; -"musicalflat",0xaf6; -"malesymbol",0xaf7; -"femalesymbol",0xaf8; -"telephone",0xaf9; -"telephonerecorder",0xafa; -"phonographcopyright",0xafb; -"caret",0xafc; -"singlelowquotemark",0xafd; -"doublelowquotemark",0xafe; -"cursor",0xaff; -"leftcaret",0xba3; -"rightcaret",0xba6; -"downcaret",0xba8; -"upcaret",0xba9; -"overbar",0xbc0; -"downtack",0xbc2; -"upshoe",0xbc3; -"downstile",0xbc4; -"underbar",0xbc6; -"jot",0xbca; -"quad",0xbcc; -"uptack",0xbce; -"circle",0xbcf; -"upstile",0xbd3; -"downshoe",0xbd6; -"rightshoe",0xbd8; -"leftshoe",0xbda; -"lefttack",0xbdc; -"righttack",0xbfc; -"hebrew_doublelowline",0xcdf; -"hebrew_aleph",0xce0; -"hebrew_bet",0xce1; -"hebrew_beth",0xce1; -"hebrew_gimel",0xce2; -"hebrew_gimmel",0xce2; -"hebrew_dalet",0xce3; -"hebrew_daleth",0xce3; -"hebrew_he",0xce4; -"hebrew_waw",0xce5; -"hebrew_zain",0xce6; -"hebrew_zayin",0xce6; -"hebrew_chet",0xce7; -"hebrew_het",0xce7; -"hebrew_tet",0xce8; -"hebrew_teth",0xce8; -"hebrew_yod",0xce9; -"hebrew_finalkaph",0xcea; -"hebrew_kaph",0xceb; -"hebrew_lamed",0xcec; -"hebrew_finalmem",0xced; -"hebrew_mem",0xcee; -"hebrew_finalnun",0xcef; -"hebrew_nun",0xcf0; -"hebrew_samech",0xcf1; -"hebrew_samekh",0xcf1; -"hebrew_ayin",0xcf2; -"hebrew_finalpe",0xcf3; -"hebrew_pe",0xcf4; -"hebrew_finalzade",0xcf5; -"hebrew_finalzadi",0xcf5; -"hebrew_zade",0xcf6; -"hebrew_zadi",0xcf6; -"hebrew_qoph",0xcf7; -"hebrew_kuf",0xcf7; -"hebrew_resh",0xcf8; -"hebrew_shin",0xcf9; -"hebrew_taw",0xcfa; -"hebrew_taf",0xcfa; -"Hebrew_switch",0xFF7E; -"Thai_kokai",0xda1; -"Thai_khokhai",0xda2; -"Thai_khokhuat",0xda3; -"Thai_khokhwai",0xda4; -"Thai_khokhon",0xda5; -"Thai_khorakhang",0xda6; -"Thai_ngongu",0xda7; -"Thai_chochan",0xda8; -"Thai_choching",0xda9; -"Thai_chochang",0xdaa; -"Thai_soso",0xdab; -"Thai_chochoe",0xdac; -"Thai_yoying",0xdad; -"Thai_dochada",0xdae; -"Thai_topatak",0xdaf; -"Thai_thothan",0xdb0; -"Thai_thonangmontho",0xdb1; -"Thai_thophuthao",0xdb2; -"Thai_nonen",0xdb3; -"Thai_dodek",0xdb4; -"Thai_totao",0xdb5; -"Thai_thothung",0xdb6; -"Thai_thothahan",0xdb7; -"Thai_thothong",0xdb8; -"Thai_nonu",0xdb9; -"Thai_bobaimai",0xdba; -"Thai_popla",0xdbb; -"Thai_phophung",0xdbc; -"Thai_fofa",0xdbd; -"Thai_phophan",0xdbe; -"Thai_fofan",0xdbf; -"Thai_phosamphao",0xdc0; -"Thai_moma",0xdc1; -"Thai_yoyak",0xdc2; -"Thai_rorua",0xdc3; -"Thai_ru",0xdc4; -"Thai_loling",0xdc5; -"Thai_lu",0xdc6; -"Thai_wowaen",0xdc7; -"Thai_sosala",0xdc8; -"Thai_sorusi",0xdc9; -"Thai_sosua",0xdca; -"Thai_hohip",0xdcb; -"Thai_lochula",0xdcc; -"Thai_oang",0xdcd; -"Thai_honokhuk",0xdce; -"Thai_paiyannoi",0xdcf; -"Thai_saraa",0xdd0; -"Thai_maihanakat",0xdd1; -"Thai_saraaa",0xdd2; -"Thai_saraam",0xdd3; -"Thai_sarai",0xdd4; -"Thai_saraii",0xdd5; -"Thai_saraue",0xdd6; -"Thai_sarauee",0xdd7; -"Thai_sarau",0xdd8; -"Thai_sarauu",0xdd9; -"Thai_phinthu",0xdda; -"Thai_maihanakat_maitho",0xdde; -"Thai_baht",0xddf; -"Thai_sarae",0xde0; -"Thai_saraae",0xde1; -"Thai_sarao",0xde2; -"Thai_saraaimaimuan",0xde3; -"Thai_saraaimaimalai",0xde4; -"Thai_lakkhangyao",0xde5; -"Thai_maiyamok",0xde6; -"Thai_maitaikhu",0xde7; -"Thai_maiek",0xde8; -"Thai_maitho",0xde9; -"Thai_maitri",0xdea; -"Thai_maichattawa",0xdeb; -"Thai_thanthakhat",0xdec; -"Thai_nikhahit",0xded; -"Thai_leksun",0xdf0; -"Thai_leknung",0xdf1; -"Thai_leksong",0xdf2; -"Thai_leksam",0xdf3; -"Thai_leksi",0xdf4; -"Thai_lekha",0xdf5; -"Thai_lekhok",0xdf6; -"Thai_lekchet",0xdf7; -"Thai_lekpaet",0xdf8; -"Thai_lekkao",0xdf9; -"Hangul",0xff31; -"Hangul_Start",0xff32; -"Hangul_End",0xff33; -"Hangul_Hanja",0xff34; -"Hangul_Jamo",0xff35; -"Hangul_Romaja",0xff36; -"Hangul_Codeinput",0xff37; -"Hangul_Jeonja",0xff38; -"Hangul_Banja",0xff39; -"Hangul_PreHanja",0xff3a; -"Hangul_PostHanja",0xff3b; -"Hangul_SingleCandidate",0xff3c; -"Hangul_MultipleCandidate",0xff3d; -"Hangul_PreviousCandidate",0xff3e; -"Hangul_Special",0xff3f; -"Hangul_switch",0xFF7E; -"Hangul_Kiyeog",0xea1; -"Hangul_SsangKiyeog",0xea2; -"Hangul_KiyeogSios",0xea3; -"Hangul_Nieun",0xea4; -"Hangul_NieunJieuj",0xea5; -"Hangul_NieunHieuh",0xea6; -"Hangul_Dikeud",0xea7; -"Hangul_SsangDikeud",0xea8; -"Hangul_Rieul",0xea9; -"Hangul_RieulKiyeog",0xeaa; -"Hangul_RieulMieum",0xeab; -"Hangul_RieulPieub",0xeac; -"Hangul_RieulSios",0xead; -"Hangul_RieulTieut",0xeae; -"Hangul_RieulPhieuf",0xeaf; -"Hangul_RieulHieuh",0xeb0; -"Hangul_Mieum",0xeb1; -"Hangul_Pieub",0xeb2; -"Hangul_SsangPieub",0xeb3; -"Hangul_PieubSios",0xeb4; -"Hangul_Sios",0xeb5; -"Hangul_SsangSios",0xeb6; -"Hangul_Ieung",0xeb7; -"Hangul_Jieuj",0xeb8; -"Hangul_SsangJieuj",0xeb9; -"Hangul_Cieuc",0xeba; -"Hangul_Khieuq",0xebb; -"Hangul_Tieut",0xebc; -"Hangul_Phieuf",0xebd; -"Hangul_Hieuh",0xebe; -"Hangul_A",0xebf; -"Hangul_AE",0xec0; -"Hangul_YA",0xec1; -"Hangul_YAE",0xec2; -"Hangul_EO",0xec3; -"Hangul_E",0xec4; -"Hangul_YEO",0xec5; -"Hangul_YE",0xec6; -"Hangul_O",0xec7; -"Hangul_WA",0xec8; -"Hangul_WAE",0xec9; -"Hangul_OE",0xeca; -"Hangul_YO",0xecb; -"Hangul_U",0xecc; -"Hangul_WEO",0xecd; -"Hangul_WE",0xece; -"Hangul_WI",0xecf; -"Hangul_YU",0xed0; -"Hangul_EU",0xed1; -"Hangul_YI",0xed2; -"Hangul_I",0xed3; -"Hangul_J_Kiyeog",0xed4; -"Hangul_J_SsangKiyeog",0xed5; -"Hangul_J_KiyeogSios",0xed6; -"Hangul_J_Nieun",0xed7; -"Hangul_J_NieunJieuj",0xed8; -"Hangul_J_NieunHieuh",0xed9; -"Hangul_J_Dikeud",0xeda; -"Hangul_J_Rieul",0xedb; -"Hangul_J_RieulKiyeog",0xedc; -"Hangul_J_RieulMieum",0xedd; -"Hangul_J_RieulPieub",0xede; -"Hangul_J_RieulSios",0xedf; -"Hangul_J_RieulTieut",0xee0; -"Hangul_J_RieulPhieuf",0xee1; -"Hangul_J_RieulHieuh",0xee2; -"Hangul_J_Mieum",0xee3; -"Hangul_J_Pieub",0xee4; -"Hangul_J_PieubSios",0xee5; -"Hangul_J_Sios",0xee6; -"Hangul_J_SsangSios",0xee7; -"Hangul_J_Ieung",0xee8; -"Hangul_J_Jieuj",0xee9; -"Hangul_J_Cieuc",0xeea; -"Hangul_J_Khieuq",0xeeb; -"Hangul_J_Tieut",0xeec; -"Hangul_J_Phieuf",0xeed; -"Hangul_J_Hieuh",0xeee; -"Hangul_RieulYeorinHieuh",0xeef; -"Hangul_SunkyeongeumMieum",0xef0; -"Hangul_SunkyeongeumPieub",0xef1; -"Hangul_PanSios",0xef2; -"Hangul_KkogjiDalrinIeung",0xef3; -"Hangul_SunkyeongeumPhieuf",0xef4; -"Hangul_YeorinHieuh",0xef5; -"Hangul_AraeA",0xef6; -"Hangul_AraeAE",0xef7; -"Hangul_J_PanSios",0xef8; -"Hangul_J_KkogjiDalrinIeung",0xef9; -"Hangul_J_YeorinHieuh",0xefa; -"Korean_Won",0xeff; -] -let keysym_to_name = [ -0xFFFFFF,"VoidSymbol"; -0xFF08,"BackSpace"; -0xFF09,"Tab"; -0xFF0A,"Linefeed"; -0xFF0B,"Clear"; -0xFF0D,"Return"; -0xFF13,"Pause"; -0xFF14,"Scroll_Lock"; -0xFF15,"Sys_Req"; -0xFF1B,"Escape"; -0xFFFF,"Delete"; -0xFF20,"Multi_key"; -0xFF21,"Kanji"; -0xFF22,"Muhenkan"; -0xFF23,"Henkan_Mode"; -0xFF23,"Henkan"; -0xFF24,"Romaji"; -0xFF25,"Hiragana"; -0xFF26,"Katakana"; -0xFF27,"Hiragana_Katakana"; -0xFF28,"Zenkaku"; -0xFF29,"Hankaku"; -0xFF2A,"Zenkaku_Hankaku"; -0xFF2B,"Touroku"; -0xFF2C,"Massyo"; -0xFF2D,"Kana_Lock"; -0xFF2E,"Kana_Shift"; -0xFF2F,"Eisu_Shift"; -0xFF30,"Eisu_toggle"; -0xFF50,"Home"; -0xFF51,"Left"; -0xFF52,"Up"; -0xFF53,"Right"; -0xFF54,"Down"; -0xFF55,"Prior"; -0xFF55,"Page_Up"; -0xFF56,"Next"; -0xFF56,"Page_Down"; -0xFF57,"End"; -0xFF58,"Begin"; -0xFF60,"Select"; -0xFF61,"Print"; -0xFF62,"Execute"; -0xFF63,"Insert"; -0xFF65,"Undo"; -0xFF66,"Redo"; -0xFF67,"Menu"; -0xFF68,"Find"; -0xFF69,"Cancel"; -0xFF6A,"Help"; -0xFF6B,"Break"; -0xFF7E,"Mode_switch"; -0xFF7E,"script_switch"; -0xFF7F,"Num_Lock"; -0xFF80,"KP_Space"; -0xFF89,"KP_Tab"; -0xFF8D,"KP_Enter"; -0xFF91,"KP_F1"; -0xFF92,"KP_F2"; -0xFF93,"KP_F3"; -0xFF94,"KP_F4"; -0xFF95,"KP_Home"; -0xFF96,"KP_Left"; -0xFF97,"KP_Up"; -0xFF98,"KP_Right"; -0xFF99,"KP_Down"; -0xFF9A,"KP_Prior"; -0xFF9A,"KP_Page_Up"; -0xFF9B,"KP_Next"; -0xFF9B,"KP_Page_Down"; -0xFF9C,"KP_End"; -0xFF9D,"KP_Begin"; -0xFF9E,"KP_Insert"; -0xFF9F,"KP_Delete"; -0xFFBD,"KP_Equal"; -0xFFAA,"KP_Multiply"; -0xFFAB,"KP_Add"; -0xFFAC,"KP_Separator"; -0xFFAD,"KP_Subtract"; -0xFFAE,"KP_Decimal"; -0xFFAF,"KP_Divide"; -0xFFB0,"KP_0"; -0xFFB1,"KP_1"; -0xFFB2,"KP_2"; -0xFFB3,"KP_3"; -0xFFB4,"KP_4"; -0xFFB5,"KP_5"; -0xFFB6,"KP_6"; -0xFFB7,"KP_7"; -0xFFB8,"KP_8"; -0xFFB9,"KP_9"; -0xFFBE,"F1"; -0xFFBF,"F2"; -0xFFC0,"F3"; -0xFFC1,"F4"; -0xFFC2,"F5"; -0xFFC3,"F6"; -0xFFC4,"F7"; -0xFFC5,"F8"; -0xFFC6,"F9"; -0xFFC7,"F10"; -0xFFC8,"F11"; -0xFFC8,"L1"; -0xFFC9,"F12"; -0xFFC9,"L2"; -0xFFCA,"F13"; -0xFFCA,"L3"; -0xFFCB,"F14"; -0xFFCB,"L4"; -0xFFCC,"F15"; -0xFFCC,"L5"; -0xFFCD,"F16"; -0xFFCD,"L6"; -0xFFCE,"F17"; -0xFFCE,"L7"; -0xFFCF,"F18"; -0xFFCF,"L8"; -0xFFD0,"F19"; -0xFFD0,"L9"; -0xFFD1,"F20"; -0xFFD1,"L10"; -0xFFD2,"F21"; -0xFFD2,"R1"; -0xFFD3,"F22"; -0xFFD3,"R2"; -0xFFD4,"F23"; -0xFFD4,"R3"; -0xFFD5,"F24"; -0xFFD5,"R4"; -0xFFD6,"F25"; -0xFFD6,"R5"; -0xFFD7,"F26"; -0xFFD7,"R6"; -0xFFD8,"F27"; -0xFFD8,"R7"; -0xFFD9,"F28"; -0xFFD9,"R8"; -0xFFDA,"F29"; -0xFFDA,"R9"; -0xFFDB,"F30"; -0xFFDB,"R10"; -0xFFDC,"F31"; -0xFFDC,"R11"; -0xFFDD,"F32"; -0xFFDD,"R12"; -0xFFDE,"F33"; -0xFFDE,"R13"; -0xFFDF,"F34"; -0xFFDF,"R14"; -0xFFE0,"F35"; -0xFFE0,"R15"; -0xFFE1,"Shift_L"; -0xFFE2,"Shift_R"; -0xFFE3,"Control_L"; -0xFFE4,"Control_R"; -0xFFE5,"Caps_Lock"; -0xFFE6,"Shift_Lock"; -0xFFE7,"Meta_L"; -0xFFE8,"Meta_R"; -0xFFE9,"Alt_L"; -0xFFEA,"Alt_R"; -0xFFEB,"Super_L"; -0xFFEC,"Super_R"; -0xFFED,"Hyper_L"; -0xFFEE,"Hyper_R"; -0xFE01,"ISO_Lock"; -0xFE02,"ISO_Level2_Latch"; -0xFE03,"ISO_Level3_Shift"; -0xFE04,"ISO_Level3_Latch"; -0xFE05,"ISO_Level3_Lock"; -0xFF7E,"ISO_Group_Shift"; -0xFE06,"ISO_Group_Latch"; -0xFE07,"ISO_Group_Lock"; -0xFE08,"ISO_Next_Group"; -0xFE09,"ISO_Next_Group_Lock"; -0xFE0A,"ISO_Prev_Group"; -0xFE0B,"ISO_Prev_Group_Lock"; -0xFE0C,"ISO_First_Group"; -0xFE0D,"ISO_First_Group_Lock"; -0xFE0E,"ISO_Last_Group"; -0xFE0F,"ISO_Last_Group_Lock"; -0xFE20,"ISO_Left_Tab"; -0xFE21,"ISO_Move_Line_Up"; -0xFE22,"ISO_Move_Line_Down"; -0xFE23,"ISO_Partial_Line_Up"; -0xFE24,"ISO_Partial_Line_Down"; -0xFE25,"ISO_Partial_Space_Left"; -0xFE26,"ISO_Partial_Space_Right"; -0xFE27,"ISO_Set_Margin_Left"; -0xFE28,"ISO_Set_Margin_Right"; -0xFE29,"ISO_Release_Margin_Left"; -0xFE2A,"ISO_Release_Margin_Right"; -0xFE2B,"ISO_Release_Both_Margins"; -0xFE2C,"ISO_Fast_Cursor_Left"; -0xFE2D,"ISO_Fast_Cursor_Right"; -0xFE2E,"ISO_Fast_Cursor_Up"; -0xFE2F,"ISO_Fast_Cursor_Down"; -0xFE30,"ISO_Continuous_Underline"; -0xFE31,"ISO_Discontinuous_Underline"; -0xFE32,"ISO_Emphasize"; -0xFE33,"ISO_Center_Object"; -0xFE34,"ISO_Enter"; -0xFE50,"dead_grave"; -0xFE51,"dead_acute"; -0xFE52,"dead_circumflex"; -0xFE53,"dead_tilde"; -0xFE54,"dead_macron"; -0xFE55,"dead_breve"; -0xFE56,"dead_abovedot"; -0xFE57,"dead_diaeresis"; -0xFE58,"dead_abovering"; -0xFE59,"dead_doubleacute"; -0xFE5A,"dead_caron"; -0xFE5B,"dead_cedilla"; -0xFE5C,"dead_ogonek"; -0xFE5D,"dead_iota"; -0xFE5E,"dead_voiced_sound"; -0xFE5F,"dead_semivoiced_sound"; -0xFE60,"dead_belowdot"; -0xFED0,"First_Virtual_Screen"; -0xFED1,"Prev_Virtual_Screen"; -0xFED2,"Next_Virtual_Screen"; -0xFED4,"Last_Virtual_Screen"; -0xFED5,"Terminate_Server"; -0xFE70,"AccessX_Enable"; -0xFE71,"AccessX_Feedback_Enable"; -0xFE72,"RepeatKeys_Enable"; -0xFE73,"SlowKeys_Enable"; -0xFE74,"BounceKeys_Enable"; -0xFE75,"StickyKeys_Enable"; -0xFE76,"MouseKeys_Enable"; -0xFE77,"MouseKeys_Accel_Enable"; -0xFE78,"Overlay1_Enable"; -0xFE79,"Overlay2_Enable"; -0xFE7A,"AudibleBell_Enable"; -0xFEE0,"Pointer_Left"; -0xFEE1,"Pointer_Right"; -0xFEE2,"Pointer_Up"; -0xFEE3,"Pointer_Down"; -0xFEE4,"Pointer_UpLeft"; -0xFEE5,"Pointer_UpRight"; -0xFEE6,"Pointer_DownLeft"; -0xFEE7,"Pointer_DownRight"; -0xFEE8,"Pointer_Button_Dflt"; -0xFEE9,"Pointer_Button1"; -0xFEEA,"Pointer_Button2"; -0xFEEB,"Pointer_Button3"; -0xFEEC,"Pointer_Button4"; -0xFEED,"Pointer_Button5"; -0xFEEE,"Pointer_DblClick_Dflt"; -0xFEEF,"Pointer_DblClick1"; -0xFEF0,"Pointer_DblClick2"; -0xFEF1,"Pointer_DblClick3"; -0xFEF2,"Pointer_DblClick4"; -0xFEF3,"Pointer_DblClick5"; -0xFEF4,"Pointer_Drag_Dflt"; -0xFEF5,"Pointer_Drag1"; -0xFEF6,"Pointer_Drag2"; -0xFEF7,"Pointer_Drag3"; -0xFEF8,"Pointer_Drag4"; -0xFEFD,"Pointer_Drag5"; -0xFEF9,"Pointer_EnableKeys"; -0xFEFA,"Pointer_Accelerate"; -0xFEFB,"Pointer_DfltBtnNext"; -0xFEFC,"Pointer_DfltBtnPrev"; -0xFD01,"3270_Duplicate"; -0xFD02,"3270_FieldMark"; -0xFD03,"3270_Right2"; -0xFD04,"3270_Left2"; -0xFD05,"3270_BackTab"; -0xFD06,"3270_EraseEOF"; -0xFD07,"3270_EraseInput"; -0xFD08,"3270_Reset"; -0xFD09,"3270_Quit"; -0xFD0A,"3270_PA1"; -0xFD0B,"3270_PA2"; -0xFD0C,"3270_PA3"; -0xFD0D,"3270_Test"; -0xFD0E,"3270_Attn"; -0xFD0F,"3270_CursorBlink"; -0xFD10,"3270_AltCursor"; -0xFD11,"3270_KeyClick"; -0xFD12,"3270_Jump"; -0xFD13,"3270_Ident"; -0xFD14,"3270_Rule"; -0xFD15,"3270_Copy"; -0xFD16,"3270_Play"; -0xFD17,"3270_Setup"; -0xFD18,"3270_Record"; -0xFD19,"3270_ChangeScreen"; -0xFD1A,"3270_DeleteWord"; -0xFD1B,"3270_ExSelect"; -0xFD1C,"3270_CursorSelect"; -0xFD1D,"3270_PrintScreen"; -0xFD1E,"3270_Enter"; -0x020,"space"; -0x021,"exclam"; -0x022,"quotedbl"; -0x023,"numbersign"; -0x024,"dollar"; -0x025,"percent"; -0x026,"ampersand"; -0x027,"apostrophe"; -0x027,"quoteright"; -0x028,"parenleft"; -0x029,"parenright"; -0x02a,"asterisk"; -0x02b,"plus"; -0x02c,"comma"; -0x02d,"minus"; -0x02e,"period"; -0x02f,"slash"; -0x030,"0"; -0x031,"1"; -0x032,"2"; -0x033,"3"; -0x034,"4"; -0x035,"5"; -0x036,"6"; -0x037,"7"; -0x038,"8"; -0x039,"9"; -0x03a,"colon"; -0x03b,"semicolon"; -0x03c,"less"; -0x03d,"equal"; -0x03e,"greater"; -0x03f,"question"; -0x040,"at"; -0x041,"A"; -0x042,"B"; -0x043,"C"; -0x044,"D"; -0x045,"E"; -0x046,"F"; -0x047,"G"; -0x048,"H"; -0x049,"I"; -0x04a,"J"; -0x04b,"K"; -0x04c,"L"; -0x04d,"M"; -0x04e,"N"; -0x04f,"O"; -0x050,"P"; -0x051,"Q"; -0x052,"R"; -0x053,"S"; -0x054,"T"; -0x055,"U"; -0x056,"V"; -0x057,"W"; -0x058,"X"; -0x059,"Y"; -0x05a,"Z"; -0x05b,"bracketleft"; -0x05c,"backslash"; -0x05d,"bracketright"; -0x05e,"asciicircum"; -0x05f,"underscore"; -0x060,"grave"; -0x060,"quoteleft"; -0x061,"a"; -0x062,"b"; -0x063,"c"; -0x064,"d"; -0x065,"e"; -0x066,"f"; -0x067,"g"; -0x068,"h"; -0x069,"i"; -0x06a,"j"; -0x06b,"k"; -0x06c,"l"; -0x06d,"m"; -0x06e,"n"; -0x06f,"o"; -0x070,"p"; -0x071,"q"; -0x072,"r"; -0x073,"s"; -0x074,"t"; -0x075,"u"; -0x076,"v"; -0x077,"w"; -0x078,"x"; -0x079,"y"; -0x07a,"z"; -0x07b,"braceleft"; -0x07c,"bar"; -0x07d,"braceright"; -0x07e,"asciitilde"; -0x0a0,"nobreakspace"; -0x0a1,"exclamdown"; -0x0a2,"cent"; -0x0a3,"sterling"; -0x0a4,"currency"; -0x0a5,"yen"; -0x0a6,"brokenbar"; -0x0a7,"section"; -0x0a8,"diaeresis"; -0x0a9,"copyright"; -0x0aa,"ordfeminine"; -0x0ab,"guillemotleft"; -0x0ac,"notsign"; -0x0ad,"hyphen"; -0x0ae,"registered"; -0x0af,"macron"; -0x0b0,"degree"; -0x0b1,"plusminus"; -0x0b2,"twosuperior"; -0x0b3,"threesuperior"; -0x0b4,"acute"; -0x0b5,"mu"; -0x0b6,"paragraph"; -0x0b7,"periodcentered"; -0x0b8,"cedilla"; -0x0b9,"onesuperior"; -0x0ba,"masculine"; -0x0bb,"guillemotright"; -0x0bc,"onequarter"; -0x0bd,"onehalf"; -0x0be,"threequarters"; -0x0bf,"questiondown"; -0x0c0,"Agrave"; -0x0c1,"Aacute"; -0x0c2,"Acircumflex"; -0x0c3,"Atilde"; -0x0c4,"Adiaeresis"; -0x0c5,"Aring"; -0x0c6,"AE"; -0x0c7,"Ccedilla"; -0x0c8,"Egrave"; -0x0c9,"Eacute"; -0x0ca,"Ecircumflex"; -0x0cb,"Ediaeresis"; -0x0cc,"Igrave"; -0x0cd,"Iacute"; -0x0ce,"Icircumflex"; -0x0cf,"Idiaeresis"; -0x0d0,"ETH"; -0x0d0,"Eth"; -0x0d1,"Ntilde"; -0x0d2,"Ograve"; -0x0d3,"Oacute"; -0x0d4,"Ocircumflex"; -0x0d5,"Otilde"; -0x0d6,"Odiaeresis"; -0x0d7,"multiply"; -0x0d8,"Ooblique"; -0x0d9,"Ugrave"; -0x0da,"Uacute"; -0x0db,"Ucircumflex"; -0x0dc,"Udiaeresis"; -0x0dd,"Yacute"; -0x0de,"THORN"; -0x0de,"Thorn"; -0x0df,"ssharp"; -0x0e0,"agrave"; -0x0e1,"aacute"; -0x0e2,"acircumflex"; -0x0e3,"atilde"; -0x0e4,"adiaeresis"; -0x0e5,"aring"; -0x0e6,"ae"; -0x0e7,"ccedilla"; -0x0e8,"egrave"; -0x0e9,"eacute"; -0x0ea,"ecircumflex"; -0x0eb,"ediaeresis"; -0x0ec,"igrave"; -0x0ed,"iacute"; -0x0ee,"icircumflex"; -0x0ef,"idiaeresis"; -0x0f0,"eth"; -0x0f1,"ntilde"; -0x0f2,"ograve"; -0x0f3,"oacute"; -0x0f4,"ocircumflex"; -0x0f5,"otilde"; -0x0f6,"odiaeresis"; -0x0f7,"division"; -0x0f8,"oslash"; -0x0f9,"ugrave"; -0x0fa,"uacute"; -0x0fb,"ucircumflex"; -0x0fc,"udiaeresis"; -0x0fd,"yacute"; -0x0fe,"thorn"; -0x0ff,"ydiaeresis"; -0x1a1,"Aogonek"; -0x1a2,"breve"; -0x1a3,"Lstroke"; -0x1a5,"Lcaron"; -0x1a6,"Sacute"; -0x1a9,"Scaron"; -0x1aa,"Scedilla"; -0x1ab,"Tcaron"; -0x1ac,"Zacute"; -0x1ae,"Zcaron"; -0x1af,"Zabovedot"; -0x1b1,"aogonek"; -0x1b2,"ogonek"; -0x1b3,"lstroke"; -0x1b5,"lcaron"; -0x1b6,"sacute"; -0x1b7,"caron"; -0x1b9,"scaron"; -0x1ba,"scedilla"; -0x1bb,"tcaron"; -0x1bc,"zacute"; -0x1bd,"doubleacute"; -0x1be,"zcaron"; -0x1bf,"zabovedot"; -0x1c0,"Racute"; -0x1c3,"Abreve"; -0x1c5,"Lacute"; -0x1c6,"Cacute"; -0x1c8,"Ccaron"; -0x1ca,"Eogonek"; -0x1cc,"Ecaron"; -0x1cf,"Dcaron"; -0x1d0,"Dstroke"; -0x1d1,"Nacute"; -0x1d2,"Ncaron"; -0x1d5,"Odoubleacute"; -0x1d8,"Rcaron"; -0x1d9,"Uring"; -0x1db,"Udoubleacute"; -0x1de,"Tcedilla"; -0x1e0,"racute"; -0x1e3,"abreve"; -0x1e5,"lacute"; -0x1e6,"cacute"; -0x1e8,"ccaron"; -0x1ea,"eogonek"; -0x1ec,"ecaron"; -0x1ef,"dcaron"; -0x1f0,"dstroke"; -0x1f1,"nacute"; -0x1f2,"ncaron"; -0x1f5,"odoubleacute"; -0x1fb,"udoubleacute"; -0x1f8,"rcaron"; -0x1f9,"uring"; -0x1fe,"tcedilla"; -0x1ff,"abovedot"; -0x2a1,"Hstroke"; -0x2a6,"Hcircumflex"; -0x2a9,"Iabovedot"; -0x2ab,"Gbreve"; -0x2ac,"Jcircumflex"; -0x2b1,"hstroke"; -0x2b6,"hcircumflex"; -0x2b9,"idotless"; -0x2bb,"gbreve"; -0x2bc,"jcircumflex"; -0x2c5,"Cabovedot"; -0x2c6,"Ccircumflex"; -0x2d5,"Gabovedot"; -0x2d8,"Gcircumflex"; -0x2dd,"Ubreve"; -0x2de,"Scircumflex"; -0x2e5,"cabovedot"; -0x2e6,"ccircumflex"; -0x2f5,"gabovedot"; -0x2f8,"gcircumflex"; -0x2fd,"ubreve"; -0x2fe,"scircumflex"; -0x3a2,"kra"; -0x3a2,"kappa"; -0x3a3,"Rcedilla"; -0x3a5,"Itilde"; -0x3a6,"Lcedilla"; -0x3aa,"Emacron"; -0x3ab,"Gcedilla"; -0x3ac,"Tslash"; -0x3b3,"rcedilla"; -0x3b5,"itilde"; -0x3b6,"lcedilla"; -0x3ba,"emacron"; -0x3bb,"gcedilla"; -0x3bc,"tslash"; -0x3bd,"ENG"; -0x3bf,"eng"; -0x3c0,"Amacron"; -0x3c7,"Iogonek"; -0x3cc,"Eabovedot"; -0x3cf,"Imacron"; -0x3d1,"Ncedilla"; -0x3d2,"Omacron"; -0x3d3,"Kcedilla"; -0x3d9,"Uogonek"; -0x3dd,"Utilde"; -0x3de,"Umacron"; -0x3e0,"amacron"; -0x3e7,"iogonek"; -0x3ec,"eabovedot"; -0x3ef,"imacron"; -0x3f1,"ncedilla"; -0x3f2,"omacron"; -0x3f3,"kcedilla"; -0x3f9,"uogonek"; -0x3fd,"utilde"; -0x3fe,"umacron"; -0x47e,"overline"; -0x4a1,"kana_fullstop"; -0x4a2,"kana_openingbracket"; -0x4a3,"kana_closingbracket"; -0x4a4,"kana_comma"; -0x4a5,"kana_conjunctive"; -0x4a5,"kana_middledot"; -0x4a6,"kana_WO"; -0x4a7,"kana_a"; -0x4a8,"kana_i"; -0x4a9,"kana_u"; -0x4aa,"kana_e"; -0x4ab,"kana_o"; -0x4ac,"kana_ya"; -0x4ad,"kana_yu"; -0x4ae,"kana_yo"; -0x4af,"kana_tsu"; -0x4af,"kana_tu"; -0x4b0,"prolongedsound"; -0x4b1,"kana_A"; -0x4b2,"kana_I"; -0x4b3,"kana_U"; -0x4b4,"kana_E"; -0x4b5,"kana_O"; -0x4b6,"kana_KA"; -0x4b7,"kana_KI"; -0x4b8,"kana_KU"; -0x4b9,"kana_KE"; -0x4ba,"kana_KO"; -0x4bb,"kana_SA"; -0x4bc,"kana_SHI"; -0x4bd,"kana_SU"; -0x4be,"kana_SE"; -0x4bf,"kana_SO"; -0x4c0,"kana_TA"; -0x4c1,"kana_CHI"; -0x4c1,"kana_TI"; -0x4c2,"kana_TSU"; -0x4c2,"kana_TU"; -0x4c3,"kana_TE"; -0x4c4,"kana_TO"; -0x4c5,"kana_NA"; -0x4c6,"kana_NI"; -0x4c7,"kana_NU"; -0x4c8,"kana_NE"; -0x4c9,"kana_NO"; -0x4ca,"kana_HA"; -0x4cb,"kana_HI"; -0x4cc,"kana_FU"; -0x4cc,"kana_HU"; -0x4cd,"kana_HE"; -0x4ce,"kana_HO"; -0x4cf,"kana_MA"; -0x4d0,"kana_MI"; -0x4d1,"kana_MU"; -0x4d2,"kana_ME"; -0x4d3,"kana_MO"; -0x4d4,"kana_YA"; -0x4d5,"kana_YU"; -0x4d6,"kana_YO"; -0x4d7,"kana_RA"; -0x4d8,"kana_RI"; -0x4d9,"kana_RU"; -0x4da,"kana_RE"; -0x4db,"kana_RO"; -0x4dc,"kana_WA"; -0x4dd,"kana_N"; -0x4de,"voicedsound"; -0x4df,"semivoicedsound"; -0xFF7E,"kana_switch"; -0x5ac,"Arabic_comma"; -0x5bb,"Arabic_semicolon"; -0x5bf,"Arabic_question_mark"; -0x5c1,"Arabic_hamza"; -0x5c2,"Arabic_maddaonalef"; -0x5c3,"Arabic_hamzaonalef"; -0x5c4,"Arabic_hamzaonwaw"; -0x5c5,"Arabic_hamzaunderalef"; -0x5c6,"Arabic_hamzaonyeh"; -0x5c7,"Arabic_alef"; -0x5c8,"Arabic_beh"; -0x5c9,"Arabic_tehmarbuta"; -0x5ca,"Arabic_teh"; -0x5cb,"Arabic_theh"; -0x5cc,"Arabic_jeem"; -0x5cd,"Arabic_hah"; -0x5ce,"Arabic_khah"; -0x5cf,"Arabic_dal"; -0x5d0,"Arabic_thal"; -0x5d1,"Arabic_ra"; -0x5d2,"Arabic_zain"; -0x5d3,"Arabic_seen"; -0x5d4,"Arabic_sheen"; -0x5d5,"Arabic_sad"; -0x5d6,"Arabic_dad"; -0x5d7,"Arabic_tah"; -0x5d8,"Arabic_zah"; -0x5d9,"Arabic_ain"; -0x5da,"Arabic_ghain"; -0x5e0,"Arabic_tatweel"; -0x5e1,"Arabic_feh"; -0x5e2,"Arabic_qaf"; -0x5e3,"Arabic_kaf"; -0x5e4,"Arabic_lam"; -0x5e5,"Arabic_meem"; -0x5e6,"Arabic_noon"; -0x5e7,"Arabic_ha"; -0x5e7,"Arabic_heh"; -0x5e8,"Arabic_waw"; -0x5e9,"Arabic_alefmaksura"; -0x5ea,"Arabic_yeh"; -0x5eb,"Arabic_fathatan"; -0x5ec,"Arabic_dammatan"; -0x5ed,"Arabic_kasratan"; -0x5ee,"Arabic_fatha"; -0x5ef,"Arabic_damma"; -0x5f0,"Arabic_kasra"; -0x5f1,"Arabic_shadda"; -0x5f2,"Arabic_sukun"; -0xFF7E,"Arabic_switch"; -0x6a1,"Serbian_dje"; -0x6a2,"Macedonia_gje"; -0x6a3,"Cyrillic_io"; -0x6a4,"Ukrainian_ie"; -0x6a4,"Ukranian_je"; -0x6a5,"Macedonia_dse"; -0x6a6,"Ukrainian_i"; -0x6a6,"Ukranian_i"; -0x6a7,"Ukrainian_yi"; -0x6a7,"Ukranian_yi"; -0x6a8,"Cyrillic_je"; -0x6a8,"Serbian_je"; -0x6a9,"Cyrillic_lje"; -0x6a9,"Serbian_lje"; -0x6aa,"Cyrillic_nje"; -0x6aa,"Serbian_nje"; -0x6ab,"Serbian_tshe"; -0x6ac,"Macedonia_kje"; -0x6ae,"Byelorussian_shortu"; -0x6af,"Cyrillic_dzhe"; -0x6af,"Serbian_dze"; -0x6b0,"numerosign"; -0x6b1,"Serbian_DJE"; -0x6b2,"Macedonia_GJE"; -0x6b3,"Cyrillic_IO"; -0x6b4,"Ukrainian_IE"; -0x6b4,"Ukranian_JE"; -0x6b5,"Macedonia_DSE"; -0x6b6,"Ukrainian_I"; -0x6b6,"Ukranian_I"; -0x6b7,"Ukrainian_YI"; -0x6b7,"Ukranian_YI"; -0x6b8,"Cyrillic_JE"; -0x6b8,"Serbian_JE"; -0x6b9,"Cyrillic_LJE"; -0x6b9,"Serbian_LJE"; -0x6ba,"Cyrillic_NJE"; -0x6ba,"Serbian_NJE"; -0x6bb,"Serbian_TSHE"; -0x6bc,"Macedonia_KJE"; -0x6be,"Byelorussian_SHORTU"; -0x6bf,"Cyrillic_DZHE"; -0x6bf,"Serbian_DZE"; -0x6c0,"Cyrillic_yu"; -0x6c1,"Cyrillic_a"; -0x6c2,"Cyrillic_be"; -0x6c3,"Cyrillic_tse"; -0x6c4,"Cyrillic_de"; -0x6c5,"Cyrillic_ie"; -0x6c6,"Cyrillic_ef"; -0x6c7,"Cyrillic_ghe"; -0x6c8,"Cyrillic_ha"; -0x6c9,"Cyrillic_i"; -0x6ca,"Cyrillic_shorti"; -0x6cb,"Cyrillic_ka"; -0x6cc,"Cyrillic_el"; -0x6cd,"Cyrillic_em"; -0x6ce,"Cyrillic_en"; -0x6cf,"Cyrillic_o"; -0x6d0,"Cyrillic_pe"; -0x6d1,"Cyrillic_ya"; -0x6d2,"Cyrillic_er"; -0x6d3,"Cyrillic_es"; -0x6d4,"Cyrillic_te"; -0x6d5,"Cyrillic_u"; -0x6d6,"Cyrillic_zhe"; -0x6d7,"Cyrillic_ve"; -0x6d8,"Cyrillic_softsign"; -0x6d9,"Cyrillic_yeru"; -0x6da,"Cyrillic_ze"; -0x6db,"Cyrillic_sha"; -0x6dc,"Cyrillic_e"; -0x6dd,"Cyrillic_shcha"; -0x6de,"Cyrillic_che"; -0x6df,"Cyrillic_hardsign"; -0x6e0,"Cyrillic_YU"; -0x6e1,"Cyrillic_A"; -0x6e2,"Cyrillic_BE"; -0x6e3,"Cyrillic_TSE"; -0x6e4,"Cyrillic_DE"; -0x6e5,"Cyrillic_IE"; -0x6e6,"Cyrillic_EF"; -0x6e7,"Cyrillic_GHE"; -0x6e8,"Cyrillic_HA"; -0x6e9,"Cyrillic_I"; -0x6ea,"Cyrillic_SHORTI"; -0x6eb,"Cyrillic_KA"; -0x6ec,"Cyrillic_EL"; -0x6ed,"Cyrillic_EM"; -0x6ee,"Cyrillic_EN"; -0x6ef,"Cyrillic_O"; -0x6f0,"Cyrillic_PE"; -0x6f1,"Cyrillic_YA"; -0x6f2,"Cyrillic_ER"; -0x6f3,"Cyrillic_ES"; -0x6f4,"Cyrillic_TE"; -0x6f5,"Cyrillic_U"; -0x6f6,"Cyrillic_ZHE"; -0x6f7,"Cyrillic_VE"; -0x6f8,"Cyrillic_SOFTSIGN"; -0x6f9,"Cyrillic_YERU"; -0x6fa,"Cyrillic_ZE"; -0x6fb,"Cyrillic_SHA"; -0x6fc,"Cyrillic_E"; -0x6fd,"Cyrillic_SHCHA"; -0x6fe,"Cyrillic_CHE"; -0x6ff,"Cyrillic_HARDSIGN"; -0x7a1,"Greek_ALPHAaccent"; -0x7a2,"Greek_EPSILONaccent"; -0x7a3,"Greek_ETAaccent"; -0x7a4,"Greek_IOTAaccent"; -0x7a5,"Greek_IOTAdiaeresis"; -0x7a7,"Greek_OMICRONaccent"; -0x7a8,"Greek_UPSILONaccent"; -0x7a9,"Greek_UPSILONdieresis"; -0x7ab,"Greek_OMEGAaccent"; -0x7ae,"Greek_accentdieresis"; -0x7af,"Greek_horizbar"; -0x7b1,"Greek_alphaaccent"; -0x7b2,"Greek_epsilonaccent"; -0x7b3,"Greek_etaaccent"; -0x7b4,"Greek_iotaaccent"; -0x7b5,"Greek_iotadieresis"; -0x7b6,"Greek_iotaaccentdieresis"; -0x7b7,"Greek_omicronaccent"; -0x7b8,"Greek_upsilonaccent"; -0x7b9,"Greek_upsilondieresis"; -0x7ba,"Greek_upsilonaccentdieresis"; -0x7bb,"Greek_omegaaccent"; -0x7c1,"Greek_ALPHA"; -0x7c2,"Greek_BETA"; -0x7c3,"Greek_GAMMA"; -0x7c4,"Greek_DELTA"; -0x7c5,"Greek_EPSILON"; -0x7c6,"Greek_ZETA"; -0x7c7,"Greek_ETA"; -0x7c8,"Greek_THETA"; -0x7c9,"Greek_IOTA"; -0x7ca,"Greek_KAPPA"; -0x7cb,"Greek_LAMDA"; -0x7cb,"Greek_LAMBDA"; -0x7cc,"Greek_MU"; -0x7cd,"Greek_NU"; -0x7ce,"Greek_XI"; -0x7cf,"Greek_OMICRON"; -0x7d0,"Greek_PI"; -0x7d1,"Greek_RHO"; -0x7d2,"Greek_SIGMA"; -0x7d4,"Greek_TAU"; -0x7d5,"Greek_UPSILON"; -0x7d6,"Greek_PHI"; -0x7d7,"Greek_CHI"; -0x7d8,"Greek_PSI"; -0x7d9,"Greek_OMEGA"; -0x7e1,"Greek_alpha"; -0x7e2,"Greek_beta"; -0x7e3,"Greek_gamma"; -0x7e4,"Greek_delta"; -0x7e5,"Greek_epsilon"; -0x7e6,"Greek_zeta"; -0x7e7,"Greek_eta"; -0x7e8,"Greek_theta"; -0x7e9,"Greek_iota"; -0x7ea,"Greek_kappa"; -0x7eb,"Greek_lamda"; -0x7eb,"Greek_lambda"; -0x7ec,"Greek_mu"; -0x7ed,"Greek_nu"; -0x7ee,"Greek_xi"; -0x7ef,"Greek_omicron"; -0x7f0,"Greek_pi"; -0x7f1,"Greek_rho"; -0x7f2,"Greek_sigma"; -0x7f3,"Greek_finalsmallsigma"; -0x7f4,"Greek_tau"; -0x7f5,"Greek_upsilon"; -0x7f6,"Greek_phi"; -0x7f7,"Greek_chi"; -0x7f8,"Greek_psi"; -0x7f9,"Greek_omega"; -0xFF7E,"Greek_switch"; -0x8a1,"leftradical"; -0x8a2,"topleftradical"; -0x8a3,"horizconnector"; -0x8a4,"topintegral"; -0x8a5,"botintegral"; -0x8a6,"vertconnector"; -0x8a7,"topleftsqbracket"; -0x8a8,"botleftsqbracket"; -0x8a9,"toprightsqbracket"; -0x8aa,"botrightsqbracket"; -0x8ab,"topleftparens"; -0x8ac,"botleftparens"; -0x8ad,"toprightparens"; -0x8ae,"botrightparens"; -0x8af,"leftmiddlecurlybrace"; -0x8b0,"rightmiddlecurlybrace"; -0x8b1,"topleftsummation"; -0x8b2,"botleftsummation"; -0x8b3,"topvertsummationconnector"; -0x8b4,"botvertsummationconnector"; -0x8b5,"toprightsummation"; -0x8b6,"botrightsummation"; -0x8b7,"rightmiddlesummation"; -0x8bc,"lessthanequal"; -0x8bd,"notequal"; -0x8be,"greaterthanequal"; -0x8bf,"integral"; -0x8c0,"therefore"; -0x8c1,"variation"; -0x8c2,"infinity"; -0x8c5,"nabla"; -0x8c8,"approximate"; -0x8c9,"similarequal"; -0x8cd,"ifonlyif"; -0x8ce,"implies"; -0x8cf,"identical"; -0x8d6,"radical"; -0x8da,"includedin"; -0x8db,"includes"; -0x8dc,"intersection"; -0x8dd,"union"; -0x8de,"logicaland"; -0x8df,"logicalor"; -0x8ef,"partialderivative"; -0x8f6,"function"; -0x8fb,"leftarrow"; -0x8fc,"uparrow"; -0x8fd,"rightarrow"; -0x8fe,"downarrow"; -0x9df,"blank"; -0x9e0,"soliddiamond"; -0x9e1,"checkerboard"; -0x9e2,"ht"; -0x9e3,"ff"; -0x9e4,"cr"; -0x9e5,"lf"; -0x9e8,"nl"; -0x9e9,"vt"; -0x9ea,"lowrightcorner"; -0x9eb,"uprightcorner"; -0x9ec,"upleftcorner"; -0x9ed,"lowleftcorner"; -0x9ee,"crossinglines"; -0x9ef,"horizlinescan1"; -0x9f0,"horizlinescan3"; -0x9f1,"horizlinescan5"; -0x9f2,"horizlinescan7"; -0x9f3,"horizlinescan9"; -0x9f4,"leftt"; -0x9f5,"rightt"; -0x9f6,"bott"; -0x9f7,"topt"; -0x9f8,"vertbar"; -0xaa1,"emspace"; -0xaa2,"enspace"; -0xaa3,"em3space"; -0xaa4,"em4space"; -0xaa5,"digitspace"; -0xaa6,"punctspace"; -0xaa7,"thinspace"; -0xaa8,"hairspace"; -0xaa9,"emdash"; -0xaaa,"endash"; -0xaac,"signifblank"; -0xaae,"ellipsis"; -0xaaf,"doubbaselinedot"; -0xab0,"onethird"; -0xab1,"twothirds"; -0xab2,"onefifth"; -0xab3,"twofifths"; -0xab4,"threefifths"; -0xab5,"fourfifths"; -0xab6,"onesixth"; -0xab7,"fivesixths"; -0xab8,"careof"; -0xabb,"figdash"; -0xabc,"leftanglebracket"; -0xabd,"decimalpoint"; -0xabe,"rightanglebracket"; -0xabf,"marker"; -0xac3,"oneeighth"; -0xac4,"threeeighths"; -0xac5,"fiveeighths"; -0xac6,"seveneighths"; -0xac9,"trademark"; -0xaca,"signaturemark"; -0xacb,"trademarkincircle"; -0xacc,"leftopentriangle"; -0xacd,"rightopentriangle"; -0xace,"emopencircle"; -0xacf,"emopenrectangle"; -0xad0,"leftsinglequotemark"; -0xad1,"rightsinglequotemark"; -0xad2,"leftdoublequotemark"; -0xad3,"rightdoublequotemark"; -0xad4,"prescription"; -0xad6,"minutes"; -0xad7,"seconds"; -0xad9,"latincross"; -0xada,"hexagram"; -0xadb,"filledrectbullet"; -0xadc,"filledlefttribullet"; -0xadd,"filledrighttribullet"; -0xade,"emfilledcircle"; -0xadf,"emfilledrect"; -0xae0,"enopencircbullet"; -0xae1,"enopensquarebullet"; -0xae2,"openrectbullet"; -0xae3,"opentribulletup"; -0xae4,"opentribulletdown"; -0xae5,"openstar"; -0xae6,"enfilledcircbullet"; -0xae7,"enfilledsqbullet"; -0xae8,"filledtribulletup"; -0xae9,"filledtribulletdown"; -0xaea,"leftpointer"; -0xaeb,"rightpointer"; -0xaec,"club"; -0xaed,"diamond"; -0xaee,"heart"; -0xaf0,"maltesecross"; -0xaf1,"dagger"; -0xaf2,"doubledagger"; -0xaf3,"checkmark"; -0xaf4,"ballotcross"; -0xaf5,"musicalsharp"; -0xaf6,"musicalflat"; -0xaf7,"malesymbol"; -0xaf8,"femalesymbol"; -0xaf9,"telephone"; -0xafa,"telephonerecorder"; -0xafb,"phonographcopyright"; -0xafc,"caret"; -0xafd,"singlelowquotemark"; -0xafe,"doublelowquotemark"; -0xaff,"cursor"; -0xba3,"leftcaret"; -0xba6,"rightcaret"; -0xba8,"downcaret"; -0xba9,"upcaret"; -0xbc0,"overbar"; -0xbc2,"downtack"; -0xbc3,"upshoe"; -0xbc4,"downstile"; -0xbc6,"underbar"; -0xbca,"jot"; -0xbcc,"quad"; -0xbce,"uptack"; -0xbcf,"circle"; -0xbd3,"upstile"; -0xbd6,"downshoe"; -0xbd8,"rightshoe"; -0xbda,"leftshoe"; -0xbdc,"lefttack"; -0xbfc,"righttack"; -0xcdf,"hebrew_doublelowline"; -0xce0,"hebrew_aleph"; -0xce1,"hebrew_bet"; -0xce1,"hebrew_beth"; -0xce2,"hebrew_gimel"; -0xce2,"hebrew_gimmel"; -0xce3,"hebrew_dalet"; -0xce3,"hebrew_daleth"; -0xce4,"hebrew_he"; -0xce5,"hebrew_waw"; -0xce6,"hebrew_zain"; -0xce6,"hebrew_zayin"; -0xce7,"hebrew_chet"; -0xce7,"hebrew_het"; -0xce8,"hebrew_tet"; -0xce8,"hebrew_teth"; -0xce9,"hebrew_yod"; -0xcea,"hebrew_finalkaph"; -0xceb,"hebrew_kaph"; -0xcec,"hebrew_lamed"; -0xced,"hebrew_finalmem"; -0xcee,"hebrew_mem"; -0xcef,"hebrew_finalnun"; -0xcf0,"hebrew_nun"; -0xcf1,"hebrew_samech"; -0xcf1,"hebrew_samekh"; -0xcf2,"hebrew_ayin"; -0xcf3,"hebrew_finalpe"; -0xcf4,"hebrew_pe"; -0xcf5,"hebrew_finalzade"; -0xcf5,"hebrew_finalzadi"; -0xcf6,"hebrew_zade"; -0xcf6,"hebrew_zadi"; -0xcf7,"hebrew_qoph"; -0xcf7,"hebrew_kuf"; -0xcf8,"hebrew_resh"; -0xcf9,"hebrew_shin"; -0xcfa,"hebrew_taw"; -0xcfa,"hebrew_taf"; -0xFF7E,"Hebrew_switch"; -0xda1,"Thai_kokai"; -0xda2,"Thai_khokhai"; -0xda3,"Thai_khokhuat"; -0xda4,"Thai_khokhwai"; -0xda5,"Thai_khokhon"; -0xda6,"Thai_khorakhang"; -0xda7,"Thai_ngongu"; -0xda8,"Thai_chochan"; -0xda9,"Thai_choching"; -0xdaa,"Thai_chochang"; -0xdab,"Thai_soso"; -0xdac,"Thai_chochoe"; -0xdad,"Thai_yoying"; -0xdae,"Thai_dochada"; -0xdaf,"Thai_topatak"; -0xdb0,"Thai_thothan"; -0xdb1,"Thai_thonangmontho"; -0xdb2,"Thai_thophuthao"; -0xdb3,"Thai_nonen"; -0xdb4,"Thai_dodek"; -0xdb5,"Thai_totao"; -0xdb6,"Thai_thothung"; -0xdb7,"Thai_thothahan"; -0xdb8,"Thai_thothong"; -0xdb9,"Thai_nonu"; -0xdba,"Thai_bobaimai"; -0xdbb,"Thai_popla"; -0xdbc,"Thai_phophung"; -0xdbd,"Thai_fofa"; -0xdbe,"Thai_phophan"; -0xdbf,"Thai_fofan"; -0xdc0,"Thai_phosamphao"; -0xdc1,"Thai_moma"; -0xdc2,"Thai_yoyak"; -0xdc3,"Thai_rorua"; -0xdc4,"Thai_ru"; -0xdc5,"Thai_loling"; -0xdc6,"Thai_lu"; -0xdc7,"Thai_wowaen"; -0xdc8,"Thai_sosala"; -0xdc9,"Thai_sorusi"; -0xdca,"Thai_sosua"; -0xdcb,"Thai_hohip"; -0xdcc,"Thai_lochula"; -0xdcd,"Thai_oang"; -0xdce,"Thai_honokhuk"; -0xdcf,"Thai_paiyannoi"; -0xdd0,"Thai_saraa"; -0xdd1,"Thai_maihanakat"; -0xdd2,"Thai_saraaa"; -0xdd3,"Thai_saraam"; -0xdd4,"Thai_sarai"; -0xdd5,"Thai_saraii"; -0xdd6,"Thai_saraue"; -0xdd7,"Thai_sarauee"; -0xdd8,"Thai_sarau"; -0xdd9,"Thai_sarauu"; -0xdda,"Thai_phinthu"; -0xdde,"Thai_maihanakat_maitho"; -0xddf,"Thai_baht"; -0xde0,"Thai_sarae"; -0xde1,"Thai_saraae"; -0xde2,"Thai_sarao"; -0xde3,"Thai_saraaimaimuan"; -0xde4,"Thai_saraaimaimalai"; -0xde5,"Thai_lakkhangyao"; -0xde6,"Thai_maiyamok"; -0xde7,"Thai_maitaikhu"; -0xde8,"Thai_maiek"; -0xde9,"Thai_maitho"; -0xdea,"Thai_maitri"; -0xdeb,"Thai_maichattawa"; -0xdec,"Thai_thanthakhat"; -0xded,"Thai_nikhahit"; -0xdf0,"Thai_leksun"; -0xdf1,"Thai_leknung"; -0xdf2,"Thai_leksong"; -0xdf3,"Thai_leksam"; -0xdf4,"Thai_leksi"; -0xdf5,"Thai_lekha"; -0xdf6,"Thai_lekhok"; -0xdf7,"Thai_lekchet"; -0xdf8,"Thai_lekpaet"; -0xdf9,"Thai_lekkao"; -0xff31,"Hangul"; -0xff32,"Hangul_Start"; -0xff33,"Hangul_End"; -0xff34,"Hangul_Hanja"; -0xff35,"Hangul_Jamo"; -0xff36,"Hangul_Romaja"; -0xff37,"Hangul_Codeinput"; -0xff38,"Hangul_Jeonja"; -0xff39,"Hangul_Banja"; -0xff3a,"Hangul_PreHanja"; -0xff3b,"Hangul_PostHanja"; -0xff3c,"Hangul_SingleCandidate"; -0xff3d,"Hangul_MultipleCandidate"; -0xff3e,"Hangul_PreviousCandidate"; -0xff3f,"Hangul_Special"; -0xFF7E,"Hangul_switch"; -0xea1,"Hangul_Kiyeog"; -0xea2,"Hangul_SsangKiyeog"; -0xea3,"Hangul_KiyeogSios"; -0xea4,"Hangul_Nieun"; -0xea5,"Hangul_NieunJieuj"; -0xea6,"Hangul_NieunHieuh"; -0xea7,"Hangul_Dikeud"; -0xea8,"Hangul_SsangDikeud"; -0xea9,"Hangul_Rieul"; -0xeaa,"Hangul_RieulKiyeog"; -0xeab,"Hangul_RieulMieum"; -0xeac,"Hangul_RieulPieub"; -0xead,"Hangul_RieulSios"; -0xeae,"Hangul_RieulTieut"; -0xeaf,"Hangul_RieulPhieuf"; -0xeb0,"Hangul_RieulHieuh"; -0xeb1,"Hangul_Mieum"; -0xeb2,"Hangul_Pieub"; -0xeb3,"Hangul_SsangPieub"; -0xeb4,"Hangul_PieubSios"; -0xeb5,"Hangul_Sios"; -0xeb6,"Hangul_SsangSios"; -0xeb7,"Hangul_Ieung"; -0xeb8,"Hangul_Jieuj"; -0xeb9,"Hangul_SsangJieuj"; -0xeba,"Hangul_Cieuc"; -0xebb,"Hangul_Khieuq"; -0xebc,"Hangul_Tieut"; -0xebd,"Hangul_Phieuf"; -0xebe,"Hangul_Hieuh"; -0xebf,"Hangul_A"; -0xec0,"Hangul_AE"; -0xec1,"Hangul_YA"; -0xec2,"Hangul_YAE"; -0xec3,"Hangul_EO"; -0xec4,"Hangul_E"; -0xec5,"Hangul_YEO"; -0xec6,"Hangul_YE"; -0xec7,"Hangul_O"; -0xec8,"Hangul_WA"; -0xec9,"Hangul_WAE"; -0xeca,"Hangul_OE"; -0xecb,"Hangul_YO"; -0xecc,"Hangul_U"; -0xecd,"Hangul_WEO"; -0xece,"Hangul_WE"; -0xecf,"Hangul_WI"; -0xed0,"Hangul_YU"; -0xed1,"Hangul_EU"; -0xed2,"Hangul_YI"; -0xed3,"Hangul_I"; -0xed4,"Hangul_J_Kiyeog"; -0xed5,"Hangul_J_SsangKiyeog"; -0xed6,"Hangul_J_KiyeogSios"; -0xed7,"Hangul_J_Nieun"; -0xed8,"Hangul_J_NieunJieuj"; -0xed9,"Hangul_J_NieunHieuh"; -0xeda,"Hangul_J_Dikeud"; -0xedb,"Hangul_J_Rieul"; -0xedc,"Hangul_J_RieulKiyeog"; -0xedd,"Hangul_J_RieulMieum"; -0xede,"Hangul_J_RieulPieub"; -0xedf,"Hangul_J_RieulSios"; -0xee0,"Hangul_J_RieulTieut"; -0xee1,"Hangul_J_RieulPhieuf"; -0xee2,"Hangul_J_RieulHieuh"; -0xee3,"Hangul_J_Mieum"; -0xee4,"Hangul_J_Pieub"; -0xee5,"Hangul_J_PieubSios"; -0xee6,"Hangul_J_Sios"; -0xee7,"Hangul_J_SsangSios"; -0xee8,"Hangul_J_Ieung"; -0xee9,"Hangul_J_Jieuj"; -0xeea,"Hangul_J_Cieuc"; -0xeeb,"Hangul_J_Khieuq"; -0xeec,"Hangul_J_Tieut"; -0xeed,"Hangul_J_Phieuf"; -0xeee,"Hangul_J_Hieuh"; -0xeef,"Hangul_RieulYeorinHieuh"; -0xef0,"Hangul_SunkyeongeumMieum"; -0xef1,"Hangul_SunkyeongeumPieub"; -0xef2,"Hangul_PanSios"; -0xef3,"Hangul_KkogjiDalrinIeung"; -0xef4,"Hangul_SunkyeongeumPhieuf"; -0xef5,"Hangul_YeorinHieuh"; -0xef6,"Hangul_AraeA"; -0xef7,"Hangul_AraeAE"; -0xef8,"Hangul_J_PanSios"; -0xef9,"Hangul_J_KkogjiDalrinIeung"; -0xefa,"Hangul_J_YeorinHieuh"; -0xeff,"Korean_Won"; -] diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.mli index ace751c64..9e339d135 100644 --- a/ide/utils/configwin_types.ml +++ b/ide/utils/configwin_types.mli @@ -25,113 +25,6 @@ (** This module contains the types used in Configwin. *) -open Config_file - -let name_to_keysym = - ("Button1", Configwin_keys.xk_Pointer_Button1) :: - ("Button2", Configwin_keys.xk_Pointer_Button2) :: - ("Button3", Configwin_keys.xk_Pointer_Button3) :: - ("Button4", Configwin_keys.xk_Pointer_Button4) :: - ("Button5", Configwin_keys.xk_Pointer_Button5) :: - Configwin_keys.name_to_keysym - -let string_to_key s = - let mask = ref [] in - let key = try - let pos = String.rindex s '-' in - for i = 0 to pos - 1 do - let m = match s.[i] with - 'C' -> `CONTROL - | 'S' -> `SHIFT - | 'L' -> `LOCK - | 'M' -> `MOD1 - | 'A' -> `MOD1 - | '1' -> `MOD1 - | '2' -> `MOD2 - | '3' -> `MOD3 - | '4' -> `MOD4 - | '5' -> `MOD5 - | _ -> - Minilib.log s; - raise Not_found - in - mask := m :: !mask - done; - String.sub s (pos+1) (String.length s - pos - 1) - with _ -> - s - in - try - !mask, List.assoc key name_to_keysym - with - e -> - Minilib.log s; - raise e - -let key_to_string (m, k) = - let s = List.assoc k Configwin_keys.keysym_to_name in - match m with - [] -> s - | _ -> - let rec iter m s = - match m with - [] -> s - | c :: m -> - iter m (( - match c with - `CONTROL -> "C" - | `SHIFT -> "S" - | `LOCK -> "L" - | `MOD1 -> "A" - | `MOD2 -> "2" - | `MOD3 -> "3" - | `MOD4 -> "4" - | `MOD5 -> "5" - | _ -> raise Not_found - ) ^ s) - in - iter m ("-" ^ s) - -let modifiers_to_string m = - let rec iter m s = - match m with - [] -> s - | c :: m -> - iter m (( - match c with - `CONTROL -> "<ctrl>" - | `SHIFT -> "<shft>" - | `LOCK -> "<lock>" - | `MOD1 -> "<alt>" - | `MOD2 -> "<mod2>" - | `MOD3 -> "<mod3>" - | `MOD4 -> "<mod4>" - | `MOD5 -> "<mod5>" - | _ -> raise Not_found - ) ^ s) - in - iter m "" - -let value_to_key v = - match v with - Raw.String s -> string_to_key s - | _ -> - Minilib.log "value_to_key"; - raise Not_found - -let key_to_value k = - Raw.String (key_to_string k) - -let key_cp_wrapper = - { - to_raw = key_to_value ; - of_raw = value_to_key ; - } - -(** A class to define key options, with the {!Config_file} module. *) -class key_cp = - [(Gdk.Tags.modifier list * int)] Config_file.cp_custom_type key_cp_wrapper - (** This type represents a string or filename parameter, or any other type, depending on the given conversion functions. *) type 'a string_param = { @@ -188,49 +81,6 @@ type custom_param = { custom_framed : string option ; (** optional label for an optional frame *) } ;; -type color_param = { - color_label : string; (** the label of the parameter *) - mutable color_value : string; (** the current value of the parameter *) - color_editable : bool ; (** indicates if the value can be changed *) - color_f_apply : (string -> unit) ; (** the function to call to apply the new value of the parameter *) - color_help : string option ; (** optional help string *) - color_expand : bool ; (** expand the entry widget or not *) - } ;; - -type date_param = { - date_label : string ; (** the label of the parameter *) - mutable date_value : int * int * int ; (** day, month, year *) - date_editable : bool ; (** indicates if the value can be changed *) - date_f_string : (int * int * int) -> string ; - (** the function used to display the current value (day, month, year) *) - date_f_apply : ((int * int * int) -> unit) ; - (** the function to call to apply the new value (day, month, year) of the parameter *) - date_help : string option ; (** optional help string *) - date_expand : bool ; (** expand the entry widget or not *) - } ;; - -type font_param = { - font_label : string ; (** the label of the parameter *) - mutable font_value : string ; (** the font name *) - font_editable : bool ; (** indicates if the value can be changed *) - font_f_apply : (string -> unit) ; - (** the function to call to apply the new value of the parameter *) - font_help : string option ; (** optional help string *) - font_expand : bool ; (** expand the entry widget or not *) - } ;; - - -type hotkey_param = { - hk_label : string ; (** the label of the parameter *) - mutable hk_value : (Gdk.Tags.modifier list * int) ; - (** The value, as a list of modifiers and a key code *) - hk_editable : bool ; (** indicates if the value can be changed *) - hk_f_apply : ((Gdk.Tags.modifier list * int) -> unit) ; - (** the function to call to apply the new value of the paramter *) - hk_help : string option ; (** optional help string *) - hk_expand : bool ; (** expand or not *) - } - type modifiers_param = { md_label : string ; (** the label of the parameter *) mutable md_value : Gdk.Tags.modifier list ; @@ -248,17 +98,11 @@ type modifiers_param = { type parameter_kind = String_param of string string_param | List_param of (GData.tooltips -> <box: GObj.widget ; apply : unit>) - | Filename_param of string string_param | Bool_param of bool_param | Text_param of string string_param | Combo_param of combo_param | Custom_param of custom_param - | Color_param of color_param - | Date_param of date_param - | Font_param of font_param - | Hotkey_param of hotkey_param | Modifiers_param of modifiers_param - | Html_param of string string_param ;; (** This type represents the structure of the configuration window. *) @@ -275,28 +119,3 @@ type return_button = | Return_cancel (** The user closed the window with the cancel button or the window manager but never clicked on the apply button.*) - -(** {2 Bindings in the html editor} *) - -type html_binding = { - mutable html_key : (Gdk.Tags.modifier list * int) ; - mutable html_begin : string ; - mutable html_end : string ; - } - -let htmlbinding_cp_wrapper = - let w = Config_file.tuple3_wrappers - key_cp_wrapper - Config_file.string_wrappers - Config_file.string_wrappers - in - { - to_raw = (fun v -> w.to_raw (v.html_key, v.html_begin, v.html_end)) ; - of_raw = - (fun r -> let (k,b,e) = w.of_raw r in - { html_key = k ; html_begin = b ; html_end = e } - ) ; - } - -class htmlbinding_cp = - [html_binding] Config_file.option_cp htmlbinding_cp_wrapper diff --git a/ide/utils/editable_cells.ml b/ide/utils/editable_cells.ml deleted file mode 100644 index 33968b8dd..000000000 --- a/ide/utils/editable_cells.ml +++ /dev/null @@ -1,113 +0,0 @@ -open Gobject - -let create l = - let hbox = GPack.hbox () in - let scw = GBin.scrolled_window - ~hpolicy:`AUTOMATIC - ~vpolicy:`AUTOMATIC - ~packing:(hbox#pack ~expand:true) () in - - let columns = new GTree.column_list in - let command_col = columns#add Data.string in - let coq_col = columns#add Data.string in - let store = GTree.list_store columns - in - -(* populate the store *) - let _ = List.iter (fun (x,y) -> - let row = store#append () in - store#set ~row ~column:command_col x; - store#set ~row ~column:coq_col y) - l - in - let view = GTree.view ~model:store ~packing:scw#add_with_viewport () in - - (* Alternate colors for the rows *) - view#set_rules_hint true; - - let renderer_comm = GTree.cell_renderer_text [`EDITABLE true] in - ignore (renderer_comm#connect#edited - ~callback:(fun (path:Gtk.tree_path) (s:string) -> - store#set - ~row:(store#get_iter path) - ~column:command_col s)); - let first = - GTree.view_column ~title:"Coq Command to try" - ~renderer:(renderer_comm,["text",command_col]) - () - in ignore (view#append_column first); - - let renderer_coq = GTree.cell_renderer_text [`EDITABLE true] in - ignore(renderer_coq#connect#edited - ~callback:(fun (path:Gtk.tree_path) (s:string) -> - store#set - ~row:(store#get_iter path) - ~column:coq_col s)); - let second = - GTree.view_column ~title:"Coq Command to insert" - ~renderer:(renderer_coq,["text",coq_col]) - () - in ignore (view#append_column second); - - let vbox = GPack.button_box `VERTICAL ~packing:hbox#pack ~layout:`SPREAD () - in - let up = GButton.button ~stock:`GO_UP ~label:"Up" ~packing:(vbox#pack ~expand:true ~fill:false) () in - let down = GButton.button - ~stock:`GO_DOWN - ~label:"Down" - ~packing:(vbox#pack ~expand:true ~fill:false) () - in - let add = GButton.button ~stock:`ADD - ~label:"Add" - ~packing:(vbox#pack ~expand:true ~fill:false) - () - in - let remove = GButton.button ~stock:`REMOVE - ~label:"Remove" - ~packing:(vbox#pack ~expand:true ~fill:false) () - in - - ignore (add#connect#clicked - ~callback:(fun b -> - let n = store#append () in - view#selection#select_iter n)); - ignore (remove#connect#clicked - ~callback:(fun b -> match view#selection#get_selected_rows with - | [] -> () - | path::_ -> - let iter = store#get_iter path in - ignore (store#remove iter); - )); - ignore (up#connect#clicked - ~callback:(fun b -> - match view#selection#get_selected_rows with - | [] -> () - | path::_ -> - let iter = store#get_iter path in - ignore (GtkTree.TreePath.prev path); - let upiter = store#get_iter path in - ignore (store#swap iter upiter); - )); - ignore (down#connect#clicked - ~callback:(fun b -> - match view#selection#get_selected_rows with - | [] -> () - | path::_ -> - let iter = store#get_iter path in - GtkTree.TreePath.next path; - try let upiter = store#get_iter path in - ignore (store#swap iter upiter) - with _ -> () - )); - let get_data () = - let start_path = GtkTree.TreePath.from_string "0" in - let start_iter = store#get_iter start_path in - let rec all acc = - let new_acc = (store#get ~row:start_iter ~column:command_col, - store#get ~row:start_iter ~column:coq_col)::acc - in - if store#iter_next start_iter then all new_acc else List.rev new_acc - in all [] - in - (hbox,get_data) - diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml deleted file mode 100644 index 8f6cb382a..000000000 --- a/ide/utils/okey.ml +++ /dev/null @@ -1,169 +0,0 @@ -(*********************************************************************************) -(* Cameleon *) -(* *) -(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. *) -(* *) -(* This program is free software; you can redistribute it and/or modify *) -(* it under the terms of the GNU Library General Public License as *) -(* published by the Free Software Foundation; either version 2 of the *) -(* License, or any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU Library General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU Library General Public *) -(* License along with this program; if not, write to the Free Software *) -(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) -(* 02111-1307 USA *) -(* *) -(* Contact: Maxence.Guesdon@inria.fr *) -(* *) -(*********************************************************************************) - -type modifier = Gdk.Tags.modifier - -type handler = { - cond : (unit -> bool) ; - cback : (unit -> unit) ; - } - -type handler_spec = int * int * Gdk.keysym - (** mods * mask * key *) - -let int_of_modifier = function - `SHIFT -> 1 - | `LOCK -> 2 - | `CONTROL -> 4 - | `MOD1 -> 8 - | `MOD2 -> 16 - | `MOD3 -> 32 - | `MOD4 -> 64 - | `MOD5 -> 128 - | `BUTTON1 -> 256 - | `BUTTON2 -> 512 - | `BUTTON3 -> 1024 - | `BUTTON4 -> 2048 - | `BUTTON5 -> 4096 - | `HYPER -> 1 lsl 22 - | `META -> 1 lsl 20 - | `RELEASE -> 1 lsl 30 - | `SUPER -> 1 lsl 21 - -let int_of_modifiers l = - List.fold_left (fun acc -> fun m -> acc + (int_of_modifier m)) 0 l - -module H = - struct - type t = handler_spec * handler - let equal (m,k) (mods, mask, key) = - (k = key) && ((m land mask) = mods) - - let filter_with_mask mods mask key l = - List.filter (fun a -> (fst a) <> (mods, mask, key)) l - - let find_handlers mods key l = - List.map snd - (List.filter - (fun ((m,ma,k),_) -> equal (mods,key) (m,ma,k)) - l - ) - - end - -let (table : (int, H.t list ref) Hashtbl.t) = Hashtbl.create 13 - -let key_press w ev = - let key = GdkEvent.Key.keyval ev in - let modifiers = GdkEvent.Key.state ev in - try - let (r : H.t list ref) = Hashtbl.find table (Oo.id w) in - let l = H.find_handlers (int_of_modifiers modifiers) key !r in - match l with - [] -> false - | _ -> - List.iter - (fun h -> - if h.cond () then - try h.cback () - with e -> Minilib.log (Printexc.to_string e) - else () - ) - l; - true - with - Not_found -> - false - -let associate_key_press w = - ignore ((w#event#connect#key_press ~callback: (key_press w)) : GtkSignal.id) - -let default_modifiers = ref ([] : modifier list) -let default_mask = ref ([`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] : modifier list) - -let set_default_modifiers l = default_modifiers := l -let set_default_mask l = default_mask := l - -let remove_widget (w : < event : GObj.event_ops ; ..>) () = - try - let r = Hashtbl.find table (Oo.id w) in - r := [] - with - Not_found -> - () - -let add1 ?(remove=false) w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k callback = - - let r = - try Hashtbl.find table (Oo.id w) - with Not_found -> - let r = ref [] in - Hashtbl.add table (Oo.id w) r; - ignore (w#connect#destroy ~callback: (remove_widget w)); - associate_key_press w; - r - in - let n_mods = int_of_modifiers mods in - let n_mask = lnot (int_of_modifiers mask) in - let new_h = { cond = cond ; cback = callback } in - if remove then - ( - let l = H.filter_with_mask n_mods n_mask k !r in - r := ((n_mods, n_mask, k), new_h) :: l - ) - else - r := ((n_mods, n_mask, k), new_h) :: !r - -let add w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k callback = - add1 w ~cond ~mods ~mask k callback - -let add_list w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k_list callback = - List.iter (fun k -> add w ~cond ~mods ~mask k callback) k_list - -let set w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k callback = - add1 ~remove: true w ~cond ~mods ~mask k callback - -let set_list w - ?(cond=(fun () -> true)) - ?(mods= !default_modifiers) - ?(mask= !default_mask) - k_list callback = - List.iter (fun k -> set w ~cond ~mods ~mask k callback) k_list diff --git a/ide/utils/okey.mli b/ide/utils/okey.mli deleted file mode 100644 index 84ea4df44..000000000 --- a/ide/utils/okey.mli +++ /dev/null @@ -1,115 +0,0 @@ -(*********************************************************************************) -(* Cameleon *) -(* *) -(* Copyright (C) 2005 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. *) -(* *) -(* This program is free software; you can redistribute it and/or modify *) -(* it under the terms of the GNU Library General Public License as *) -(* published by the Free Software Foundation; either version 2 of the *) -(* License, or any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU Library General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU Library General Public *) -(* License along with this program; if not, write to the Free Software *) -(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *) -(* 02111-1307 USA *) -(* *) -(* Contact: Maxence.Guesdon@inria.fr *) -(* *) -(*********************************************************************************) - -(** Okey interface. - - Once the lib is compiled and installed, you can use it by referencing - it with the [Okey] module. You must add [okey.cmo] or [okey.cmx] - on the commande line when you link. -*) - -type modifier = Gdk.Tags.modifier - -(** Set the default modifier list. The first default value is [[]].*) -val set_default_modifiers : modifier list -> unit - -(** Set the default modifier mask. The first default value is - [[`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK]]. - The mask defines the modifiers not taken into account - when looking for the handler of a key press event. -*) -val set_default_mask : modifier list -> unit - -(** [add widget key callback] associates the [callback] function to the event - "key_press" with the given [key] for the given [widget]. - - @param remove when true, the previous handlers for the given key and modifier - list are not kept. - @param cond this function is a guard: the [callback] function is not called - if the [cond] function returns [false]. - The default [cond] function always returns [true]. - - @param mods the list of modifiers. If not given, the default modifiers - are used. - You can set the default modifiers with function {!Okey.set_default_modifiers}. - - @param mask the list of modifiers which must not be taken - into account to trigger the given handler. [mods] - and [mask] must not have common modifiers. If not given, the default mask - is used. - You can set the default modifiers mask with function {!Okey.set_default_mask}. -*) -val add : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym -> - (unit -> unit) -> - unit - -(** It calls {!Okey.add} for each given key.*) -val add_list : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym list -> - (unit -> unit) -> - unit - -(** Like {!Okey.add} but the previous handlers for the - given modifiers and key are not kept.*) -val set : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym -> - (unit -> unit) -> - unit - -(** It calls {!Okey.set} for each given key.*) -val set_list : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym list -> - (unit -> unit) -> - unit - -(** Remove the handlers associated to the given widget. - This is automatically done when a widget is destroyed but - you can do it yourself. *) -val remove_widget : - < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - unit -> - unit diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index 946aaf010..47dad8f19 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -100,18 +100,15 @@ object(self) if Str.string_match (Str.regexp "\\. *$") com 0 then com else com ^ " " ^ arg ^" . " in - let log level message = - Ideutils.insert_xml result#buffer message; - result#buffer#insert "\n"; - in let process = - Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function + Coq.bind (Coq.query (phrase,Stateid.dummy)) (function | Interface.Fail (_,l,str) -> - Ideutils.insert_xml result#buffer str; + let width = Ideutils.textview_width result in + Ideutils.insert_xml result#buffer (Richpp.richpp_of_pp width str); notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce; Coq.return () | Interface.Good res -> - result#buffer#insert res; + result#buffer#insert res; notebook#set_page ~tab_label:(new_tab_lbl arg) frame#coerce; Coq.return ()) in diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 0330b8eff..3d0cd46cd 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -28,9 +28,10 @@ class type message_view = inherit GObj.widget method connect : message_view_signals method clear : unit - method add : Richpp.richpp -> unit + method add : Pp.std_ppcmds -> unit method add_string : string -> unit - method set : Richpp.richpp -> unit + method set : Pp.std_ppcmds -> unit + method refresh : bool -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer @@ -57,46 +58,71 @@ let message_view () : message_view = 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 _ = background_color#connect#changed ~callback:cb in + let _ = view#misc#connect#realize ~callback:(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) + + (* Inserts at point, advances the mark *) + let insert_msg (level, msg) = + let tags = match level with + | Feedback.Error -> [Tags.Message.error] + | Feedback.Warning -> [Tags.Message.warning] + | _ -> [] + in + let mark = `MARK mark in + let width = Ideutils.textview_width view in + Ideutils.insert_xml ~mark buffer ~tags (Richpp.richpp_of_pp width msg); + buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n" + in + + let mv = object (self) inherit GObj.widget box#as_widget + (* List of displayed messages *) + val mutable last_width = -1 + val mutable msgs = [] + val push = new GUtil.signal () method connect = new message_view_signals_impl box#as_widget push + method refresh force = + (* We need to block updates here due to the following race: + insertion of messages may create a vertical scrollbar, this + will trigger a width change, calling refresh again and + going into an infinite loop. *) + let width = Ideutils.textview_width view in + (* Could still this method race if the scrollbar changes the + textview_width ?? *) + let needed = force || last_width <> width in + if needed then begin + last_width <- width; + buffer#set_text ""; + buffer#move_mark (`MARK mark) ~where:buffer#start_iter; + List.(iter insert_msg (rev msgs)) + end + method clear = - buffer#set_text ""; - buffer#move_mark (`MARK mark) ~where:buffer#start_iter + msgs <- []; self#refresh true method push level msg = - let tags = match level with - | Feedback.Error -> [Tags.Message.error] - | Feedback.Warning -> [Tags.Message.warning] - | _ -> [] - in - let rec non_empty = function - | Xml_datatype.PCData "" -> false - | Xml_datatype.PCData _ -> true - | Xml_datatype.Element (_, _, children) -> List.exists non_empty children - in - if non_empty (Richpp.repr msg) then begin - let mark = `MARK mark in - Ideutils.insert_xml ~mark buffer ~tags msg; - buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n"; - push#call (level, msg) - end + msgs <- (level, msg) :: msgs; + insert_msg (level, msg); + push#call (level, msg) method add msg = self#push Feedback.Notice msg - method add_string s = self#add (Richpp.richpp_of_string s) + method add_string s = self#add (Pp.str s) method set msg = self#clear; self#add msg method buffer = text_buffer end + in + (* Is there a better way to connect the signal ? *) + let w_cb (_ : Gtk.rectangle) = mv#refresh false in + ignore (view#misc#connect#size_allocate ~callback:w_cb); + mv diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index 2d34533de..d065fcbc8 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -18,9 +18,10 @@ class type message_view = inherit GObj.widget method connect : message_view_signals method clear : unit - method add : Richpp.richpp -> unit + method add : Pp.std_ppcmds -> unit method add_string : string -> unit - method set : Richpp.richpp -> unit + method set : Pp.std_ppcmds -> unit + method refresh : bool -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 47c86045a..b5405570c 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -18,7 +18,6 @@ class type proof_view = method clear : unit -> unit method set_goals : Interface.goals option -> unit method set_evars : Interface.evar list option -> unit - method width : int end (* tag is the tag to be hooked, item is the item covered by this tag, make_menu @@ -74,6 +73,7 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with | None -> [], [] | Some (hl, h) -> (hl, h) in + let width = Ideutils.textview_width proof in let rec insert_hyp hints hs = match hs with | [] -> () | hyp :: hs -> @@ -84,7 +84,7 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with let () = hook_tag_cb tag hint sel_cb on_hover in [tag], hints in - let () = insert_xml ~tags proof#buffer hyp in + let () = insert_xml ~tags proof#buffer (Richpp.richpp_of_pp width hyp) in proof#buffer#insert "\n"; insert_hyp rem_hints hs in @@ -98,13 +98,13 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with else [] in proof#buffer#insert (goal_str 1 goals_cnt); - insert_xml proof#buffer cur_goal; + insert_xml proof#buffer (Richpp.richpp_of_pp width cur_goal); proof#buffer#insert "\n" in (* Insert remaining goals (no hypotheses) *) let fold_goal i _ { Interface.goal_ccl = g } = proof#buffer#insert (goal_str i goals_cnt); - insert_xml proof#buffer g; + insert_xml proof#buffer (Richpp.richpp_of_pp width g); proof#buffer#insert "\n" in let () = Util.List.fold_left_i fold_goal 2 () rem_goals in @@ -122,6 +122,7 @@ let rec flatten = function let display mode (view : #GText.view_skel) goals hints evars = let () = view#buffer#set_text "" in + let width = Ideutils.textview_width view in match goals with | None -> () (* No proof in progress *) @@ -144,7 +145,7 @@ let display mode (view : #GText.view_skel) goals hints evars = (* The proof is finished, with the exception of given up goals. *) view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n"; let iter goal = - insert_xml view#buffer goal.Interface.goal_ccl; + insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iter iter given_up_goals; @@ -153,7 +154,7 @@ let display mode (view : #GText.view_skel) goals hints evars = (* All the goals have been resolved but those on the shelf. *) view#buffer#insert "All the remaining goals are on the shelf:\n\n"; let iter goal = - insert_xml view#buffer goal.Interface.goal_ccl; + insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iter iter shelved_goals @@ -166,7 +167,7 @@ let display mode (view : #GText.view_skel) goals hints evars = view#buffer#insert "This subproof is complete, but there are some unfocused goals:\n\n"; let iter i goal = let () = view#buffer#insert (goal_str (succ i)) in - insert_xml view#buffer goal.Interface.goal_ccl; + insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); view#buffer#insert "\n" in List.iteri iter bg @@ -192,7 +193,7 @@ let proof_view () = let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in stick text_font view cb; - object + let pf = object inherit GObj.widget view#as_widget val mutable goals = None val mutable evars = None @@ -207,9 +208,11 @@ let proof_view () = method refresh () = let dummy _ () = () in - display (mode_tactic dummy) (view :> GText.view_skel) goals None evars - - method width = Ideutils.textview_width (view :> GText.view_skel) + display (mode_tactic dummy) view goals None evars end - -(* ignore (proof_buffer#add_selection_clipboard cb); *) + in + (* Is there a better way to connect the signal ? *) + (* Can this be done in the object constructor? *) + let w_cb _ = pf#refresh () in + ignore (view#misc#connect#size_allocate w_cb); + pf diff --git a/ide/wg_ProofView.mli b/ide/wg_ProofView.mli index b6eae48b3..aa01d955d 100644 --- a/ide/wg_ProofView.mli +++ b/ide/wg_ProofView.mli @@ -14,7 +14,6 @@ class type proof_view = method clear : unit -> unit method set_goals : Interface.goals option -> unit method set_evars : Interface.evar list option -> unit - method width : int end val proof_view : unit -> proof_view diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index aecb317bc..5f80d6897 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -12,6 +12,9 @@ let protocol_version = "20150913" +type msg_format = Richpp of int | Ppcmds +let msg_format = ref (Richpp 72) + (** * Interface of calls to Coq by CoqIde *) open Util @@ -92,10 +95,57 @@ let to_stateid = function let of_stateid i = Element ("state_id",["val",string_of_int (Stateid.to_int i)],[]) -let of_richpp x = Element ("richpp", [], [Richpp.repr x]) -let to_richpp xml = match xml with - | Element ("richpp", [], [x]) -> Richpp.richpp_of_xml x - | x -> raise Serialize.(Marshal_error("richpp",x)) +let of_box (ppb : Pp.block_type) = let open Pp in match ppb with + | Pp_hbox i -> constructor "ppbox" "hbox" [of_int i] + | Pp_vbox i -> constructor "ppbox" "vbox" [of_int i] + | Pp_hvbox i -> constructor "ppbox" "hvbox" [of_int i] + | Pp_hovbox i -> constructor "ppbox" "hovbox" [of_int i] + +let to_box = let open Pp in + do_match "ppbox" (fun s args -> match s with + | "hbox" -> Pp_hbox (to_int (singleton args)) + | "vbox" -> Pp_vbox (to_int (singleton args)) + | "hvbox" -> Pp_hvbox (to_int (singleton args)) + | "hovbox" -> Pp_hovbox (to_int (singleton args)) + | x -> raise (Marshal_error("*ppbox",PCData x)) + ) + +let rec of_pp (pp : Pp.std_ppcmds) = let open Pp in match Pp.repr pp with + | Ppcmd_empty -> constructor "ppdoc" "emtpy" [] + | Ppcmd_string s -> constructor "ppdoc" "string" [of_string s] + | Ppcmd_glue sl -> constructor "ppdoc" "glue" [of_list of_pp sl] + | Ppcmd_box (bt,s) -> constructor "ppdoc" "box" [of_pair of_box of_pp (bt,s)] + | Ppcmd_tag (t,s) -> constructor "ppdoc" "tag" [of_pair of_string of_pp (t,s)] + | Ppcmd_print_break (i,j) + -> constructor "ppdoc" "break" [of_pair of_int of_int (i,j)] + | Ppcmd_force_newline -> constructor "ppdoc" "newline" [] + | Ppcmd_comment cmd -> constructor "ppdoc" "comment" [of_list of_string cmd] + + +let rec to_pp xpp = let open Pp in + Pp.unrepr @@ + do_match "ppdoc" (fun s args -> match s with + | "empty" -> Ppcmd_empty + | "string" -> Ppcmd_string (to_string (singleton args)) + | "glue" -> Ppcmd_glue (to_list to_pp (singleton args)) + | "box" -> let (bt,s) = to_pair to_box to_pp (singleton args) in + Ppcmd_box(bt,s) + | "tag" -> let (tg,s) = to_pair to_string to_pp (singleton args) in + Ppcmd_tag(tg,s) + | "break" -> let (i,j) = to_pair to_int to_int (singleton args) in + Ppcmd_print_break(i, j) + | "newline" -> Ppcmd_force_newline + | "comment" -> Ppcmd_comment (to_list to_string (singleton args)) + | x -> raise (Marshal_error("*ppdoc",PCData x)) + ) xpp + +let of_richpp x = Element ("richpp", [], [x]) + +(* Run-time Selectable *) +let of_pp (pp : Pp.std_ppcmds) = + match !msg_format with + | Richpp margin -> of_richpp (Richpp.richpp_of_pp margin pp) + | Ppcmds -> of_pp pp let of_value f = function | Good x -> Element ("value", ["val", "good"], [f x]) @@ -104,7 +154,7 @@ let of_value f = function | None -> [] | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in let id = of_stateid id in - Element ("value", ["val", "fail"] @ loc, [id; of_richpp msg]) + Element ("value", ["val", "fail"] @ loc, [id; of_pp msg]) let to_value f = function | Element ("value", attrs, l) -> @@ -120,7 +170,7 @@ let to_value f = function in let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise (Marshal_error("val",PCData "no id attribute")) in let id = to_stateid id in - let msg = to_richpp msg in + let msg = to_pp msg in Fail (id, loc, msg) else raise (Marshal_error("good or fail",PCData ans)) | x -> raise (Marshal_error("value",x)) @@ -147,15 +197,15 @@ let to_evar = function | x -> raise (Marshal_error("evar",x)) let of_goal g = - let hyp = of_list of_richpp g.goal_hyp in - let ccl = of_richpp g.goal_ccl in + let hyp = of_list of_pp g.goal_hyp in + let ccl = of_pp g.goal_ccl in let id = of_string g.goal_id in Element ("goal", [], [id; hyp; ccl]) let to_goal = function | Element ("goal", [], [id; hyp; ccl]) -> - let hyp = to_list to_richpp hyp in - let ccl = to_richpp ccl in - let id = to_string id in + let hyp = to_list to_pp hyp in + let ccl = to_pp ccl in + let id = to_string id in { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; } | x -> raise (Marshal_error("goal",x)) @@ -344,8 +394,8 @@ end = struct Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals else let pr_goal { goal_hyp = hyps; goal_ccl = goal } = - "[" ^ String.concat "; " (List.map Richpp.raw_print hyps) ^ " |- " ^ - Richpp.raw_print goal ^ "]" in + "[" ^ String.concat "; " (List.map Pp.string_of_ppcmds hyps) ^ " |- " ^ + Pp.string_of_ppcmds goal ^ "]" in String.concat " " (List.map pr_goal g.fg_goals) let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]" let pr_status (s : status) = @@ -631,6 +681,9 @@ let of_answer : type a. a call -> a value -> xml = function | PrintAst _ -> of_value (of_value_type print_ast_rty_t ) | Annotate _ -> of_value (of_value_type annotate_rty_t ) +let of_answer msg_fmt = + msg_format := msg_fmt; of_answer + let to_answer : type a. a call -> xml -> a value = function | Add _ -> to_value (to_value_type add_rty_t ) | Edit_at _ -> to_value (to_value_type edit_at_rty_t ) @@ -701,10 +754,10 @@ let to_call : xml -> unknown_call = let pr_value_gen pr = function | Good v -> "GOOD " ^ pr v - | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^Richpp.raw_print str^"]" + | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^ Pp.string_of_ppcmds str ^ "]" | Fail (id,Some(i,j),str) -> "FAIL "^Stateid.to_string id^ - " ("^string_of_int i^","^string_of_int j^")["^Richpp.raw_print str^"]" + " ("^string_of_int i^","^string_of_int j^")["^Pp.string_of_ppcmds str^"]" let pr_value v = pr_value_gen (fun _ -> "FIXME") v let pr_full_value : type a. a call -> a value -> string = fun call value -> match call with | Add _ -> pr_value_gen (print add_rty_t ) value @@ -760,7 +813,7 @@ let document to_string_fmt = (to_string_fmt (of_value (fun _ -> PCData "b") (Good ()))); Printf.printf "or:\n\n%s\n\nwhere the attributes loc_s and loc_c are optional.\n" (to_string_fmt (of_value (fun _ -> PCData "b") - (Fail (Stateid.initial,Some (15,34),Richpp.richpp_of_string "error message")))); + (Fail (Stateid.initial,Some (15,34), Pp.str "error message")))); document_type_encoding to_string_fmt (* Moved from feedback.mli : This is IDE specific and we don't want to @@ -787,20 +840,14 @@ let to_message_level = let of_message lvl loc msg = let lvl = of_message_level lvl in let xloc = of_option of_loc loc in - let content = of_richpp msg in + let content = of_pp msg in Xml_datatype.Element ("message", [], [lvl; xloc; content]) let to_message xml = match xml with | Xml_datatype.Element ("message", [], [lvl; xloc; content]) -> - Message(to_message_level lvl, to_option to_loc xloc, to_richpp content) + Message(to_message_level lvl, to_option to_loc xloc, to_pp content) | x -> raise (Marshal_error("message",x)) -let is_message xml = - try begin match to_message xml with - | Message(l,c,m) -> Some (l,c,m) - | _ -> None - end with | Marshal_error _ -> None - let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with | "addedaxiom", _ -> AddedAxiom | "processed", _ -> Processed @@ -816,7 +863,6 @@ let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with | "workerstatus", [ns] -> let n, s = to_pair to_string to_string ns in WorkerStatus(n,s) - | "goals", [loc;s] -> Goals (to_loc loc, to_string s) | "custom", [loc;name;x]-> Custom (to_loc loc, to_string name, x) | "filedependency", [from; dep] -> FileDependency (to_option to_string from, to_string dep) @@ -849,8 +895,6 @@ let of_feedback_content = function | WorkerStatus(n,s) -> constructor "feedback_content" "workerstatus" [of_pair of_string of_string (n,s)] - | Goals (loc,s) -> - constructor "feedback_content" "goals" [of_loc loc;of_string s] | Custom (loc, name, x) -> constructor "feedback_content" "custom" [of_loc loc; of_string name; x] | FileDependency (from, depends_on) -> @@ -873,6 +917,9 @@ let of_feedback msg = let route = string_of_int msg.route in Element ("feedback", obj @ ["route",route], [id;content]) +let of_feedback msg_fmt = + msg_format := msg_fmt; of_feedback + let to_feedback xml = match xml with | Element ("feedback", ["object","edit";"route",route], [id;content]) -> { id = Edit(to_edit_id id); diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli index 1bb998970..9cefab517 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -40,12 +40,17 @@ val abstract_eval_call : handler -> 'a call -> 'a value val protocol_version : string +(** By default, we still output messages in Richpp so we are + compatible with 8.6, however, 8.7 aware clients will want to + set this to Ppcmds *) +type msg_format = Richpp of int | Ppcmds + (** * XML data marshalling *) val of_call : 'a call -> xml val to_call : xml -> unknown_call -val of_answer : 'a call -> 'a value -> xml +val of_answer : msg_format -> 'a call -> 'a value -> xml val to_answer : 'a call -> xml -> 'a value (* Prints the documentation of this module *) @@ -57,16 +62,8 @@ val pr_call : 'a call -> string val pr_value : 'a value -> string val pr_full_value : 'a call -> 'a value -> string -(** * Serialization of rich documents *) -val of_richpp : Richpp.richpp -> Xml_datatype.xml -val to_richpp : Xml_datatype.xml -> Richpp.richpp - (** * Serializaiton of feedback *) -val of_feedback : Feedback.feedback -> xml +val of_feedback : msg_format -> Feedback.feedback -> xml val to_feedback : xml -> Feedback.feedback -val is_feedback : xml -> bool - -val is_message : xml -> (Feedback.level * Loc.t option * Richpp.richpp) option -val of_message : Feedback.level -> Loc.t option -> Richpp.richpp -> xml -(* val to_message : xml -> Feedback.message *) +val is_feedback : xml -> bool diff --git a/interp/constrarg.ml b/interp/constrarg.ml deleted file mode 100644 index ca828102b..000000000 --- a/interp/constrarg.ml +++ /dev/null @@ -1,74 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Loc -open Tacexpr -open Misctypes -open Genarg -open Geninterp - -let make0 ?dyn name = - let wit = Genarg.make0 name in - let () = Geninterp.register_val0 wit dyn in - wit - -(** This is a hack for now, to break the dependency of Genarg on constr-related - types. We should use dedicated functions someday. *) - -let loc_of_or_by_notation f = function - | AN c -> f c - | ByNotation (loc,s,_) -> loc - -let wit_int_or_var = - make0 ~dyn:(val_tag (topwit Stdarg.wit_int)) "int_or_var" - -let wit_intro_pattern : (Constrexpr.constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type = - make0 "intropattern" - -let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = - make0 "tactic" - -let wit_ltac = make0 ~dyn:(val_tag (topwit Stdarg.wit_unit)) "ltac" - -let wit_ident = - make0 "ident" - -let wit_var = - make0 ~dyn:(val_tag (topwit wit_ident)) "var" - -let wit_ref = make0 "ref" - -let wit_quant_hyp = make0 "quant_hyp" - -let wit_constr = - make0 "constr" - -let wit_uconstr = make0 "uconstr" - -let wit_open_constr = make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr" - -let wit_constr_with_bindings = make0 "constr_with_bindings" - -let wit_bindings = make0 "bindings" - -let wit_red_expr = make0 "redexpr" - -let wit_clause_dft_concl = - make0 "clause_dft_concl" - -let wit_destruction_arg = - make0 "destruction_arg" - -(** Aliases *) - -let wit_reference = wit_ref -let wit_global = wit_ref -let wit_clause = wit_clause_dft_concl -let wit_quantified_hypothesis = wit_quant_hyp -let wit_intropattern = wit_intro_pattern -let wit_redexpr = wit_red_expr diff --git a/interp/constrarg.mli b/interp/constrarg.mli deleted file mode 100644 index 6ccd944d4..000000000 --- a/interp/constrarg.mli +++ /dev/null @@ -1,87 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** Generic arguments based on [constr]. We put them here to avoid a dependency - of Genarg in [constr]-related interfaces. *) - -open Loc -open Names -open Term -open Libnames -open Globnames -open Genredexpr -open Pattern -open Constrexpr -open Tacexpr -open Misctypes -open Genarg - -(** FIXME: nothing to do there. *) -val loc_of_or_by_notation : ('a -> Loc.t) -> 'a or_by_notation -> Loc.t - -(** {5 Additional generic arguments} *) - -val wit_int_or_var : (int or_var, int or_var, int) genarg_type - -val wit_intro_pattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type - -val wit_ident : Id.t uniform_genarg_type - -val wit_var : (Id.t located, Id.t located, Id.t) genarg_type - -val wit_ref : (reference, global_reference located or_var, global_reference) genarg_type - -val wit_quant_hyp : quantified_hypothesis uniform_genarg_type - -val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type - -val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type - -val wit_open_constr : - (constr_expr, glob_constr_and_expr, constr) genarg_type - -val wit_constr_with_bindings : - (constr_expr with_bindings, - glob_constr_and_expr with_bindings, - constr with_bindings delayed_open) genarg_type - -val wit_bindings : - (constr_expr bindings, - glob_constr_and_expr bindings, - constr bindings delayed_open) genarg_type - -val wit_red_expr : - ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, - (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, - (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type - -val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Geninterp.Val.t) genarg_type - -(** [wit_ltac] is subtly different from [wit_tactic]: they only change for their - toplevel interpretation. The one of [wit_ltac] forces the tactic and - discards the result. *) -val wit_ltac : (raw_tactic_expr, glob_tactic_expr, unit) genarg_type - -val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type - -val wit_destruction_arg : - (constr_expr with_bindings destruction_arg, - glob_constr_and_expr with_bindings destruction_arg, - delayed_open_constr_with_bindings destruction_arg) genarg_type - -(** Aliases for compatibility *) - -val wit_reference : (reference, global_reference located or_var, global_reference) genarg_type -val wit_global : (reference, global_reference located or_var, global_reference) genarg_type -val wit_clause : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type -val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type -val wit_intropattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type -val wit_redexpr : - ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, - (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, - (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 04429851f..59c24900d 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -382,18 +382,18 @@ let rec prod_constr_expr c = function let coerce_reference_to_id = function | Ident (_,id) -> id | Qualid (loc,_) -> - CErrors.user_err_loc (loc, "coerce_reference_to_id", - str "This expression should be a simple identifier.") + CErrors.user_err ~loc ~hdr:"coerce_reference_to_id" + (str "This expression should be a simple identifier.") let coerce_to_id = function | CRef (Ident (loc,id),_) -> (loc,id) - | a -> CErrors.user_err_loc - (constr_loc a,"coerce_to_id", - str "This expression should be a simple identifier.") + | a -> CErrors.user_err ~loc:(constr_loc a) + ~hdr:"coerce_to_id" + (str "This expression should be a simple identifier.") let coerce_to_name = function | CRef (Ident (loc,id),_) -> (loc,Name id) | CHole (loc,_,_,_) -> (loc,Anonymous) - | a -> CErrors.user_err_loc - (constr_loc a,"coerce_to_name", - str "This expression should be a name.") + | a -> CErrors.user_err + ~loc:(constr_loc a) ~hdr:"coerce_to_name" + (str "This expression should be a name.") diff --git a/interp/constrextern.ml b/interp/constrextern.ml index dd8a48b85..3077231be 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -94,8 +94,8 @@ let is_record indsp = let encode_record r = let indsp = global_inductive r in if not (is_record indsp) then - user_err_loc (loc_of_reference r,"encode_record", - str "This type is not a structure type."); + user_err ~loc:(loc_of_reference r) ~hdr:"encode_record" + (str "This type is not a structure type."); indsp module PrintingRecordRecord = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c916fcd88..3ed8733df 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -154,17 +154,17 @@ let explain_internalization_error e = | BadPatternsNumber (n1,n2) -> explain_bad_patterns_number n1 n2 in pp ++ str "." -let error_bad_inductive_type loc = - user_err_loc (loc,"",str +let error_bad_inductive_type ?loc = + user_err ?loc (str "This should be an inductive type applied to patterns.") -let error_parameter_not_implicit loc = - user_err_loc (loc,"", str +let error_parameter_not_implicit ?loc = + user_err ?loc (str "The parameters do not bind in patterns;" ++ spc () ++ str "they must be replaced by '_'.") -let error_ldots_var loc = - user_err_loc (loc,"",str "Special token " ++ pr_id ldots_var ++ +let error_ldots_var ?loc = + user_err ?loc (str "Special token " ++ pr_id ldots_var ++ str " is for use in the Notation command.") (**********************************************************************) @@ -262,15 +262,15 @@ let pr_scope_stack = function | l -> str "scope stack " ++ str "[" ++ prlist_with_sep pr_comma str l ++ str "]" -let error_inconsistent_scope loc id scopes1 scopes2 = - user_err_loc (loc,"set_var_scope", - pr_id id ++ str " is here used in " ++ +let error_inconsistent_scope ?loc id scopes1 scopes2 = + user_err ?loc ~hdr:"set_var_scope" + (pr_id id ++ str " is here used in " ++ pr_scope_stack scopes2 ++ strbrk " while it was elsewhere used in " ++ pr_scope_stack scopes1) -let error_expect_binder_notation_type loc id = - user_err_loc (loc,"", - pr_id id ++ +let error_expect_binder_notation_type ?loc id = + user_err ?loc + (pr_id id ++ str " is expected to occur in binding position in the right-hand side.") let set_var_scope loc id istermvar env ntnvars = @@ -284,12 +284,12 @@ let set_var_scope loc id istermvar env ntnvars = | Some (tmp, scope) -> let s1 = make_current_scope tmp scope in let s2 = make_current_scope env.tmp_scope env.scopes in - if not (List.equal String.equal s1 s2) then error_inconsistent_scope loc id s1 s2 + if not (List.equal String.equal s1 s2) then error_inconsistent_scope ~loc id s1 s2 end in match typ with | NtnInternTypeBinder -> - if istermvar then error_expect_binder_notation_type loc id + if istermvar then error_expect_binder_notation_type ~loc id | NtnInternTypeConstr -> (* We need sometimes to parse idents at a constr level for factorization and we cannot enforce this constraint: @@ -366,19 +366,19 @@ let check_hidden_implicit_parameters id impls = | (Inductive indparams,_,_,_) -> Id.List.mem id indparams | _ -> false) impls then - errorlabstrm "" (strbrk "A parameter of an inductive type " ++ + user_err (strbrk "A parameter of an inductive type " ++ pr_id id ++ strbrk " is not allowed to be used as a bound variable in the type of its constructor.") let push_name_env ?(global_level=false) ntnvars implargs env = function | loc,Anonymous -> if global_level then - user_err_loc (loc,"", str "Anonymous variables not allowed"); + user_err ~loc (str "Anonymous variables not allowed"); env | loc,Name id -> check_hidden_implicit_parameters id env.impls ; if Id.Map.is_empty ntnvars && Id.equal id ldots_var - then error_ldots_var loc; + then error_ldots_var ~loc; set_var_scope loc id false env ntnvars; if global_level then Dumpglob.dump_definition (loc,id) true "var" else Dumpglob.dump_binding loc id; @@ -660,23 +660,13 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = let arg = match arg with | None -> None | Some arg -> - let open Tacexpr in - let open Genarg in - let wit = glbwit Constrarg.wit_tactic in - let body = - if has_type arg wit then out_gen wit arg - else assert false (** FIXME *) - in - let mk_env id (c, (tmp_scope, subscopes)) accu = + let mk_env (c, (tmp_scope, subscopes)) = let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in let gc = intern nenv c in - let c = ConstrMayEval (Genredexpr.ConstrTerm (gc, Some c)) in - ((loc, id), c) :: accu + (gc, Some c) in - let bindings = Id.Map.fold mk_env terms [] in - let tac = TacLetIn (false, bindings, body) in - let arg = in_gen wit tac in - Some arg + let bindings = Id.Map.map mk_env terms in + Some (Genintern.generic_substitute_notation bindings arg) in GHole (loc, knd, naming, arg) | NBinderList (x,y,iter,terminator) -> @@ -764,7 +754,7 @@ let string_of_ty = function let gvar (loc, id) us = match us with | None -> GVar (loc, id) | Some _ -> - user_err_loc (loc, "", str "Variable " ++ pr_id id ++ + user_err ~loc (str "Variable " ++ pr_id id ++ str " cannot have a universe instance") let intern_var genv (ltacvars,ntnvars) namedctx loc id us = @@ -788,12 +778,12 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id us = (* Is [id] the special variable for recursive notations *) else if Id.equal id ldots_var then if Id.Map.is_empty ntnvars - then error_ldots_var loc + then error_ldots_var ~loc else gvar (loc,id) us, [], [], [] else if Id.Set.mem id ltacvars.ltac_bound then (* Is [id] bound to a free name in ltac (this is an ltac error message) *) - user_err_loc (loc,"intern_var", - str "variable " ++ pr_id id ++ str " should be bound to a term.") + user_err ~loc ~hdr:"intern_var" + (str "variable " ++ pr_id id ++ str " should be bound to a term.") else (* Is [id] a goal or section variable *) let _ = Context.Named.lookup id namedctx in @@ -825,7 +815,7 @@ let find_appl_head_data c = | x -> x,[],[],[] let error_not_enough_arguments loc = - user_err_loc (loc,"",str "Abbreviation is not applied enough.") + user_err ~loc (str "Abbreviation is not applied enough.") let check_no_explicitation l = let is_unset (a, b) = match b with None -> false | Some _ -> true in @@ -834,7 +824,7 @@ let check_no_explicitation l = | [] -> () | (_, None) :: _ -> assert false | (_, Some (loc, _)) :: _ -> - user_err_loc (loc,"",str"Unexpected explicitation of the argument of an abbreviation.") + user_err ~loc (str"Unexpected explicitation of the argument of an abbreviation.") let dump_extended_global loc = function | TrueGlobal ref -> (*feedback_global loc ref;*) Dumpglob.add_glob loc ref @@ -847,7 +837,7 @@ let intern_reference ref = let qid = qualid_of_reference ref in let r = try intern_extended_global_of_qualid qid - with Not_found -> error_global_not_found_loc (fst qid) (snd qid) + with Not_found -> error_global_not_found ~loc:(fst qid) (snd qid) in Smartlocate.global_of_extended_global r @@ -872,7 +862,7 @@ let intern_qualid loc qid intern env lvar us args = | Some _, GApp (loc, GRef (loc', ref, None), arg) -> GApp (loc, GRef (loc', ref, us), arg) | Some _, _ -> - user_err_loc (loc, "", str "Notation " ++ pr_qualid qid ++ + user_err ~loc (str "Notation " ++ pr_qualid qid ++ str " cannot have a universe instance, its expanded head does not start with a reference") in @@ -888,7 +878,7 @@ let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = | Qualid (loc, qid) -> let r,projapp,args2 = try intern_qualid loc qid intern env ntnvars us args - with Not_found -> error_global_not_found_loc loc qid + with Not_found -> error_global_not_found ~loc qid in let x, imp, scopes, l = find_appl_head_data r in (x,imp,scopes,l), args2 @@ -904,7 +894,7 @@ let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then (gvar (loc,id) us, [], [], []), args - else error_global_not_found_loc loc qid + else error_global_not_found ~loc qid let interp_reference vars r = let (r,_,_,_),_ = @@ -982,7 +972,7 @@ let check_number_of_pattern loc n l = let check_or_pat_variables loc ids idsl = if List.exists (fun ids' -> not (List.eq_set Id.equal ids ids')) idsl then - user_err_loc (loc, "", str + user_err ~loc (str "The components of this disjunctive pattern must bind the same variables.") (** Use only when params were NOT asked to the user. @@ -991,7 +981,7 @@ let check_constructor_length env loc cstr len_pl pl0 = let n = len_pl + List.length pl0 in if Int.equal n (Inductiveops.constructor_nallargs cstr) then false else (Int.equal n (Inductiveops.constructor_nalldecls cstr) || - (error_wrong_numarg_constructor_loc loc env cstr + (error_wrong_numarg_constructor ~loc env cstr (Inductiveops.constructor_nrealargs cstr))) let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 = @@ -1016,14 +1006,14 @@ let add_implicits_check_constructor_length env loc c len_pl1 pl2 = let nargs = Inductiveops.constructor_nallargs c in let nargs' = Inductiveops.constructor_nalldecls c in let impls_st = implicits_of_global (ConstructRef c) in - add_implicits_check_length (error_wrong_numarg_constructor_loc loc env c) + add_implicits_check_length (error_wrong_numarg_constructor ~loc env c) nargs nargs' impls_st len_pl1 pl2 let add_implicits_check_ind_length env loc c len_pl1 pl2 = let nallargs = inductive_nallargs_env env c in let nalldecls = inductive_nalldecls_env env c in let impls_st = implicits_of_global (IndRef c) in - add_implicits_check_length (error_wrong_numarg_inductive_loc loc env c) + add_implicits_check_length (error_wrong_numarg_inductive ~loc env c) nallargs nalldecls impls_st len_pl1 pl2 (** Do not raise NotEnoughArguments thanks to preconditions*) @@ -1034,7 +1024,7 @@ let chop_params_pattern loc ind args with_letin = assert (nparams <= List.length args); let params,args = List.chop nparams args in List.iter (function PatVar(_,Anonymous) -> () - | PatVar (loc',_) | PatCstr(loc',_,_,_) -> error_parameter_not_implicit loc') params; + | PatVar (loc',_) | PatCstr(loc',_,_,_) -> error_parameter_not_implicit ~loc:loc') params; args let find_constructor loc add_params ref = @@ -1042,10 +1032,10 @@ let find_constructor loc add_params ref = | ConstructRef cstr -> cstr | IndRef _ -> let error = str "There is an inductive name deep in a \"in\" clause." in - user_err_loc (loc, "find_constructor", error) + user_err ~loc ~hdr:"find_constructor" error | ConstRef _ | VarRef _ -> let error = str "This reference is not a constructor." in - user_err_loc (loc, "find_constructor", error) + user_err ~loc ~hdr:"find_constructor" error in cstr, match add_params with | Some nb_args -> @@ -1067,7 +1057,7 @@ let check_duplicate loc fields = match dups with | [] -> () | (r, _) :: _ -> - user_err_loc (loc, "", str "This record defines several times the field " ++ + user_err ~loc (str "This record defines several times the field " ++ pr_reference r ++ str ".") (** [sort_fields ~complete loc fields completer] expects a list @@ -1092,8 +1082,8 @@ let sort_fields ~complete loc fields completer = let gr = global_reference_of_reference first_field_ref in (gr, Recordops.find_projection gr) with Not_found -> - user_err_loc (loc_of_reference first_field_ref, "intern", - pr_reference first_field_ref ++ str": Not a projection") + user_err ~loc:(loc_of_reference first_field_ref) ~hdr:"intern" + (pr_reference first_field_ref ++ str": Not a projection") in (* the number of parameters *) let nparams = record.Recordops.s_EXPECTEDPARAM in @@ -1123,7 +1113,7 @@ let sort_fields ~complete loc fields completer = by a let-in in the record declaration (its value is fixed from other fields). *) if first_field && not regular && complete then - user_err_loc (loc, "", str "No local fields allowed in a record construction.") + user_err ~loc (str "No local fields allowed in a record construction.") else if first_field then build_proj_list projs proj_kinds (idx+1) ~acc_first_idx:idx acc else if not regular && complete then @@ -1136,7 +1126,7 @@ let sort_fields ~complete loc fields completer = | None :: projs -> if complete then (* we don't want anonymous fields *) - user_err_loc (loc, "", str "This record contains anonymous fields.") + user_err ~loc (str "This record contains anonymous fields.") else (* anonymous arguments don't appear in proj_kinds *) build_proj_list projs proj_kinds (idx+1) ~acc_first_idx acc @@ -1150,15 +1140,14 @@ let sort_fields ~complete loc fields completer = | (field_ref, field_value) :: fields -> let field_glob_ref = try global_reference_of_reference field_ref with Not_found -> - user_err_loc (loc_of_reference field_ref, "intern", - str "The field \"" ++ pr_reference field_ref ++ str "\" does not exist.") in + user_err ~loc:(loc_of_reference field_ref) ~hdr:"intern" + (str "The field \"" ++ pr_reference field_ref ++ str "\" does not exist.") in let remaining_projs, (field_index, _) = let the_proj (idx, glob_ref) = eq_gr field_glob_ref glob_ref in try CList.extract_first the_proj remaining_projs with Not_found -> - user_err_loc - (loc, "", - str "This record contains fields of different records.") + user_err ~loc + (str "This record contains fields of different records.") in index_fields fields remaining_projs ((field_index, field_value) :: acc) | [] -> @@ -1229,7 +1218,7 @@ let drop_notations_pattern looked_for = if top then looked_for g else match g with ConstructRef _ -> () | _ -> raise Not_found with Not_found -> - error_invalid_pattern_notation loc + error_invalid_pattern_notation ~loc () in let test_kind top = if top then looked_for else function ConstructRef _ -> () | _ -> raise Not_found @@ -1354,8 +1343,8 @@ let drop_notations_pattern looked_for = List.map2 (fun x -> in_not false loc (x,snd scopes) fullsubst []) argscs1 pl @ List.map (in_pat false scopes) args, []) | NList (x,y,iter,terminator,lassoc) -> - if not (List.is_empty args) then user_err_loc - (loc,"",strbrk "Application of arguments to a recursive notation not supported in patterns."); + if not (List.is_empty args) then user_err ~loc + (strbrk "Application of arguments to a recursive notation not supported in patterns."); (try (* All elements of the list are in scopes (scopt,subscopes) *) let (l,(scopt,subscopes)) = Id.Map.find x substlist in @@ -1370,7 +1359,7 @@ let drop_notations_pattern looked_for = | NHole _ -> let () = assert (List.is_empty args) in RCPatAtom (loc, None) - | t -> error_invalid_pattern_notation loc + | t -> error_invalid_pattern_notation ~loc () in in_pat true let rec intern_pat genv aliases pat = @@ -1422,8 +1411,8 @@ let rec intern_pat genv aliases pat = [pattern] rule. *) let rec check_no_patcast = function | CPatCast (loc,_,_) -> - CErrors.user_err_loc (loc, "check_no_patcast", - Pp.strbrk "Casts are not supported here.") + CErrors.user_err ~loc ~hdr:"check_no_patcast" + (Pp.strbrk "Casts are not supported here.") | CPatDelimiters(_,_,p) | CPatAlias(_,p,_) -> check_no_patcast p | CPatCstr(_,_,opl,pl) -> @@ -1456,11 +1445,11 @@ let intern_ind_pattern genv scopes pat = let no_not = try drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) scopes pat - with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type loc + with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type ~loc in match no_not with | RCPatCstr (loc, head, expl_pl, pl) -> - let c = (function IndRef ind -> ind | _ -> error_bad_inductive_type loc) head in + let c = (function IndRef ind -> ind | _ -> error_bad_inductive_type ~loc) head in let with_letin, pl2 = add_implicits_check_ind_length genv loc c (List.length expl_pl) pl in let idslpl1 = List.rev_map (intern_pat genv empty_alias) expl_pl in @@ -1468,8 +1457,8 @@ let intern_ind_pattern genv scopes pat = (with_letin, match product_of_cases_patterns [] (List.rev_append idslpl1 idslpl2) with | _,[_,pl] -> (c,chop_params_pattern loc c pl with_letin) - | _ -> error_bad_inductive_type loc) - | x -> error_bad_inductive_type (raw_cases_pattern_expr_loc x) + | _ -> error_bad_inductive_type ~loc) + | x -> error_bad_inductive_type ~loc:(raw_cases_pattern_expr_loc x) (**********************************************************************) (* Utilities for application *) @@ -1508,10 +1497,10 @@ let extract_explicit_arg imps args = let id = match pos with | ExplByName id -> if not (exists_implicit_name id imps) then - user_err_loc - (loc,"",str "Wrong argument name: " ++ pr_id id ++ str "."); + user_err ~loc + (str "Wrong argument name: " ++ pr_id id ++ str "."); if Id.Map.mem id eargs then - user_err_loc (loc,"",str "Argument name " ++ pr_id id + user_err ~loc (str "Argument name " ++ pr_id id ++ str " occurs more than once."); id | ExplByPos (p,_id) -> @@ -1521,11 +1510,11 @@ let extract_explicit_arg imps args = if not (is_status_implicit imp) then failwith "imp"; name_of_implicit imp with Failure _ (* "nth" | "imp" *) -> - user_err_loc - (loc,"",str"Wrong argument position: " ++ int p ++ str ".") + user_err ~loc + (str"Wrong argument position: " ++ int p ++ str ".") in if Id.Map.mem id eargs then - user_err_loc (loc,"",str"Argument at position " ++ int p ++ + user_err ~loc (str"Argument at position " ++ int p ++ str " is mentioned more than once."); id in (Id.Map.add id (loc, a) eargs, rargs) @@ -1576,7 +1565,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = (function | BDRawDef a -> a | BDPattern (loc,_,_,_,_) -> - Loc.raise loc (Stream.Error "pattern with quote not allowed after fix")) rbl in + Loc.raise ~loc (Stream.Error "pattern with quote not allowed after fix")) rbl in ((n, ro), bl, intern_type env' ty, env')) dl in let idl = Array.map2 (fun (_,_,_,_,bd) (a,b,c,env') -> let env'' = List.fold_left_i (fun i en name -> @@ -1603,7 +1592,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = (fun ((loc,id),bl,ty,_) -> let (env',rbl) = List.fold_left intern_local_binder (env,[]) bl in let rbl = List.map (function BDRawDef a -> a | BDPattern _ -> - Loc.raise loc (Stream.Error "pattern with quote not allowed after cofix")) rbl in + Loc.raise ~loc (Stream.Error "pattern with quote not allowed after cofix")) rbl in (List.rev rbl, intern_type env' ty,env')) dl in let idl = Array.map2 (fun (_,_,_,bd) (b,c,env') -> @@ -1681,7 +1670,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = in begin match fields with - | None -> user_err_loc (loc, "intern", str"No constructor inference.") + | None -> user_err ~loc ~hdr:"intern" (str"No constructor inference.") | Some (n, constrname, args) -> let pars = List.make n (CHole (loc, None, Misctypes.IntroAnonymous, None)) in let app = CAppExpl (loc, (None, constrname,None), List.rev_append pars args) in @@ -1751,7 +1740,9 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = let k = match k with | None -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in - Evar_kinds.QuestionMark st + (match naming with + | Misctypes.IntroIdentifier id -> Evar_kinds.NamedHole id + | _ -> Evar_kinds.QuestionMark st) | Some k -> k in let solve = match solve with @@ -1904,7 +1895,7 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = | (imp::impl', []) -> if not (Id.Map.is_empty eargs) then (let (id,(loc,_)) = Id.Map.choose eargs in - user_err_loc (loc,"",str "Not enough non implicit \ + user_err ~loc (str "Not enough non implicit \ arguments to accept the argument bound to " ++ pr_id id ++ str".")); [] @@ -1935,8 +1926,8 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = intern env c with InternalizationError (loc,e) -> - user_err_loc (loc,"internalize", - explain_internalization_error e) + user_err ~loc ~hdr:"internalize" + (explain_internalization_error e) (**************************************************************************) (* Functions to translate constr_expr into glob_constr *) @@ -1975,7 +1966,7 @@ let intern_pattern globalenv patt = intern_cases_pattern globalenv (None,[]) empty_alias patt with InternalizationError (loc,e) -> - user_err_loc (loc,"internalize",explain_internalization_error e) + user_err ~loc ~hdr:"internalize" (explain_internalization_error e) (*********************************************************************) @@ -2086,13 +2077,13 @@ let intern_context global_level env impl_env binders = (function | BDRawDef a -> a | BDPattern (loc,_,_,_,_) -> - Loc.raise loc (Stream.Error "pattern with quote not allowed here")) bl in + Loc.raise ~loc (Stream.Error "pattern with quote not allowed here")) bl in (env, bl)) ({ids = extract_ids env; unb = false; tmp_scope = None; scopes = []; impls = impl_env}, []) binders in (lenv.impls, List.map snd bl) with InternalizationError (loc,e) -> - user_err_loc (loc,"internalize", explain_internalization_error e) + user_err ~loc ~hdr:"internalize" (explain_internalization_error e) let interp_rawcontext_evars env evdref k bl = let (env, par, _, impls) = diff --git a/interp/coqlib.ml b/interp/coqlib.ml index 588637b76..9539980f0 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -86,7 +86,7 @@ let check_required_library d = (Loc.ghost,make_qualid (DirPath.make (List.rev prefix)) m) *) (* or failing ...*) - errorlabstrm "Coqlib.check_required_library" + user_err ~hdr:"Coqlib.check_required_library" (str "Library " ++ pr_dirpath dir ++ str " has to be required first.") (************************************************************************) diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index b020f8945..9f549b0c0 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -173,32 +173,33 @@ let cook_notation df sc = (* - all single quotes in terminal tokens are doubled *) (* - characters < 32 are represented by '^A, '^B, '^C, etc *) (* The output is decoded in function Index.prepare_entry of coqdoc *) - let ntn = String.make (String.length df * 5) '_' in + let ntn = Bytes.make (String.length df * 5) '_' in let j = ref 0 in let l = String.length df - 1 in let i = ref 0 in + let open Bytes in (* Bytes.set *) while !i <= l do assert (df.[!i] != ' '); if df.[!i] == '_' && (Int.equal !i l || df.[!i+1] == ' ') then (* Next token is a non-terminal *) - (ntn.[!j] <- 'x'; incr j; incr i) + (set ntn !j 'x'; incr j; incr i) else begin (* Next token is a terminal *) - ntn.[!j] <- '\''; incr j; + set ntn !j '\''; incr j; while !i <= l && df.[!i] != ' ' do if df.[!i] < ' ' then let c = char_of_int (int_of_char 'A' + int_of_char df.[!i] - 1) in (String.blit ("'^" ^ String.make 1 c) 0 ntn !j 3; j := !j+3; incr i) else begin - if df.[!i] == '\'' then (ntn.[!j] <- '\''; incr j); - ntn.[!j] <- df.[!i]; incr j; incr i + if df.[!i] == '\'' then (set ntn !j '\''; incr j); + set ntn !j df.[!i]; incr j; incr i end done; - ntn.[!j] <- '\''; incr j + set ntn !j '\''; incr j end; - if !i <= l then (ntn.[!j] <- '_'; incr j; incr i) + if !i <= l then (set ntn !j '_'; incr j; incr i) done; - let df = String.sub ntn 0 !j in + let df = Bytes.sub_string ntn 0 !j in match sc with Some sc -> ":" ^ sc ^ ":" ^ df | _ -> "::" ^ df let dump_notation_location posl df (((path,secpath),_),sc) = diff --git a/interp/genintern.ml b/interp/genintern.ml index d6bfd347f..be7abfa99 100644 --- a/interp/genintern.ml +++ b/interp/genintern.ml @@ -16,6 +16,7 @@ type glob_sign = { type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb type 'glb subst_fun = substitution -> 'glb -> 'glb +type 'glb ntn_subst_fun = Tactypes.glob_constr_and_expr Id.Map.t -> 'glb -> 'glb module InternObj = struct @@ -31,8 +32,16 @@ struct let default _ = None end +module NtnSubstObj = +struct + type ('raw, 'glb, 'top) obj = 'glb ntn_subst_fun + let name = "notation_subst" + let default _ = None +end + module Intern = Register (InternObj) module Subst = Register (SubstObj) +module NtnSubst = Register (NtnSubstObj) let intern = Intern.obj let register_intern0 = Intern.register0 @@ -50,3 +59,12 @@ let generic_substitute subs (GenArg (Glbwit wit, v)) = in_gen (glbwit wit) (substitute wit subs v) let () = Hook.set Detyping.subst_genarg_hook generic_substitute + +(** Notation substitution *) + +let substitute_notation = NtnSubst.obj +let register_ntn_subst0 = NtnSubst.register0 + +let generic_substitute_notation env (GenArg (Glbwit wit, v)) = + let v = substitute_notation wit env v in + in_gen (glbwit wit) v diff --git a/interp/genintern.mli b/interp/genintern.mli index 4b244b38d..4b0354be3 100644 --- a/interp/genintern.mli +++ b/interp/genintern.mli @@ -32,6 +32,14 @@ val substitute : ('raw, 'glb, 'top) genarg_type -> 'glb subst_fun val generic_substitute : glob_generic_argument subst_fun +(** {5 Notation functions} *) + +type 'glb ntn_subst_fun = Tactypes.glob_constr_and_expr Id.Map.t -> 'glb -> 'glb + +val substitute_notation : ('raw, 'glb, 'top) genarg_type -> 'glb ntn_subst_fun + +val generic_substitute_notation : glob_generic_argument ntn_subst_fun + (** Registering functions *) val register_intern0 : ('raw, 'glb, 'top) genarg_type -> @@ -39,3 +47,6 @@ val register_intern0 : ('raw, 'glb, 'top) genarg_type -> val register_subst0 : ('raw, 'glb, 'top) genarg_type -> 'glb subst_fun -> unit + +val register_ntn_subst0 : ('raw, 'glb, 'top) genarg_type -> + 'glb ntn_subst_fun -> unit diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 10cfbe58f..77a8ed680 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -21,18 +21,20 @@ open Libobject open Nameops open Misctypes open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration (*i*) let generalizable_table = Summary.ref Id.Pred.empty ~name:"generalizable-ident" let declare_generalizable_ident table (loc,id) = if not (Id.equal id (root_of_id id)) then - user_err_loc(loc,"declare_generalizable_ident", - (pr_id id ++ str + user_err ~loc ~hdr:"declare_generalizable_ident" + ((pr_id id ++ str " is not declarable as generalizable identifier: it must have no trailing digits, quote, or _")); if Id.Pred.mem id table then - user_err_loc(loc,"declare_generalizable_ident", - (pr_id id++str" is already declared as a generalizable identifier")) + user_err ~loc ~hdr:"declare_generalizable_ident" + ((pr_id id++str" is already declared as a generalizable identifier")) else Id.Pred.add id table let add_generalizable gen table = @@ -78,8 +80,8 @@ let is_freevar ids env x = (* Auxiliary functions for the inference of implicitly quantified variables. *) let ungeneralizable loc id = - user_err_loc (loc, "Generalization", - str "Unbound and ungeneralizable variable " ++ pr_id id) + user_err ~loc ~hdr:"Generalization" + (str "Unbound and ungeneralizable variable " ++ pr_id id) let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = let found loc id bdvars l = @@ -186,7 +188,7 @@ let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.emp vars let rec make_fresh ids env x = - if is_freevar ids env x then x else make_fresh ids env (Nameops.lift_subscript x) + if is_freevar ids env x then x else make_fresh ids env (Nameops.increment_subscript x) let next_name_away_from na avoid = match na with @@ -198,12 +200,12 @@ let combine_params avoid fn applied needed = List.partition (function (t, Some (loc, ExplByName id)) -> - let is_id (_, decl) = match get_name decl with + let is_id (_, decl) = match RelDecl.get_name decl with | Name id' -> Id.equal id id' | Anonymous -> false in if not (List.exists is_id needed) then - user_err_loc (loc,"",str "Wrong argument name: " ++ Nameops.pr_id id); + user_err ~loc (str "Wrong argument name: " ++ Nameops.pr_id id); true | _ -> false) applied in @@ -237,12 +239,12 @@ let combine_params avoid fn applied needed = aux (t' :: ids) avoid' app need | (x,_) :: _, [] -> - user_err_loc (Constrexpr_ops.constr_loc x,"",str "Typeclass does not expect more arguments") + user_err ~loc:(Constrexpr_ops.constr_loc x) (str "Typeclass does not expect more arguments") in aux [] avoid applied needed let combine_params_freevar = fun avoid (_, decl) -> - let id' = next_name_away_from (get_name decl) avoid in + let id' = next_name_away_from (RelDecl.get_name decl) avoid in (CRef (Ident (Loc.ghost, id'),None), Id.Set.add id' avoid) let destClassApp cl = diff --git a/interp/interp.mllib b/interp/interp.mllib index 96b52959a..607af82a0 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -1,5 +1,4 @@ Stdarg -Constrarg Genintern Constrexpr_ops Notation_ops diff --git a/interp/modintern.ml b/interp/modintern.ml index e5dce5ccf..d4ade7058 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -26,16 +26,16 @@ let error_not_a_module_loc kind loc qid = | ModType -> Modops.ModuleTypingError (Modops.NotAModuleType s) | ModAny -> ModuleInternalizationError (NotAModuleNorModtype s) in - Loc.raise loc e + Loc.raise ~loc e let error_application_to_not_path loc me = - Loc.raise loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me)) + Loc.raise ~loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me)) let error_incorrect_with_in_module loc = - Loc.raise loc (ModuleInternalizationError IncorrectWithInModule) + Loc.raise ~loc (ModuleInternalizationError IncorrectWithInModule) let error_application_to_module_type loc = - Loc.raise loc (ModuleInternalizationError IncorrectModuleApplication) + Loc.raise ~loc (ModuleInternalizationError IncorrectModuleApplication) (** Searching for a module name in the Nametab. diff --git a/interp/notation.ml b/interp/notation.ml index 389a1c9df..66d3c9185 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -20,6 +20,9 @@ open Notation_term open Glob_term open Glob_ops open Ppextend +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (*i*) (*s A scope is a set of notations; it includes @@ -95,7 +98,7 @@ let declare_scope scope = scope_map := String.Map.add scope empty_scope !scope_map let error_unknown_scope sc = - errorlabstrm "Notation" + user_err ~hdr:"Notation" (str "Scope " ++ str sc ++ str " is not declared.") let find_scope scope = @@ -208,7 +211,7 @@ let remove_delimiters scope = let sc = find_scope scope in let newsc = { sc with delimiters = None } in match sc.delimiters with - | None -> CErrors.errorlabstrm "" (str "No bound key for scope " ++ str scope ++ str ".") + | None -> CErrors.user_err (str "No bound key for scope " ++ str scope ++ str ".") | Some key -> scope_map := String.Map.add scope newsc !scope_map; try @@ -220,8 +223,8 @@ let remove_delimiters scope = let find_delimiters_scope loc key = try String.Map.find key !delimiters_map with Not_found -> - user_err_loc - (loc, "find_delimiters", str "Unknown scope delimiting key " ++ str key ++ str ".") + user_err ~loc ~hdr:"find_delimiters" + (str "Unknown scope delimiting key " ++ str key ++ str ".") (* Uninterpretation tables *) @@ -337,8 +340,8 @@ let declare_string_interpreter sc dir interp (patl,uninterp,inpat) = let check_required_module loc sc (sp,d) = try let _ = Nametab.global_of_path sp in () with Not_found -> - user_err_loc (loc,"prim_token_interpreter", - str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") + user_err ~loc ~hdr:"prim_token_interpreter" + (str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") (* Look if some notation or numeral printer in [scope] can be used in the scope stack [scopes], and if yes, using delimiters or not *) @@ -458,8 +461,8 @@ let interp_prim_token_gen g loc p local_scopes = let p_as_ntn = try notation_of_prim_token p with Not_found -> "" in try find_interpretation p_as_ntn (find_prim_token g loc p) scopes with Not_found -> - user_err_loc (loc,"interp_prim_token", - (match p with + user_err ~loc ~hdr:"interp_prim_token" + ((match p with | Numeral n -> str "No interpretation for numeral " ++ str (to_string n) | String s -> str "No interpretation for string " ++ qs s) ++ str ".") @@ -483,8 +486,8 @@ let interp_notation loc ntn local_scopes = let scopes = make_current_scopes local_scopes in try find_interpretation ntn (find_notation ntn) scopes with Not_found -> - user_err_loc - (loc,"",str "Unknown interpretation for notation \"" ++ str ntn ++ str "\".") + user_err ~loc + (str "Unknown interpretation for notation \"" ++ str ntn ++ str "\".") let uninterp_notations c = List.map_append (fun key -> keymap_find key !notations_key_table) @@ -684,7 +687,7 @@ let discharge_arguments_scope (_,(req,r,n,l,_)) = let n = try let vars = Lib.variable_section_segment_of_reference r in - List.length (List.filter (fun (_,_,b,_) -> b = None) vars) + vars |> List.map fst |> List.filter is_local_assum |> List.length with Not_found (* Not a ref defined in this section *) -> 0 in Some (req,Lib.discharge_global r,n,l,[]) @@ -888,11 +891,11 @@ let global_reference_of_notation test (ntn,(sc,c,_)) = | _ -> None let error_ambiguous_notation loc _ntn = - user_err_loc (loc,"",str "Ambiguous notation.") + user_err ~loc (str "Ambiguous notation.") let error_notation_not_reference loc ntn = - user_err_loc (loc,"", - str "Unable to interpret " ++ quote (str ntn) ++ + user_err ~loc + (str "Unable to interpret " ++ quote (str ntn) ++ str " as a reference.") let interp_notation_as_global_reference loc test ntn sc = @@ -924,19 +927,19 @@ let locate_notation prglob ntn scope = match ntns with | [] -> str "Unknown notation" | _ -> - t (str "Notation " ++ - tab () ++ str "Scope " ++ tab () ++ fnl () ++ + str "Notation" ++ fnl () ++ prlist (fun (ntn,l) -> let scope = find_default ntn scopes in prlist (fun (sc,r,(_,df)) -> hov 0 ( - pr_notation_info prglob df r ++ tbrk (1,2) ++ - (if String.equal sc default_scope then mt () else (str ": " ++ str sc)) ++ - tbrk (1,2) ++ - (if Option.equal String.equal (Some sc) scope then str "(default interpretation)" else mt ()) + pr_notation_info prglob df r ++ + (if String.equal sc default_scope then mt () + else (spc () ++ str ": " ++ str sc)) ++ + (if Option.equal String.equal (Some sc) scope + then spc () ++ str "(default interpretation)" else mt ()) ++ fnl ())) - l) ntns) + l) ntns let collect_notation_in_scope scope sc known = assert (not (String.equal scope default_scope)); @@ -1018,8 +1021,8 @@ let add_notation_extra_printing_rule ntn k v = let p, pp, gr = String.Map.find ntn !notation_rules in String.Map.add ntn (p, (k,v) :: pp, gr) !notation_rules with Not_found -> - user_err_loc (Loc.ghost,"add_notation_extra_printing_rule", - str "No such Notation.") + user_err ~hdr:"add_notation_extra_printing_rule" + (str "No such Notation.") (**********************************************************************) (* Synchronisation with reset *) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 0c5393cf4..7dbd94aa7 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -242,8 +242,8 @@ let split_at_recursive_part c = let subtract_loc loc1 loc2 = Loc.make_loc (fst (Loc.unloc loc1),fst (Loc.unloc loc2)-1) let check_is_hole id = function GHole _ -> () | t -> - user_err_loc (loc_of_glob_constr t,"", - strbrk "In recursive notation with binders, " ++ pr_id id ++ + user_err ~loc:(loc_of_glob_constr t) + (strbrk "In recursive notation with binders, " ++ pr_id id ++ strbrk " is expected to come without type.") let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b' @@ -294,8 +294,8 @@ let compare_recursive_parts found f f' (iterator,subc) = let loc1 = loc_of_glob_constr iterator in let loc2 = loc_of_glob_constr (Option.get !terminator) in (* Here, we would need a loc made of several parts ... *) - user_err_loc (subtract_loc loc1 loc2,"", - str "Both ends of the recursive pattern are the same.") + user_err ~loc:(subtract_loc loc1 loc2) + (str "Both ends of the recursive pattern are the same.") | Some (x,y,RecursiveTerms lassoc) -> let newfound,x,y,lassoc = if List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi2 !found) || @@ -338,8 +338,8 @@ let notation_constr_and_vars_of_glob_constr a = | GApp (_,GVar (loc,f),[c]) when Id.equal f ldots_var -> (* Fall on the second part of the recursive pattern w/o having found the first part *) - user_err_loc (loc,"", - str "Cannot find where the recursive pattern starts.") + user_err ~loc + (str "Cannot find where the recursive pattern starts.") | c -> aux' c and aux' = function @@ -394,7 +394,7 @@ let check_variables_and_reversibility nenv (found,foundrec,foundrecbinding) = let vars = Id.Map.filter filter nenv.ninterp_var_type in let check_recvar x = if Id.List.mem x found then - errorlabstrm "" (pr_id x ++ + user_err (pr_id x ++ strbrk " should only be used in the recursive part of a pattern.") in let check (x, y) = check_recvar x; check_recvar y in let () = List.iter check foundrec in @@ -413,7 +413,7 @@ let check_variables_and_reversibility nenv (found,foundrec,foundrecbinding) = in let check_pair s x y where = if not (List.mem_f (pair_equal Id.equal Id.equal) (x,y) where) then - errorlabstrm "" (strbrk "in the right-hand side, " ++ pr_id x ++ + user_err (strbrk "in the right-hand side, " ++ pr_id x ++ str " and " ++ pr_id y ++ strbrk " should appear in " ++ str s ++ str " position as part of a recursive pattern.") in let check_type x typ = diff --git a/interp/ppextend.ml b/interp/ppextend.ml index 37bbe0ce8..87ca25325 100644 --- a/interp/ppextend.ml +++ b/interp/ppextend.ml @@ -23,12 +23,9 @@ type ppbox = | PpHOVB of int | PpHVB of int | PpVB of int - | PpTB type ppcut = | PpBrk of int * int - | PpTbrk of int * int - | PpTab | PpFnl let ppcmd_of_box = function @@ -36,13 +33,10 @@ let ppcmd_of_box = function | PpHOVB n -> hov n | PpHVB n -> hv n | PpVB n -> v n - | PpTB -> t let ppcmd_of_cut = function - | PpTab -> tab () | PpFnl -> fnl () | PpBrk(n1,n2) -> brk(n1,n2) - | PpTbrk(n1,n2) -> tbrk(n1,n2) type unparsing = | UnpMetaVar of int * parenRelation diff --git a/interp/ppextend.mli b/interp/ppextend.mli index de7a42eee..09dc36943 100644 --- a/interp/ppextend.mli +++ b/interp/ppextend.mli @@ -23,12 +23,9 @@ type ppbox = | PpHOVB of int | PpHVB of int | PpVB of int - | PpTB type ppcut = | PpBrk of int * int - | PpTbrk of int * int - | PpTab | PpFnl val ppcmd_of_box : ppbox -> std_ppcmds -> std_ppcmds diff --git a/interp/reserve.ml b/interp/reserve.ml index 388ca0805..a4d4f4027 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -86,13 +86,13 @@ let in_reserved : Id.t * notation_constr -> obj = let declare_reserved_type_binding (loc,id) t = if not (Id.equal id (root_of_id id)) then - user_err_loc(loc,"declare_reserved_type", - (pr_id id ++ str + user_err ~loc ~hdr:"declare_reserved_type" + ((pr_id id ++ str " is not reservable: it must have no trailing digits, quote, or _")); begin try let _ = Id.Map.find id !reserve_table in - user_err_loc(loc,"declare_reserved_type", - (pr_id id++str" is already bound to a type")) + user_err ~loc ~hdr:"declare_reserved_type" + ((pr_id id++str" is already bound to a type")) with Not_found -> () end; add_anonymous_leaf (in_reserved (id,t)) diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 478774219..178c1c1f9 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -46,7 +46,7 @@ let locate_global_with_alias ?(head=false) (loc,qid) = if head then global_of_extended_global_head ref else global_of_extended_global ref with Not_found -> - user_err_loc (loc,"",pr_qualid qid ++ + user_err ~loc (pr_qualid qid ++ str " is bound to a notation that does not denote a reference.") let global_inductive_with_alias r = @@ -54,14 +54,14 @@ let global_inductive_with_alias r = try match locate_global_with_alias lqid with | IndRef ind -> ind | ref -> - user_err_loc (loc_of_reference r,"global_inductive", - pr_reference r ++ spc () ++ str "is not an inductive type.") - with Not_found -> Nametab.error_global_not_found_loc loc qid + user_err ~loc:(loc_of_reference r) ~hdr:"global_inductive" + (pr_reference r ++ spc () ++ str "is not an inductive type.") + with Not_found -> Nametab.error_global_not_found ~loc qid let global_with_alias ?head r = let (loc,qid as lqid) = qualid_of_reference r in try locate_global_with_alias ?head lqid - with Not_found -> Nametab.error_global_not_found_loc loc qid + with Not_found -> Nametab.error_global_not_found ~loc qid let smart_global ?head = function | AN r -> diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 2a7d52e3a..341ff5662 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -6,6 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Loc +open Misctypes +open Tactypes open Genarg open Geninterp @@ -29,7 +32,49 @@ let wit_string : string uniform_genarg_type = let wit_pre_ident : string uniform_genarg_type = make0 ~dyn:(val_tag (topwit wit_string)) "preident" +let loc_of_or_by_notation f = function + | AN c -> f c + | ByNotation (loc,s,_) -> loc + +let wit_int_or_var = + make0 ~dyn:(val_tag (topwit wit_int)) "int_or_var" + +let wit_intro_pattern = + make0 "intropattern" + +let wit_ident = + make0 "ident" + +let wit_var = + make0 ~dyn:(val_tag (topwit wit_ident)) "var" + +let wit_ref = make0 "ref" + +let wit_quant_hyp = make0 "quant_hyp" + +let wit_constr = + make0 "constr" + +let wit_uconstr = make0 "uconstr" + +let wit_open_constr = make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr" + +let wit_constr_with_bindings = make0 "constr_with_bindings" + +let wit_bindings = make0 "bindings" + +let wit_red_expr = make0 "redexpr" + +let wit_clause_dft_concl = + make0 "clause_dft_concl" + (** Aliases for compatibility *) let wit_integer = wit_int let wit_preident = wit_pre_ident +let wit_reference = wit_ref +let wit_global = wit_ref +let wit_clause = wit_clause_dft_concl +let wit_quantified_hypothesis = wit_quant_hyp +let wit_intropattern = wit_intro_pattern +let wit_redexpr = wit_red_expr diff --git a/interp/stdarg.mli b/interp/stdarg.mli index e1f648d7f..af3a73462 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -8,8 +8,21 @@ (** Basic generic arguments. *) +open Loc +open Names +open Term +open Libnames +open Globnames +open Genredexpr +open Pattern +open Constrexpr +open Misctypes +open Tactypes open Genarg +(** FIXME: nothing to do there. *) +val loc_of_or_by_notation : ('a -> Loc.t) -> 'a or_by_notation -> Loc.t + val wit_unit : unit uniform_genarg_type val wit_bool : bool uniform_genarg_type @@ -20,7 +33,54 @@ val wit_string : string uniform_genarg_type val wit_pre_ident : string uniform_genarg_type +(** {5 Additional generic arguments} *) + +val wit_int_or_var : (int or_var, int or_var, int) genarg_type + +val wit_intro_pattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type + +val wit_ident : Id.t uniform_genarg_type + +val wit_var : (Id.t located, Id.t located, Id.t) genarg_type + +val wit_ref : (reference, global_reference located or_var, global_reference) genarg_type + +val wit_quant_hyp : quantified_hypothesis uniform_genarg_type + +val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type + +val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type + +val wit_open_constr : + (constr_expr, glob_constr_and_expr, constr) genarg_type + +val wit_constr_with_bindings : + (constr_expr with_bindings, + glob_constr_and_expr with_bindings, + constr with_bindings delayed_open) genarg_type + +val wit_bindings : + (constr_expr bindings, + glob_constr_and_expr bindings, + constr bindings delayed_open) genarg_type + +val wit_red_expr : + ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, + (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, + (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type + +val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type + (** Aliases for compatibility *) val wit_integer : int uniform_genarg_type val wit_preident : string uniform_genarg_type +val wit_reference : (reference, global_reference located or_var, global_reference) genarg_type +val wit_global : (reference, global_reference located or_var, global_reference) genarg_type +val wit_clause : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type +val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type +val wit_intropattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type +val wit_redexpr : + ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, + (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, + (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 2523063e6..c3f4c4f30 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -30,7 +30,7 @@ let add_syntax_constant kn c onlyparse = let load_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = if Nametab.exists_cci sp then - errorlabstrm "cache_syntax_constant" + user_err ~hdr:"cache_syntax_constant" (pr_id (basename sp) ++ str " already exists"); add_syntax_constant kn pat onlyparse; Nametab.push_syndef (Nametab.Until i) sp kn diff --git a/interp/topconstr.ml b/interp/topconstr.ml index a397ca82e..fd57b70ca 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -31,8 +31,8 @@ let _ = Goptions.declare_bool_option { (**********************************************************************) (* Miscellaneous *) -let error_invalid_pattern_notation loc = - user_err_loc (loc,"",str "Invalid notation for pattern.") +let error_invalid_pattern_notation ?loc () = + user_err ?loc (str "Invalid notation for pattern.") (**********************************************************************) (* Functions on constr_expr *) @@ -177,10 +177,10 @@ let split_at_annot bl na = end | LocalRawDef _ as x :: rest -> aux (x :: acc) rest | LocalPattern (loc,_,_) :: rest -> - Loc.raise loc (Stream.Error "pattern with quote not allowed after fix") + Loc.raise ~loc (Stream.Error "pattern with quote not allowed after fix") | [] -> - user_err_loc(loc,"", - str "No parameter named " ++ Nameops.pr_id id ++ str".") + user_err ~loc + (str "No parameter named " ++ Nameops.pr_id id ++ str".") in aux [] bl (* Used in correctness and interface *) diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 58edd4ddf..95d702f8d 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -46,4 +46,4 @@ val patntn_loc : (** For cases pattern parsing errors *) -val error_invalid_pattern_notation : Loc.t -> 'a +val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a diff --git a/intf/decl_kinds.mli b/intf/decl_kinds.mli index 6a4e18833..8254b1b80 100644 --- a/intf/decl_kinds.mli +++ b/intf/decl_kinds.mli @@ -41,7 +41,7 @@ type definition_object_kind = type assumption_object_kind = Definitional | Logical | Conjectural -(** [assumption_kind] +(* [assumption_kind] | Local | Global ------------------------------------ diff --git a/intf/evar_kinds.mli b/intf/evar_kinds.mli index afc5e3bab..470ad2a23 100644 --- a/intf/evar_kinds.mli +++ b/intf/evar_kinds.mli @@ -20,6 +20,7 @@ type t = | ImplicitArg of global_reference * (int * Id.t option) * bool (** Force inference *) | BinderType of Name.t + | NamedHole of Id.t (* coming from some ?[id] syntax *) | QuestionMark of obligation_definition_status | CasesType of bool (* true = a subterm of the type *) | InternalHole diff --git a/intf/genredexpr.mli b/intf/genredexpr.mli index 2df79673a..16f0c0c92 100644 --- a/intf/genredexpr.mli +++ b/intf/genredexpr.mli @@ -8,6 +8,8 @@ (** Reduction expressions *) +open Names + (** The parsing produces initially a list of [red_atom] *) type 'a red_atom = @@ -50,5 +52,15 @@ type ('a,'b,'c) red_expr_gen = type ('a,'b,'c) may_eval = | ConstrTerm of 'a | ConstrEval of ('a,'b,'c) red_expr_gen * 'a - | ConstrContext of (Loc.t * Names.Id.t) * 'a + | ConstrContext of (Loc.t * Id.t) * 'a | ConstrTypeOf of 'a + +open Libnames +open Constrexpr +open Misctypes + +type r_trm = constr_expr +type r_pat = constr_pattern_expr +type r_cst = reference or_by_notation + +type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen diff --git a/intf/misctypes.mli b/intf/misctypes.mli index 1452bbc34..33dc2a335 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -28,7 +28,7 @@ and 'constr intro_pattern_action_expr = | IntroWildcard | IntroOrAndPattern of 'constr or_and_intro_pattern_expr | IntroInjection of (Loc.t * 'constr intro_pattern_expr) list - | IntroApplyOn of 'constr * (Loc.t * 'constr intro_pattern_expr) + | IntroApplyOn of (Loc.t * 'constr) * (Loc.t * 'constr intro_pattern_expr) | IntroRewrite of bool and 'constr or_and_intro_pattern_expr = | IntroOrPattern of (Loc.t * 'constr intro_pattern_expr) list list @@ -108,3 +108,31 @@ type 'a or_by_notation = (** Kinds of modules *) type module_kind = Module | ModType | ModAny + +(** Various flags *) + +type direction_flag = bool (* true = Left-to-right false = right-to-right *) +type evars_flag = bool (* true = pose evars false = fail on evars *) +type rec_flag = bool (* true = recursive false = not recursive *) +type advanced_flag = bool (* true = advanced false = basic *) +type letin_flag = bool (* true = use local def false = use Leibniz *) +type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) + +type multi = + | Precisely of int + | UpTo of int + | RepeatStar + | RepeatPlus + +type 'a core_destruction_arg = + | ElimOnConstr of 'a + | ElimOnIdent of Id.t Loc.located + | ElimOnAnonHyp of int + +type 'a destruction_arg = + clear_flag * 'a core_destruction_arg + +type inversion_kind = + | SimpleInversion + | FullInversion + | FullInversionClear diff --git a/intf/tactypes.mli b/intf/tactypes.mli new file mode 100644 index 000000000..b96cb67df --- /dev/null +++ b/intf/tactypes.mli @@ -0,0 +1,35 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Tactic-related types that are not totally Ltac specific and still used in + lower API. It's not clear whether this is a temporary API or if this is + meant to stay. *) + +open Loc +open Names +open Constrexpr +open Glob_term +open Pattern +open Misctypes + +(** In globalize tactics, we need to keep the initial [constr_expr] to recompute + in the environment by the effective calls to Intro, Inversion, etc + The [constr_expr] field is [None] in TacDef though *) +type glob_constr_and_expr = Glob_term.glob_constr * constr_expr option +type glob_constr_pattern_and_expr = Id.Set.t * glob_constr_and_expr * constr_pattern + +type 'a delayed_open = + { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } + +type delayed_open_constr = Term.constr delayed_open +type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open + +type intro_pattern = delayed_open_constr intro_pattern_expr located +type intro_patterns = delayed_open_constr intro_pattern_expr located list +type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr located +type intro_pattern_naming = intro_pattern_naming_expr located diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 92e4dd618..8827bc132 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -8,7 +8,6 @@ open Loc open Names -open Tacexpr open Misctypes open Constrexpr open Decl_kinds @@ -27,7 +26,7 @@ type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation to print a goal that is out of focus (or already solved) it doesn't make sense to apply a tactic to it. Hence it the types may look very similar, they do not seem to mean the same thing. *) -type goal_selector = Tacexpr.goal_selector = +type goal_selector = | SelectNth of int | SelectList of (int * int) list | SelectId of Id.t @@ -136,7 +135,7 @@ type hints_expr = | HintsTransparency of reference list * bool | HintsMode of reference * hint_mode list | HintsConstructors of reference list - | HintsExtern of int * constr_expr option * raw_tactic_expr + | HintsExtern of int * constr_expr option * Genarg.raw_generic_argument type search_restriction = | SearchInside of reference list @@ -177,7 +176,7 @@ type sort_expr = glob_sort type definition_expr = | ProveBody of local_binder list * constr_expr - | DefineBody of local_binder list * raw_red_expr option * constr_expr + | DefineBody of local_binder list * Genredexpr.raw_red_expr option * constr_expr * constr_expr option type fixpoint_expr = @@ -442,9 +441,9 @@ type vernac_expr = | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list | VernacPrintOption of Goptions.option_name - | VernacCheckMayEval of raw_red_expr option * int option * constr_expr + | VernacCheckMayEval of Genredexpr.raw_red_expr option * int option * constr_expr | VernacGlobalCheck of constr_expr - | VernacDeclareReduction of string * raw_red_expr + | VernacDeclareReduction of string * Genredexpr.raw_red_expr | VernacPrint of printable | VernacSearch of searchable * int option * search_restriction | VernacLocate of locatable @@ -470,7 +469,7 @@ type vernac_expr = | VernacEndSubproof | VernacShow of showable | VernacCheckGuard - | VernacProof of raw_tactic_expr option * section_subset_expr option + | VernacProof of Genarg.raw_generic_argument option * section_subset_expr option | VernacProofMode of string (* Toplevel control *) | VernacToplevelControl of exn @@ -483,10 +482,6 @@ type vernac_expr = | VernacPolymorphic of bool * vernac_expr | VernacLocal of bool * vernac_expr -and tacdef_body = - | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) - | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) - and vernac_implicit_status = Implicit | MaximallyImplicit | NotImplicit and vernac_argument_status = { diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 810c34699..94ca4c72d 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -299,7 +299,7 @@ and pp_bytecodes c = | Ksequence (l1, l2) :: c -> pp_bytecodes l1 ++ pp_bytecodes l2 ++ pp_bytecodes c | i :: c -> - tab () ++ pp_instr i ++ fnl () ++ pp_bytecodes c + pp_instr i ++ fnl () ++ pp_bytecodes c (*spiwack: moved this type in this file because I needed it for retroknowledge which can't depend from cbytegen *) diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index b1fc0c85d..57b397e6f 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -979,7 +979,7 @@ let compile fail_on_error ?universes:(universes=0) env c = Feedback.msg_debug (dump_bytecodes init_code !fun_code fv)) ; Some (init_code,!fun_code, Array.of_list fv) with TooLargeInductive tname -> - let fn = if fail_on_error then CErrors.errorlabstrm "compile" else + let fn = if fail_on_error then CErrors.user_err ?loc:None ~hdr:"compile" else (fun x -> Feedback.msg_warning x) in (Pp.(fn (str "Cannot compile code for virtual machine as it uses inductive " ++ diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index f13620e10..40c1e027d 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -24,33 +24,45 @@ type reloc_info = type patch = reloc_info * int let patch_char4 buff pos c1 c2 c3 c4 = - String.unsafe_set buff pos c1; - String.unsafe_set buff (pos + 1) c2; - String.unsafe_set buff (pos + 2) c3; - String.unsafe_set buff (pos + 3) c4 + Bytes.unsafe_set buff pos c1; + Bytes.unsafe_set buff (pos + 1) c2; + Bytes.unsafe_set buff (pos + 2) c3; + Bytes.unsafe_set buff (pos + 3) c4 let patch buff (pos, n) = patch_char4 buff pos (Char.unsafe_chr n) (Char.unsafe_chr (n asr 8)) (Char.unsafe_chr (n asr 16)) (Char.unsafe_chr (n asr 24)) +(* val patch_int : emitcodes -> ((\*pos*\)int * int) list -> emitcodes *) let patch_int buff patches = (* copy code *before* patching because of nested evaluations: the code we are patching might be called (and thus "concurrently" patched) and results in wrong results. Side-effects... *) - let buff = String.copy buff in + let buff = Bytes.of_string buff in let () = List.iter (fun p -> patch buff p) patches in - buff + (* Note: we follow the apporach suggested by Gabriel Scherer in + PR#136 here, and use unsafe as we own buff. + + The crux of the question that avoids defining emitcodes just as a + Byte.t is the call to hcons in to_memory below. Even if disabling + this optimization has no visible time impact, test data shows + that the optimization is indeed triggered quite often so we + choose ugliness over altering the semantics. + + Handle with care. + *) + Bytes.unsafe_to_string buff (* Buffering of bytecode *) -let out_buffer = ref(String.create 1024) +let out_buffer = ref(Bytes.create 1024) and out_position = ref 0 let out_word b1 b2 b3 b4 = let p = !out_position in - if p >= String.length !out_buffer then begin - let len = String.length !out_buffer in + if p >= Bytes.length !out_buffer then begin + let len = Bytes.length !out_buffer in let new_len = if len <= Sys.max_string_length / 2 then 2 * len @@ -58,8 +70,8 @@ let out_word b1 b2 b3 b4 = if len = Sys.max_string_length then invalid_arg "String.create" (* Pas la bonne exception .... *) else Sys.max_string_length in - let new_buffer = String.create new_len in - String.blit !out_buffer 0 new_buffer 0 len; + let new_buffer = Bytes.create new_len in + Bytes.blit !out_buffer 0 new_buffer 0 len; out_buffer := new_buffer end; patch_char4 !out_buffer p (Char.unsafe_chr b1) @@ -94,10 +106,10 @@ let extend_label_table needed = let backpatch (pos, orig) = let displ = (!out_position - orig) asr 2 in - !out_buffer.[pos] <- Char.unsafe_chr displ; - !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8); - !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16); - !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24) + Bytes.set !out_buffer pos @@ Char.unsafe_chr displ; + Bytes.set !out_buffer (pos+1) @@ Char.unsafe_chr (displ asr 8); + Bytes.set !out_buffer (pos+2) @@ Char.unsafe_chr (displ asr 16); + Bytes.set !out_buffer (pos+3) @@ Char.unsafe_chr (displ asr 24) let define_label lbl = if lbl >= Array.length !label_table then extend_label_table lbl; @@ -308,7 +320,7 @@ let init () = label_table := Array.make 16 (Label_undefined []); reloc_info := [] -type emitcodes = string +type emitcodes = String.t let length = String.length @@ -372,9 +384,8 @@ let to_memory (init_code, fun_code, fv) = init(); emit init_code []; emit fun_code []; - let code = String.create !out_position in - String.unsafe_blit !out_buffer 0 code 0 !out_position; (** Later uses of this string are all purely functional *) + let code = Bytes.sub_string !out_buffer 0 !out_position in let code = CString.hcons code in let reloc = List.rev !reloc_info in Array.iter (fun lbl -> diff --git a/kernel/constr.mli b/kernel/constr.mli index 42d298e3b..7095dbe6f 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -189,8 +189,12 @@ type ('constr, 'types) pcofixpoint = int * ('constr, 'types) prec_declaration type ('constr, 'types) kind_of_term = - | Rel of int - | Var of Id.t + | Rel of int (** Gallina-variable introduced by [forall], [fun], [let-in], [fix], or [cofix]. *) + + | Var of Id.t (** Gallina-variable that was introduced by Vernacular-command that extends + the local context of the currently open section + (i.e. [Variable] or [Let]). *) + | Meta of metavariable | Evar of 'constr pexistential | Sort of Sorts.t @@ -199,12 +203,16 @@ type ('constr, 'types) kind_of_term = | Lambda of Name.t * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:B := C in D"] is represented as [LetIn (A,B,C,D)]. *) | App of 'constr * 'constr array (** Concrete syntax ["(F P1 P2 ... Pn)"] is represented as [App (F, [|P1; P2; ...; Pn|])]. + The {!mkApp} constructor also enforces the following invariant: - [F] itself is not {!App} - and [[|P1;..;Pn|]] is not empty. *) - | Const of constant puniverses - | Ind of inductive puniverses - | Construct of constructor puniverses + + | Const of constant puniverses (** Gallina-variable that was introduced by Vernacular-command that extends the global environment + (i.e. [Parameter], or [Axiom], or [Definition], or [Theorem] etc.) *) + + | Ind of inductive puniverses (** A name of an inductive type defined by [Variant], [Inductive] or [Record] Vernacular-commands. *) + | Construct of constructor puniverses (** A constructor of an inductive type defined by [Variant], [Inductive] or [Record] Vernacular-commands. *) | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint diff --git a/kernel/context.ml b/kernel/context.ml index 4e53b73a2..ae0388003 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -138,7 +138,7 @@ struct | LocalDef (_,v,ty) -> f v; f ty (** Reduce all terms in a given declaration to a single value. *) - let fold f decl acc = + let fold_constr f decl acc = match decl with | LocalAssum (n,ty) -> f ty acc | LocalDef (n,v,ty) -> f ty (f v acc) @@ -147,9 +147,6 @@ struct | LocalAssum (na, ty) -> na, None, ty | LocalDef (na, v, ty) -> na, Some v, ty - let of_tuple = function - | n, None, ty -> LocalAssum (n,ty) - | n, Some v, ty -> LocalDef (n,v,ty) end (** Rel-context is represented as a list of declarations. @@ -336,7 +333,7 @@ struct | LocalDef (_, v, ty) -> f v; f ty (** Reduce all terms in a given declaration to a single value. *) - let fold f decl a = + let fold_constr f decl a = match decl with | LocalAssum (_, ty) -> f ty a | LocalDef (_, v, ty) -> a |> f v |> f ty @@ -348,6 +345,18 @@ struct let of_tuple = function | id, None, ty -> LocalAssum (id, ty) | id, Some v, ty -> LocalDef (id, v, ty) + + let of_rel_decl f = function + | Rel.Declaration.LocalAssum (na,t) -> + LocalAssum (f na, t) + | Rel.Declaration.LocalDef (na,v,t) -> + LocalDef (f na, v, t) + + let to_rel_decl = function + | LocalAssum (id,t) -> + Rel.Declaration.LocalAssum (Name id, t) + | LocalDef (id,v,t) -> + Rel.Declaration.LocalDef (Name id,v,t) end (** Named-context is represented as a list of declarations. @@ -401,23 +410,39 @@ struct | _ -> None in List.map_filter filter - end +end -module NamedList = +module Compacted = struct module Declaration = struct - type t = Id.t list * Constr.t option * Constr.t - - let map_constr f (ids, copt, ty as decl) = - let copt' = Option.map f copt in - let ty' = f ty in - if copt == copt' && ty == ty' then decl else (ids, copt', ty') + type t = + | LocalAssum of Id.t list * Constr.t + | LocalDef of Id.t list * Constr.t * Constr.t + + let map_constr f = function + | LocalAssum (ids, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (ids, ty') + | LocalDef (ids, c, ty) as decl -> + let ty' = f ty in + let c' = f c in + if c == c' && ty == ty' then decl else LocalDef (ids,c',ty') + + let of_named_decl = function + | Named.Declaration.LocalAssum (id,t) -> + LocalAssum ([id],t) + | Named.Declaration.LocalDef (id,v,t) -> + LocalDef ([id],v,t) + + let to_named_context = function + | LocalAssum (ids, t) -> + List.map (fun id -> Named.Declaration.LocalAssum (id,t)) ids + | LocalDef (ids, v, t) -> + List.map (fun id -> Named.Declaration.LocalDef (id,v,t)) ids end type t = Declaration.t list let fold f l ~init = List.fold_right f l init end - -type section_context = Named.t diff --git a/kernel/context.mli b/kernel/context.mli index b5f3904d2..955e214cb 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -79,10 +79,9 @@ sig val iter_constr : (Constr.t -> unit) -> t -> unit (** Reduce all terms in a given declaration to a single value. *) - val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a + val fold_constr : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a val to_tuple : t -> Name.t * Constr.t option * Constr.t - val of_tuple : Name.t * Constr.t option * Constr.t -> t end (** Rel-context is represented as a list of declarations. @@ -193,10 +192,18 @@ sig val iter_constr : (Constr.t -> unit) -> t -> unit (** Reduce all terms in a given declaration to a single value. *) - val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a + val fold_constr : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a val to_tuple : t -> Id.t * Constr.t option * Constr.t val of_tuple : Id.t * Constr.t option * Constr.t -> t + + (** Convert [Rel.Declaration.t] value to the corresponding [Named.Declaration.t] value. + The function provided as the first parameter determines how to translate "names" to "ids". *) + val of_rel_decl : (Name.t -> Id.t) -> Rel.Declaration.t -> t + + (** Convert [Named.Declaration.t] value to the corresponding [Rel.Declaration.t] value. *) + (* TODO: Move this function to [Rel.Declaration] module and rename it to [of_named]. *) + val to_rel_decl : t -> Rel.Declaration.t end (** Rel-context is represented as a list of declarations. @@ -244,17 +251,20 @@ sig val to_instance : t -> Constr.t list end -module NamedList : +module Compacted : sig module Declaration : sig - type t = Id.t list * Constr.t option * Constr.t + type t = + | LocalAssum of Id.t list * Constr.t + | LocalDef of Id.t list * Constr.t * Constr.t + val map_constr : (Constr.t -> Constr.t) -> t -> t + val of_named_decl : Named.Declaration.t -> t + val to_named_context : t -> Named.t end type t = Declaration.t list val fold : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a end - -type section_context = Named.t diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 134599150..f5059cd75 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -21,6 +21,8 @@ open Declarations open Environ open Univ +module NamedDecl = Context.Named.Declaration + (*s Cooking the constants. *) let pop_dirpath p = match DirPath.repr p with @@ -152,7 +154,7 @@ type inline = bool type result = constant_def * constant_type * projection_body option * bool * constant_universes * inline - * Context.section_context option + * Context.Named.t option let on_body ml hy f = function | Undef _ as x -> x @@ -202,8 +204,7 @@ let cook_constant env { from = cb; info } = in let const_hyps = Context.Named.fold_outside (fun decl hyps -> - let open Context.Named.Declaration in - List.filter (fun decl' -> not (Id.equal (get_id decl) (get_id decl'))) + List.filter (fun decl' -> not (Id.equal (NamedDecl.get_id decl) (NamedDecl.get_id decl'))) hyps) hyps ~init:cb.const_hyps in let typ = match cb.const_type with diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 327e697d2..eb4073096 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -19,7 +19,7 @@ type inline = bool type result = constant_def * constant_type * projection_body option * bool * constant_universes * inline - * Context.section_context option + * Context.Named.t option val cook_constant : env -> recipe -> result val cook_constr : Opaqueproof.cooking_info -> Term.constr -> Term.constr diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index c27cb0487..40595f944 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -22,6 +22,8 @@ open Declarations open Pre_env open Cbytegen +module NamedDecl = Context.Named.Declaration +module RelDecl = Context.Rel.Declaration external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code" external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" @@ -189,18 +191,14 @@ and slot_for_fv env fv = let nv = Pre_env.lookup_named_val id env in begin match force_lazy_val nv with | None -> - let open Context.Named in - let open Declaration in - env |> Pre_env.lookup_named id |> get_value |> fill_fv_cache nv id val_of_named idfun + env |> Pre_env.lookup_named id |> NamedDecl.get_value |> fill_fv_cache nv id val_of_named idfun | Some (v, _) -> v end | FVrel i -> let rv = Pre_env.lookup_rel_val i env in begin match force_lazy_val rv with | None -> - let open Context.Rel in - let open Declaration in - env.env_rel_context |> lookup i |> get_value |> fill_fv_cache rv i val_of_rel env_of_rel + env.env_rel_context |> Context.Rel.lookup i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel | Some (v, _) -> v end | FVuniv_var idu -> diff --git a/kernel/declarations.mli b/kernel/declarations.mli index f89773fcc..7821ea20f 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -58,10 +58,11 @@ type projection_body = { proj_body : constr; (* For compatibility with VMs only, the match version *) } +(* Global declarations (i.e. constants) can be either: *) type constant_def = - | Undef of inline - | Def of constr Mod_subst.substituted - | OpaqueDef of Opaqueproof.opaque + | Undef of inline (** a global assumption *) + | Def of constr Mod_subst.substituted (** or a transparent global definition *) + | OpaqueDef of Opaqueproof.opaque (** or an opaque global definition *) type constant_universes = Univ.universe_context @@ -78,7 +79,7 @@ type typing_flags = { (* some contraints are in constant_constraints, some other may be in * the OpaueDef *) type constant_body = { - const_hyps : Context.section_context; (** New: younger hyp at top *) + const_hyps : Context.Named.t; (** New: younger hyp at top *) const_body : constant_def; const_type : constant_type; const_body_code : Cemitcodes.to_patch_substituted option; @@ -177,7 +178,7 @@ type mutual_inductive_body = { mind_ntypes : int; (** Number of types in the block *) - mind_hyps : Context.section_context; (** Section hypotheses on which the block depends *) + mind_hyps : Context.Named.t; (** Section hypotheses on which the block depends *) mind_nparams : int; (** Number of expected parameters including non-uniform ones (i.e. length of mind_params_ctxt w/o let-in) *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 211e5e062..0a822d6fa 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -9,7 +9,8 @@ open Declarations open Mod_subst open Util -open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration (** Operations concernings types in [Declarations] : [constant_body], [mutual_inductive_body], [module_body] ... *) @@ -94,7 +95,7 @@ let is_opaque cb = match cb.const_body with (** {7 Constant substitutions } *) let subst_rel_declaration sub = - map_constr (subst_mps sub) + RelDecl.map_constr (subst_mps sub) let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) @@ -146,7 +147,7 @@ let subst_const_body sub cb = themselves. But would it really bring substantial gains ? *) let hcons_rel_decl = - map_type Term.hcons_types % map_value Term.hcons_constr % map_name Names.Name.hcons + RelDecl.map_name Names.Name.hcons %> RelDecl.map_value Term.hcons_constr %> RelDecl.map_type Term.hcons_types let hcons_rel_context l = List.smartmap hcons_rel_decl l diff --git a/kernel/entries.mli b/kernel/entries.mli index 5287a009e..1e07c9690 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -61,7 +61,7 @@ type 'a const_entry_body = 'a proof_output Future.computation type 'a definition_entry = { const_entry_body : 'a const_entry_body; (* List of section variables *) - const_entry_secctx : Context.section_context option; + const_entry_secctx : Context.Named.t option; (* State id on which the completion of type checking is reported *) const_entry_feedback : Stateid.t option; const_entry_type : types option; @@ -73,7 +73,7 @@ type 'a definition_entry = { type inline = int option (* inlining level, None for no inlining *) type parameter_entry = - Context.section_context option * bool * types Univ.in_universe_context * inline + Context.Named.t option * bool * types Univ.in_universe_context * inline type projection_entry = { proj_entry_ind : mutual_inductive; diff --git a/kernel/environ.ml b/kernel/environ.ml index 16ddfac64..4a543f195 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -413,7 +413,7 @@ let global_vars_set env constr = Id.Set.union (vars_of_global env c) acc | _ -> acc in - fold_constr filtrec acc c + Term.fold_constr filtrec acc c in filtrec Id.Set.empty constr diff --git a/kernel/environ.mli b/kernel/environ.mli index 6ac00088b..ea570cb4a 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -231,7 +231,7 @@ val vars_of_global : env -> constr -> Id.Set.t val really_needed : env -> Id.Set.t -> Id.Set.t (** like [really_needed] but computes a well ordered named context *) -val keep_hyps : env -> Id.Set.t -> Context.section_context +val keep_hyps : env -> Id.Set.t -> Context.Named.t (** {5 Unsafe judgments. } We introduce here the pre-type of judgments, which is diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml deleted file mode 100644 index bd91c689d..000000000 --- a/kernel/fast_typeops.ml +++ /dev/null @@ -1,463 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open CErrors -open Util -open Names -open Univ -open Term -open Vars -open Declarations -open Environ -open Reduction -open Inductive -open Type_errors - -let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y - -let conv_leq_vecti env v1 v2 = - Array.fold_left2_i - (fun i _ t1 t2 -> - try conv_leq false env t1 t2 - with NotConvertible -> raise (NotConvertibleVect i)) - () - v1 - v2 - -let check_constraints cst env = - if Environ.check_constraints cst env then () - else error_unsatisfied_constraints env cst - -(* This should be a type (a priori without intention to be an assumption) *) -let type_judgment env c t = - match kind_of_term(whd_all env t) with - | Sort s -> {utj_val = c; utj_type = s } - | _ -> error_not_type env (make_judge c t) - -let check_type env c t = - match kind_of_term(whd_all env t) with - | Sort s -> s - | _ -> error_not_type env (make_judge c t) - -(* This should be a type intended to be assumed. The error message is *) -(* not as useful as for [type_judgment]. *) -let assumption_of_judgment env t ty = - try let _ = check_type env t ty in t - with TypeError _ -> - error_assumption env (make_judge t ty) - -(************************************************) -(* Incremental typing rules: builds a typing judgment given the *) -(* judgments for the subterms. *) - -(*s Type of sorts *) - -(* Prop and Set *) - -let judge_of_prop = mkSort type1_sort - -let judge_of_prop_contents _ = judge_of_prop - -(* Type of Type(i). *) - -let judge_of_type u = - let uu = Universe.super u in - mkType uu - -(*s Type of a de Bruijn index. *) - -let judge_of_relative env n = - try - let open Context.Rel.Declaration in - env |> lookup_rel n |> get_type |> lift n - with Not_found -> - error_unbound_rel env n - -(* Type of variables *) -let judge_of_variable env id = - try named_type id env - with Not_found -> - error_unbound_var env id - -(* Management of context of variables. *) - -(* Checks if a context of variables can be instantiated by the - variables of the current env *) -(* TODO: check order? *) -let check_hyps_inclusion env f c sign = - Context.Named.fold_outside - (fun decl () -> - let open Context.Named.Declaration in - let id = get_id decl in - let ty1 = get_type decl in - try - let ty2 = named_type id env in - if not (eq_constr ty2 ty1) then raise Exit - with Not_found | Exit -> - error_reference_variables env id (f c)) - sign - ~init:() - -(* Instantiation of terms on real arguments. *) - -(* Make a type polymorphic if an arity *) - -(* Type of constants *) - - -let type_of_constant_knowing_parameters_arity env t paramtyps = - match t with - | RegularArity t -> t - | TemplateArity (sign,ar) -> - let ctx = List.rev sign in - let ctx,s = instantiate_universes env ctx ar paramtyps in - mkArity (List.rev ctx,s) - -let type_of_constant_knowing_parameters env cst paramtyps = - let ty, cu = constant_type env cst in - type_of_constant_knowing_parameters_arity env ty paramtyps, cu - -let judge_of_constant_knowing_parameters env (kn,u as cst) args = - let cb = lookup_constant kn env in - let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in - let ty, cu = type_of_constant_knowing_parameters env cst args in - let () = check_constraints cu env in - ty - -let judge_of_constant env cst = - judge_of_constant_knowing_parameters env cst [||] - -(* Type of a lambda-abstraction. *) - -(* [judge_of_abstraction env name var j] implements the rule - - env, name:typ |- j.uj_val:j.uj_type env, |- (name:typ)j.uj_type : s - ----------------------------------------------------------------------- - env |- [name:typ]j.uj_val : (name:typ)j.uj_type - - Since all products are defined in the Calculus of Inductive Constructions - and no upper constraint exists on the sort $s$, we don't need to compute $s$ -*) - -let judge_of_abstraction env name var ty = - mkProd (name, var, ty) - -(* Type of an application. *) - -let make_judgev c t = - Array.map2 make_judge c t - -let judge_of_apply env func funt argsv argstv = - let len = Array.length argsv in - let rec apply_rec i typ = - if Int.equal i len then typ - else - (match kind_of_term (whd_all env typ) with - | Prod (_,c1,c2) -> - let arg = argsv.(i) and argt = argstv.(i) in - (try - let () = conv_leq false env argt c1 in - apply_rec (i+1) (subst1 arg c2) - with NotConvertible -> - error_cant_apply_bad_type env - (i+1,c1,argt) - (make_judge func funt) - (make_judgev argsv argstv)) - - | _ -> - error_cant_apply_not_functional env - (make_judge func funt) - (make_judgev argsv argstv)) - in apply_rec 0 funt - -(* Type of product *) - -let sort_of_product env domsort rangsort = - match (domsort, rangsort) with - (* Product rule (s,Prop,Prop) *) - | (_, Prop Null) -> rangsort - (* Product rule (Prop/Set,Set,Set) *) - | (Prop _, Prop Pos) -> rangsort - (* Product rule (Type,Set,?) *) - | (Type u1, Prop Pos) -> - if is_impredicative_set env then - (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) - rangsort - else - (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) - Type (Universe.sup Universe.type0 u1) - (* Product rule (Prop,Type_i,Type_i) *) - | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) - (* Product rule (Prop,Type_i,Type_i) *) - | (Prop Null, Type _) -> rangsort - (* Product rule (Type_i,Type_i,Type_i) *) - | (Type u1, Type u2) -> Type (Universe.sup u1 u2) - -(* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule - - env |- typ1:s1 env, name:typ1 |- typ2 : s2 - ------------------------------------------------------------------------- - s' >= (s1,s2), env |- (name:typ)j.uj_val : s' - - where j.uj_type is convertible to a sort s2 -*) -let judge_of_product env name s1 s2 = - let s = sort_of_product env s1 s2 in - mkSort s - -(* Type of a type cast *) - -(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule - - env |- c:typ1 env |- typ2:s env |- typ1 <= typ2 - --------------------------------------------------------------------- - env |- c:typ2 -*) - -let judge_of_cast env c ct k expected_type = - try - match k with - | VMcast -> - vm_conv CUMUL env ct expected_type - | DEFAULTcast -> - default_conv ~l2r:false CUMUL env ct expected_type - | REVERTcast -> - default_conv ~l2r:true CUMUL env ct expected_type - | NATIVEcast -> - let sigma = Nativelambda.empty_evars in - Nativeconv.native_conv CUMUL sigma env ct expected_type - with NotConvertible -> - error_actual_type env (make_judge c ct) expected_type - -(* Inductive types. *) - -(* The type is parametric over the uniform parameters whose conclusion - is in Type; to enforce the internal constraints between the - parameters and the instances of Type occurring in the type of the - constructors, we use the level variables _statically_ assigned to - the conclusions of the parameters as mediators: e.g. if a parameter - has conclusion Type(alpha), static constraints of the form alpha<=v - exist between alpha and the Type's occurring in the constructor - types; when the parameters is finally instantiated by a term of - conclusion Type(u), then the constraints u<=alpha is computed in - the App case of execute; from this constraints, the expected - dynamic constraints of the form u<=v are enforced *) - -let judge_of_inductive_knowing_parameters env (ind,u as indu) args = - let (mib,mip) as spec = lookup_mind_specif env ind in - check_hyps_inclusion env mkIndU indu mib.mind_hyps; - let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters - env (spec,u) args - in - check_constraints cst env; - t - -let judge_of_inductive env (ind,u as indu) = - let (mib,mip) = lookup_mind_specif env ind in - check_hyps_inclusion env mkIndU indu mib.mind_hyps; - let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in - check_constraints cst env; - t - -(* Constructors. *) - -let judge_of_constructor env (c,u as cu) = - let _ = - let ((kn,_),_) = c in - let mib = lookup_mind kn env in - check_hyps_inclusion env mkConstructU cu mib.mind_hyps in - let specif = lookup_mind_specif env (inductive_of_constructor c) in - let t,cst = constrained_type_of_constructor cu specif in - let () = check_constraints cst env in - t - -(* Case. *) - -let check_branch_types env (ind,u) c ct lft explft = - try conv_leq_vecti env lft explft - with - NotConvertibleVect i -> - error_ill_formed_branch env c ((ind,i+1),u) lft.(i) explft.(i) - | Invalid_argument _ -> - error_number_branches env (make_judge c ct) (Array.length explft) - -let judge_of_case env ci p pt c ct lf lft = - let (pind, _ as indspec) = - try find_rectype env ct - with Not_found -> error_case_not_inductive env (make_judge c ct) in - let _ = check_case_info env pind ci in - let (bty,rslty) = - type_case_branches env indspec (make_judge p pt) c in - let () = check_branch_types env pind c ct lft bty in - rslty - -let judge_of_projection env p c ct = - let pb = lookup_projection p env in - let (ind,u), args = - try find_rectype env ct - with Not_found -> error_case_not_inductive env (make_judge c ct) - in - assert(eq_mind pb.proj_ind (fst ind)); - let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in - substl (c :: List.rev args) ty - - -(* Fixpoints. *) - -(* Checks the type of a general (co)fixpoint, i.e. without checking *) -(* the specific guard condition. *) - -let type_fixpoint env lna lar vdef vdeft = - let lt = Array.length vdeft in - assert (Int.equal (Array.length lar) lt); - try - conv_leq_vecti env vdeft (Array.map (fun ty -> lift lt ty) lar) - with NotConvertibleVect i -> - error_ill_typed_rec_body env i lna (make_judgev vdef vdeft) lar - -(************************************************************************) -(************************************************************************) - -(* The typing machine. *) - (* ATTENTION : faudra faire le typage du contexte des Const, - Ind et Constructsi un jour cela devient des constructions - arbitraires et non plus des variables *) -let rec execute env cstr = - let open Context.Rel.Declaration in - match kind_of_term cstr with - (* Atomic terms *) - | Sort (Prop c) -> - judge_of_prop_contents c - - | Sort (Type u) -> - judge_of_type u - - | Rel n -> - judge_of_relative env n - - | Var id -> - judge_of_variable env id - - | Const c -> - judge_of_constant env c - - | Proj (p, c) -> - let ct = execute env c in - judge_of_projection env p c ct - - (* Lambda calculus operators *) - | App (f,args) -> - let argst = execute_array env args in - let ft = - match kind_of_term f with - | Ind ind when Environ.template_polymorphic_pind ind env -> - (* Template sort-polymorphism of inductive types *) - let args = Array.map (fun t -> lazy t) argst in - judge_of_inductive_knowing_parameters env ind args - | Const cst when Environ.template_polymorphic_pconstant cst env -> - (* Template sort-polymorphism of constants *) - let args = Array.map (fun t -> lazy t) argst in - judge_of_constant_knowing_parameters env cst args - | _ -> - (* Full or no sort-polymorphism *) - execute env f - in - - judge_of_apply env f ft args argst - - | Lambda (name,c1,c2) -> - let _ = execute_is_type env c1 in - let env1 = push_rel (LocalAssum (name,c1)) env in - let c2t = execute env1 c2 in - judge_of_abstraction env name c1 c2t - - | Prod (name,c1,c2) -> - let vars = execute_is_type env c1 in - let env1 = push_rel (LocalAssum (name,c1)) env in - let vars' = execute_is_type env1 c2 in - judge_of_product env name vars vars' - - | LetIn (name,c1,c2,c3) -> - let c1t = execute env c1 in - let _c2s = execute_is_type env c2 in - let _ = judge_of_cast env c1 c1t DEFAULTcast c2 in - let env1 = push_rel (LocalDef (name,c1,c2)) env in - let c3t = execute env1 c3 in - subst1 c1 c3t - - | Cast (c,k,t) -> - let ct = execute env c in - let _ts = execute_type env t in - let _ = judge_of_cast env c ct k t in - t - - (* Inductive types *) - | Ind ind -> - judge_of_inductive env ind - - | Construct c -> - judge_of_constructor env c - - | Case (ci,p,c,lf) -> - let ct = execute env c in - let pt = execute env p in - let lft = execute_array env lf in - judge_of_case env ci p pt c ct lf lft - - | Fix ((vn,i as vni),recdef) -> - let (fix_ty,recdef') = execute_recdef env recdef i in - let fix = (vni,recdef') in - check_fix env fix; fix_ty - - | CoFix (i,recdef) -> - let (fix_ty,recdef') = execute_recdef env recdef i in - let cofix = (i,recdef') in - check_cofix env cofix; fix_ty - - (* Partial proofs: unsupported by the kernel *) - | Meta _ -> - anomaly (Pp.str "the kernel does not support metavariables") - - | Evar _ -> - anomaly (Pp.str "the kernel does not support existential variables") - -and execute_is_type env constr = - let t = execute env constr in - check_type env constr t - -and execute_type env constr = - let t = execute env constr in - type_judgment env constr t - -and execute_recdef env (names,lar,vdef) i = - let lart = execute_array env lar in - let lara = Array.map2 (assumption_of_judgment env) lar lart in - let env1 = push_rec_types (names,lara,vdef) env in - let vdeft = execute_array env1 vdef in - let () = type_fixpoint env1 names lara vdef vdeft in - (lara.(i),(names,lara,vdef)) - -and execute_array env = Array.map (execute env) - -(* Derived functions *) -let infer env constr = - let t = execute env constr in - make_judge constr t - -let infer = - if Flags.profile then - let infer_key = Profile.declare_profile "Fast_infer" in - Profile.profile2 infer_key (fun b c -> infer b c) - else (fun b c -> infer b c) - -let infer_type env constr = - execute_type env constr - -let infer_v env cv = - let jv = execute_array env cv in - make_judgev cv jv diff --git a/kernel/fast_typeops.mli b/kernel/fast_typeops.mli deleted file mode 100644 index 41cff607e..000000000 --- a/kernel/fast_typeops.mli +++ /dev/null @@ -1,24 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Term -open Environ -open Declarations - -(** {6 Typing functions (not yet tagged as safe) } - - They return unsafe judgments that are "in context" of a set of - (local) universe variables (the ones that appear in the term) - and associated constraints. In case of polymorphic definitions, - these variables and constraints will be generalized. - *) - - -val infer : env -> constr -> unsafe_judgment -val infer_v : env -> constr array -> unsafe_judgment array -val infer_type : env -> types -> unsafe_type_judgment diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 15f213ce9..4c540a6d7 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -32,7 +32,6 @@ Type_errors Modops Inductive Typeops -Fast_typeops Indtypes Cooking Term_typing diff --git a/kernel/names.ml b/kernel/names.ml index 1eb9a3175..ee8d838da 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -50,17 +50,20 @@ struct | None -> true | Some _ -> false + let of_bytes s = + let s = Bytes.to_string s in + check_soft s; + String.hcons s + let of_string s = let () = check_soft s in - let s = String.copy s in String.hcons s let of_string_soft s = let () = check_soft ~warn:false s in - let s = String.copy s in String.hcons s - let to_string id = String.copy id + let to_string id = id let print id = str id @@ -88,11 +91,14 @@ struct type t = Anonymous (** anonymous identifier *) | Name of Id.t (** non-anonymous identifier *) + let mk_name id = + Name id + let is_anonymous = function | Anonymous -> true | Name _ -> false - let is_name = not % is_anonymous + let is_name = is_anonymous %> not let compare n1 n2 = match n1, n2 with | Anonymous, Anonymous -> 0 @@ -601,7 +607,13 @@ end module Constant = KerPair module Cmap = HMap.Make(Constant.CanOrd) +(** A map whose keys are constants (values of the {!Constant.t} type). + Keys are ordered wrt. "cannonical form" of the constant. *) + module Cmap_env = HMap.Make(Constant.UserOrd) +(** A map whose keys are constants (values of the {!Constant.t} type). + Keys are ordered wrt. "user form" of the constant. *) + module Cpred = Predicate.Make(Constant.CanOrd) module Cset = Cmap.Set module Cset_env = Cmap_env.Set diff --git a/kernel/names.mli b/kernel/names.mli index feaedc775..be9b9422b 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -43,6 +43,7 @@ sig (** Check that a string may be converted to an identifier. @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) + val of_bytes : bytes -> t val of_string : string -> t (** Converts a string into an identifier. @raise UserError if the string is not valid, or echo a warning if it contains invalid identifier characters. @@ -82,6 +83,9 @@ sig type t = Anonymous (** anonymous identifier *) | Name of Id.t (** non-anonymous identifier *) + val mk_name : Id.t -> t + (** constructor *) + val is_anonymous : t -> bool (** Return [true] iff a given name is [Anonymous]. *) @@ -368,8 +372,14 @@ end module Cpred : Predicate.S with type elt = Constant.t module Cset : CSig.SetS with type elt = Constant.t module Cset_env : CSig.SetS with type elt = Constant.t + module Cmap : Map.ExtS with type key = Constant.t and module Set := Cset +(** A map whose keys are constants (values of the {!Constant.t} type). + Keys are ordered wrt. "cannonical form" of the constant. *) + module Cmap_env : Map.ExtS with type key = Constant.t and module Set := Cset_env +(** A map whose keys are constants (values of the {!Constant.t} type). + Keys are ordered wrt. "user form" of the constant. *) (** {6 Inductive names} *) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index eaddace4b..33bd7d8dd 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1848,10 +1848,9 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = auxdefs, MLlet(aux_name, ml, mkMLapp (MLlocal aux_name) (Array.of_list (fv_rel@fv_named))) and compile_rel env sigma univ auxdefs n = - let open Context.Rel in - let n = length env.env_rel_context - n in - let open Declaration in - match lookup n env.env_rel_context with + let n = Context.Rel.length env.env_rel_context - n in + let open Context.Rel.Declaration in + match Context.Rel.lookup n env.env_rel_context with | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 91b40be7e..366f9a0a6 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -14,6 +14,8 @@ open Pre_env open Nativevalues open Nativeinstr +module RelDecl = Context.Rel.Declaration + (** This file defines the lambda code generation phase of the native compiler *) exception NotClosed @@ -727,8 +729,7 @@ let optimize lam = let lambda_of_constr env sigma c = set_global_env env; let env = Renv.make () in - let open Context.Rel.Declaration in - let ids = List.rev_map get_name !global_env.env_rel_context in + let ids = List.rev_map RelDecl.get_name !global_env.env_rel_context in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env sigma c in (* if Flags.vm_draw_opt () then begin diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 1c58c7445..6bd82170e 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -35,7 +35,7 @@ let ( / ) = Filename.concat (* We have to delay evaluation of include_dirs because coqlib cannot be guessed until flags have been properly initialized *) let include_dirs () = - [Filename.temp_dir_name; coqlib () / "kernel"; coqlib () / "library"] + [Filename.get_temp_dir_name (); coqlib () / "kernel"; coqlib () / "library"] (* Pointer to the function linking an ML object into coq's toplevel *) let load_obj = ref (fun x -> () : string -> unit) diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 8093df304..965ed67b0 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -491,12 +491,12 @@ let str_encode expr = let str_decode s = let mshl_expr_len = String.length s / 2 in let mshl_expr = Buffer.create mshl_expr_len in - let buf = String.create 2 in + let buf = Bytes.create 2 in for i = 0 to mshl_expr_len - 1 do - String.blit s (2*i) buf 0 2; - Buffer.add_char mshl_expr (bin_of_hex buf) + Bytes.blit_string s (2*i) buf 0 2; + Buffer.add_char mshl_expr (bin_of_hex (Bytes.to_string buf)) done; - Marshal.from_string (Buffer.contents mshl_expr) 0 + Marshal.from_bytes (Buffer.to_bytes mshl_expr) 0 (** Retroknowledge, to be removed when we switch to primitive integers *) diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 130f1eb03..f147ea343 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -136,7 +136,7 @@ let dump (otab,_) = let disch_table = Array.make n a_discharge in let f2t_map = ref FMap.empty in Int.Map.iter (fun n (d,cu) -> - let c, u = Future.split2 ~greedy:true cu in + let c, u = Future.split2 cu in Future.sink u; Future.sink c; opaque_table.(n) <- c; diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index f211583e0..d14a254d3 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -17,7 +17,8 @@ open Util open Names open Term open Declarations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (* The type of environments. *) @@ -128,10 +129,10 @@ let env_of_rel n env = (* Named context *) let push_named_context_val_val d rval ctxt = -(* assert (not (Id.Map.mem (get_id d) ctxt.env_named_map)); *) +(* assert (not (Id.Map.mem (NamedDecl.get_id d) ctxt.env_named_map)); *) { env_named_ctx = Context.Named.add d ctxt.env_named_ctx; - env_named_map = Id.Map.add (get_id d) (d, rval) ctxt.env_named_map; + env_named_map = Id.Map.add (NamedDecl.get_id d) (d, rval) ctxt.env_named_map; } let push_named_context_val d ctxt = @@ -140,8 +141,8 @@ let push_named_context_val d ctxt = let match_named_context_val c = match c.env_named_ctx with | [] -> None | decl :: ctx -> - let (_, v) = Id.Map.find (get_id decl) c.env_named_map in - let map = Id.Map.remove (get_id decl) c.env_named_map in + let (_, v) = Id.Map.find (NamedDecl.get_id decl) c.env_named_map in + let map = Id.Map.remove (NamedDecl.get_id decl) c.env_named_map in let cval = { env_named_ctx = ctx; env_named_map = map } in Some (decl, v, cval) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index e3b87bbe1..caaaff1b8 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -62,6 +62,8 @@ open Names open Declarations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + (** {6 Safe environments } Fields of [safe_environment] : @@ -69,7 +71,7 @@ open Context.Named.Declaration - [env] : the underlying environment (cf Environ) - [modpath] : the current module name - [modvariant] : - * NONE before coqtop initialization (or when -notop is used) + * NONE before coqtop initialization * LIBRARY at toplevel of a compilation or a regular coqtop session * STRUCT (params,oldsenv) : inside a local module, with module parameters [params] and earlier environment [oldsenv] @@ -361,7 +363,7 @@ let check_required current_libs needed = cost too much. *) let safe_push_named d env = - let id = get_id d in + let id = NamedDecl.get_id d in let _ = try let _ = Environ.lookup_named id env in @@ -795,7 +797,7 @@ type native_library = Nativecode.global list let get_library_native_symbols senv dir = try DPMap.find dir senv.native_symbols - with Not_found -> CErrors.errorlabstrm "get_library_native_symbols" + with Not_found -> CErrors.user_err ~hdr:"get_library_native_symbols" Pp.((str "Linker error in the native compiler. Are you using Require inside a nested Module declaration?") ++ fnl () ++ (str "This use case is not supported, but disabling the native compiler may help.")) @@ -819,7 +821,7 @@ let export ?except senv dir = try join_safe_environment ?except senv with e -> let e = CErrors.push e in - CErrors.errorlabstrm "export" (CErrors.iprint e) + CErrors.user_err ~hdr:"export" (CErrors.iprint e) in assert(senv.future_cst = []); let () = check_current_library dir senv in @@ -855,7 +857,7 @@ let import lib cst vodigest senv = check_required senv.required lib.comp_deps; check_engagement senv.env lib.comp_enga; if DirPath.equal (ModPath.dp senv.modpath) lib.comp_name then - CErrors.errorlabstrm "Safe_typing.import" + CErrors.user_err ~hdr:"Safe_typing.import" (Pp.strbrk "Cannot load a library with the same name as the current one."); let mp = MPfile lib.comp_name in let mb = lib.comp_mod in diff --git a/kernel/term.ml b/kernel/term.ml index 15f187e5c..62c161be4 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -328,38 +328,9 @@ let destCoFix c = match kind_of_term c with let isCoFix c = match kind_of_term c with CoFix _ -> true | _ -> false (******************************************************************) -(* Cast management *) -(******************************************************************) - -let rec strip_outer_cast c = match kind_of_term c with - | Cast (c,_,_) -> strip_outer_cast c - | _ -> c - -(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *) - -let under_outer_cast f c = match kind_of_term c with - | Cast (b,k,t) -> mkCast (f b, k, f t) - | _ -> f c - -let rec under_casts f c = match kind_of_term c with - | Cast (c,k,t) -> mkCast (under_casts f c, k, t) - | _ -> f c - -(******************************************************************) (* Flattening and unflattening of embedded applications and casts *) (******************************************************************) -(* flattens application lists throwing casts in-between *) -let collapse_appl c = match kind_of_term c with - | App (f,cl) -> - let rec collapse_rec f cl2 = - match kind_of_term (strip_outer_cast f) with - | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) - | _ -> mkApp (f,cl2) - in - collapse_rec f cl - | _ -> c - let decompose_app c = match kind_of_term c with | App (f,cl) -> (f, Array.to_list cl) @@ -465,7 +436,7 @@ let rec to_lambda n prod = match kind_of_term prod with | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) | Cast (c,_,_) -> to_lambda n c - | _ -> errorlabstrm "to_lambda" (mt ()) + | _ -> user_err ~hdr:"to_lambda" (mt ()) let rec to_prod n lam = if Int.equal n 0 then @@ -474,7 +445,7 @@ let rec to_prod n lam = match kind_of_term lam with | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) | Cast (c,_,_) -> to_prod n c - | _ -> errorlabstrm "to_prod" (mt ()) + | _ -> user_err ~hdr:"to_prod" (mt ()) let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) diff --git a/kernel/term.mli b/kernel/term.mli index 60a3c7715..a8d9dfbff 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -349,20 +349,6 @@ val strip_lam_n : int -> constr -> constr val strip_prod_assum : types -> types val strip_lam_assum : constr -> constr -(** Flattens application lists *) -val collapse_appl : constr -> constr - - -(** Remove recursively the casts around a term i.e. - [strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) -val strip_outer_cast : constr -> constr - -(** Apply a function letting Casted types in place *) -val under_casts : (constr -> constr) -> constr -> constr - -(** Apply a function under components of Cast if any *) -val under_outer_cast : (constr -> constr) -> constr -> constr - (** {5 ... } *) (** An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort. Such a term can canonically be seen as the pair of a context of types diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 6ce14c853..2eb2c040e 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -20,7 +20,9 @@ open Declarations open Environ open Entries open Typeops -open Fast_typeops + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration (* Insertion of constants and parameters in environment. *) @@ -95,8 +97,7 @@ let inline_side_effects env body ctx side_eff = let cbl = List.filter not_exists cbl in let cname c = let name = string_of_con c in - for i = 0 to String.length name - 1 do - if name.[i] == '.' || name.[i] == '#' then name.[i] <- '_' done; + let name = String.map (fun c -> if c == '.' || c == '#' then '_' else c) name in Name (id_of_string name) in let rec sub c i x = match kind_of_term x with | Const (c', _) when eq_constant c c' -> mkRel i @@ -214,7 +215,7 @@ let infer_declaration ~trust env kn dcl = let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let tyj = infer_type env typ in let proofterm = - Future.chain ~greedy:true ~pure:true body (fun ((body,uctx),side_eff) -> + Future.chain ~pure:true body (fun ((body,uctx),side_eff) -> let body, uctx, signatures = inline_side_effects env body uctx side_eff in let valid_signatures = check_signatures trust signatures in @@ -286,18 +287,17 @@ let global_vars_set_constant_type env = function | RegularArity t -> global_vars_set env t | TemplateArity (ctx,_) -> Context.Rel.fold_outside - (Context.Rel.Declaration.fold + (RelDecl.fold_constr (fun t c -> Id.Set.union (global_vars_set env t) c)) ctx ~init:Id.Set.empty let record_aux env s_ty s_bo suggested_expr = - let open Context.Named.Declaration in let in_ty = keep_hyps env s_ty in let v = String.concat " " (CList.map_filter (fun decl -> - let id = get_id decl in - if List.exists (Id.equal id % get_id) in_ty then None + let id = NamedDecl.get_id decl in + if List.exists (NamedDecl.get_id %> Id.equal id) in_ty then None else Some (Id.to_string id)) (keep_hyps env s_bo)) in Aux_file.record_in_aux "context_used" (v ^ ";" ^ suggested_expr) @@ -306,26 +306,25 @@ let suggest_proof_using = ref (fun _ _ _ _ _ -> "") let set_suggest_proof_using f = suggest_proof_using := f let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) = - let open Context.Named.Declaration in let check declared inferred = - let mk_set l = List.fold_right Id.Set.add (List.map get_id l) Id.Set.empty in + let mk_set l = List.fold_right Id.Set.add (List.map NamedDecl.get_id l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in if not (Id.Set.subset inferred_set declared_set) then let l = Id.Set.elements (Idset.diff inferred_set declared_set) in let n = List.length l in - errorlabstrm "" (Pp.(str "The following section " ++ + user_err (Pp.(str "The following section " ++ str (String.plural n "variable") ++ str " " ++ str (String.conjugate_verb_to_be n) ++ str " used but not declared:" ++ fnl () ++ pr_sequence Id.print (List.rev l) ++ str ".")) in let sort evn l = List.filter (fun decl -> - let id = get_id decl in - List.exists (Names.Id.equal id % get_id) l) + let id = NamedDecl.get_id decl in + List.exists (NamedDecl.get_id %> Names.Id.equal id) l) (named_context env) in (* We try to postpone the computation of used section variables *) let hyps, def = - let context_ids = List.map get_id (named_context env) in + let context_ids = List.map NamedDecl.get_id (named_context env) in match ctx with | None when not (List.is_empty context_ids) -> (* No declared section vars, and non-empty section context: @@ -453,7 +452,7 @@ let export_side_effects mb env ce = let { const_entry_body = body } = c in let _, eff = Future.force body in let ce = DefinitionEntry { c with - const_entry_body = Future.chain ~greedy:true ~pure:true body + const_entry_body = Future.chain ~pure:true body (fun (b_ctx, _) -> b_ctx, empty_seff) } in let not_exists (c,_,_,_) = try ignore(Environ.lookup_constant c env); false @@ -519,8 +518,7 @@ let translate_local_def mb env id centry = | Undef _ -> () | Def _ -> () | OpaqueDef lc -> - let open Context.Named.Declaration in - let context_ids = List.map get_id (named_context env) in + let context_ids = List.map NamedDecl.get_id (named_context env) in let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Opaqueproof.force_proof (opaque_tables env) lc) in @@ -536,7 +534,7 @@ let translate_local_def mb env id centry = let translate_mind env kn mie = Indtypes.check_inductive env kn mie let inline_entry_side_effects env ce = { ce with - const_entry_body = Future.chain ~greedy:true ~pure:true + const_entry_body = Future.chain ~pure:true ce.const_entry_body (fun ((body, ctx), side_eff) -> let body, ctx',_ = inline_side_effects env body ctx side_eff in (body, ctx'), empty_seff); diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 0059111c0..7d9a2aac0 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -14,11 +14,12 @@ open Term open Vars open Declarations open Environ -open Entries open Reduction open Inductive open Type_errors -open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y @@ -35,61 +36,46 @@ let check_constraints cst env = if Environ.check_constraints cst env then () else error_unsatisfied_constraints env cst -(* This should be a type (a priori without intension to be an assumption) *) -let type_judgment env j = - match kind_of_term(whd_all env j.uj_type) with - | Sort s -> {utj_val = j.uj_val; utj_type = s } - | _ -> error_not_type env j +(* This should be a type (a priori without intention to be an assumption) *) +let check_type env c t = + match kind_of_term(whd_all env t) with + | Sort s -> s + | _ -> error_not_type env (make_judge c t) -(* This should be a type intended to be assumed. The error message is *) -(* not as useful as for [type_judgment]. *) -let assumption_of_judgment env j = - try (type_judgment env j).utj_val +(* This should be a type intended to be assumed. The error message is + not as useful as for [type_judgment]. *) +let check_assumption env t ty = + try let _ = check_type env t ty in t with TypeError _ -> - error_assumption env j + error_assumption env (make_judge t ty) (************************************************) -(* Incremental typing rules: builds a typing judgement given the *) -(* judgements for the subterms. *) +(* Incremental typing rules: builds a typing judgment given the *) +(* judgments for the subterms. *) (*s Type of sorts *) (* Prop and Set *) -let judge_of_prop = - { uj_val = mkProp; - uj_type = mkSort type1_sort } - -let judge_of_set = - { uj_val = mkSet; - uj_type = mkSort type1_sort } - -let judge_of_prop_contents = function - | Null -> judge_of_prop - | Pos -> judge_of_set +let type1 = mkSort type1_sort (* Type of Type(i). *) -let judge_of_type u = +let type_of_type u = let uu = Universe.super u in - { uj_val = mkType u; - uj_type = mkType uu } + mkType uu (*s Type of a de Bruijn index. *) -let judge_of_relative env n = +let type_of_relative env n = try - let typ = get_type (lookup_rel n env) in - { uj_val = mkRel n; - uj_type = lift n typ } + env |> lookup_rel n |> RelDecl.get_type |> lift n with Not_found -> error_unbound_rel env n (* Type of variables *) -let judge_of_variable env id = - try - let ty = named_type id env in - make_judge (mkVar id) ty +let type_of_variable env id = + try named_type id env with Not_found -> error_unbound_var env id @@ -98,11 +84,11 @@ let judge_of_variable env id = (* Checks if a context of variables can be instantiated by the variables of the current env. Order does not have to be checked assuming that all names are distinct *) -let check_hyps_inclusion env c sign = +let check_hyps_inclusion env f c sign = Context.Named.fold_outside (fun d1 () -> let open Context.Named.Declaration in - let id = get_id d1 in + let id = NamedDecl.get_id d1 in try let d2 = lookup_named id env in conv env (get_type d2) (get_type d1); @@ -114,7 +100,7 @@ let check_hyps_inclusion env c sign = | LocalDef _, LocalAssum _ -> raise NotConvertible | LocalDef (_,b2,_), LocalDef (_,b1,_) -> conv env b2 b1); with Not_found | NotConvertible | Option.Heterogeneous -> - error_reference_variables env id c) + error_reference_variables env id (f c)) sign ~init:() @@ -122,35 +108,9 @@ let check_hyps_inclusion env c sign = (* Make a type polymorphic if an arity *) -let extract_level env p = - let _,c = dest_prod_assum env p in - match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None - -let extract_context_levels env l = - let fold l = function - | LocalAssum (_,p) -> extract_level env p :: l - | LocalDef _ -> l - in - List.fold_left fold [] l - -let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} = - let params, ccl = dest_prod_assum env t in - match kind_of_term ccl with - | Sort (Type u) -> - let ind, l = decompose_app (whd_all env c) in - if isInd ind && List.is_empty l then - let mis = lookup_mind_specif env (fst (destInd ind)) in - let nparams = Inductive.inductive_params mis in - let paramsl = CList.lastn nparams params in - let param_ccls = extract_context_levels env paramsl in - let s = { template_param_levels = param_ccls; template_level = u} in - TemplateArity (params,s) - else RegularArity t - | _ -> - RegularArity t - (* Type of constants *) + let type_of_constant_type_knowing_parameters env t paramtyps = match t with | RegularArity t -> t @@ -159,49 +119,28 @@ let type_of_constant_type_knowing_parameters env t paramtyps = let ctx,s = instantiate_universes env ctx ar paramtyps in mkArity (List.rev ctx,s) -let type_of_constant_knowing_parameters env cst paramtyps = - let cb = lookup_constant (fst cst) env in - let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in +let type_of_constant_knowing_parameters env (kn,u as cst) args = + let cb = lookup_constant kn env in + let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in let ty, cu = constant_type env cst in - type_of_constant_type_knowing_parameters env ty paramtyps, cu + let ty = type_of_constant_type_knowing_parameters env ty args in + let () = check_constraints cu env in + ty -let type_of_constant_knowing_parameters_in env cst paramtyps = - let cb = lookup_constant (fst cst) env in - let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in +let type_of_constant_knowing_parameters_in env (kn,u as cst) args = + let cb = lookup_constant kn env in + let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in let ty = constant_type_in env cst in - type_of_constant_type_knowing_parameters env ty paramtyps - -let type_of_constant_type env t = - type_of_constant_type_knowing_parameters env t [||] + type_of_constant_type_knowing_parameters env ty args let type_of_constant env cst = type_of_constant_knowing_parameters env cst [||] let type_of_constant_in env cst = - let cb = lookup_constant (fst cst) env in - let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in - let ar = constant_type_in env cst in - type_of_constant_type_knowing_parameters env ar [||] - -let judge_of_constant_knowing_parameters env (kn,u as cst) args = - let c = mkConstU cst in - let ty, cu = type_of_constant_knowing_parameters env cst args in - let () = check_constraints cu env in - make_judge c ty - -let judge_of_constant env cst = - judge_of_constant_knowing_parameters env cst [||] - -let type_of_projection env (p,u) = - let cst = Projection.constant p in - let cb = lookup_constant cst env in - match cb.const_proj with - | Some pb -> - if cb.const_polymorphic then - Vars.subst_instance_constr u pb.proj_type - else pb.proj_type - | None -> raise (Invalid_argument "type_of_projection: not a projection") + type_of_constant_knowing_parameters_in env cst [||] +let type_of_constant_type env t = + type_of_constant_type_knowing_parameters env t [||] (* Type of a lambda-abstraction. *) @@ -215,40 +154,36 @@ let type_of_projection env (p,u) = and no upper constraint exists on the sort $s$, we don't need to compute $s$ *) -let judge_of_abstraction env name var j = - { uj_val = mkLambda (name, var.utj_val, j.uj_val); - uj_type = mkProd (name, var.utj_val, j.uj_type) } - -(* Type of let-in. *) - -let judge_of_letin env name defj typj j = - { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ; - uj_type = subst1 defj.uj_val j.uj_type } +let type_of_abstraction env name var ty = + mkProd (name, var, ty) (* Type of an application. *) -let judge_of_apply env funj argjv = - let rec apply_rec n typ = function - | [] -> - { uj_val = mkApp (j_val funj, Array.map j_val argjv); - uj_type = typ } - | hj::restjl -> - (match kind_of_term (whd_all env typ) with - | Prod (_,c1,c2) -> - (try - let () = conv_leq false env hj.uj_type c1 in - apply_rec (n+1) (subst1 hj.uj_val c2) restjl - with NotConvertible -> - error_cant_apply_bad_type env - (n,c1, hj.uj_type) - funj argjv) - - | _ -> - error_cant_apply_not_functional env funj argjv) - in - apply_rec 1 - funj.uj_type - (Array.to_list argjv) +let make_judgev c t = + Array.map2 make_judge c t + +let type_of_apply env func funt argsv argstv = + let len = Array.length argsv in + let rec apply_rec i typ = + if Int.equal i len then typ + else + (match kind_of_term (whd_all env typ) with + | Prod (_,c1,c2) -> + let arg = argsv.(i) and argt = argstv.(i) in + (try + let () = conv_leq false env argt c1 in + apply_rec (i+1) (subst1 arg c2) + with NotConvertible -> + error_cant_apply_bad_type env + (i+1,c1,argt) + (make_judge func funt) + (make_judgev argsv argstv)) + + | _ -> + error_cant_apply_not_functional env + (make_judge func funt) + (make_judgev argsv argstv)) + in apply_rec 0 funt (* Type of product *) @@ -281,10 +216,9 @@ let sort_of_product env domsort rangsort = where j.uj_type is convertible to a sort s2 *) -let judge_of_product env name t1 t2 = - let s = sort_of_product env t1.utj_type t2.utj_type in - { uj_val = mkProd (name, t1.utj_val, t2.utj_val); - uj_type = mkSort s } +let type_of_product env name s1 s2 = + let s = sort_of_product env s1 s2 in + mkSort s (* Type of a type cast *) @@ -295,29 +229,20 @@ let judge_of_product env name t1 t2 = env |- c:typ2 *) -let judge_of_cast env cj k tj = - let expected_type = tj.utj_val in +let check_cast env c ct k expected_type = try - let c, cst = - match k with - | VMcast -> - mkCast (cj.uj_val, k, expected_type), - Reduction.vm_conv CUMUL env cj.uj_type expected_type - | DEFAULTcast -> - mkCast (cj.uj_val, k, expected_type), - default_conv ~l2r:false CUMUL env cj.uj_type expected_type - | REVERTcast -> - cj.uj_val, - default_conv ~l2r:true CUMUL env cj.uj_type expected_type - | NATIVEcast -> - let sigma = Nativelambda.empty_evars in - mkCast (cj.uj_val, k, expected_type), - Nativeconv.native_conv CUMUL sigma env cj.uj_type expected_type - in - { uj_val = c; - uj_type = expected_type } + match k with + | VMcast -> + vm_conv CUMUL env ct expected_type + | DEFAULTcast -> + default_conv ~l2r:false CUMUL env ct expected_type + | REVERTcast -> + default_conv ~l2r:true CUMUL env ct expected_type + | NATIVEcast -> + let sigma = Nativelambda.empty_evars in + Nativeconv.native_conv CUMUL sigma env ct expected_type with NotConvertible -> - error_actual_type env cj expected_type + error_actual_type env (make_judge c ct) expected_type (* Inductive types. *) @@ -333,83 +258,78 @@ let judge_of_cast env cj k tj = the App case of execute; from this constraints, the expected dynamic constraints of the form u<=v are enforced *) -let judge_of_inductive_knowing_parameters env (ind,u as indu) args = - let c = mkIndU indu in +let type_of_inductive_knowing_parameters env (ind,u as indu) args = let (mib,mip) as spec = lookup_mind_specif env ind in - check_hyps_inclusion env c mib.mind_hyps; + check_hyps_inclusion env mkIndU indu mib.mind_hyps; let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters env (spec,u) args in - check_constraints cst env; - make_judge c t + check_constraints cst env; + t -let judge_of_inductive env (ind,u as indu) = - let c = mkIndU indu in - let (mib,mip) as spec = lookup_mind_specif env ind in - check_hyps_inclusion env c mib.mind_hyps; - let t,cst = Inductive.constrained_type_of_inductive env (spec,u) in - check_constraints cst env; - (make_judge c t) +let type_of_inductive env (ind,u as indu) = + let (mib,mip) = lookup_mind_specif env ind in + check_hyps_inclusion env mkIndU indu mib.mind_hyps; + let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in + check_constraints cst env; + t (* Constructors. *) -let judge_of_constructor env (c,u as cu) = - let constr = mkConstructU cu in - let _ = +let type_of_constructor env (c,u as cu) = + let () = let ((kn,_),_) = c in let mib = lookup_mind kn env in - check_hyps_inclusion env constr mib.mind_hyps in + check_hyps_inclusion env mkConstructU cu mib.mind_hyps + in let specif = lookup_mind_specif env (inductive_of_constructor c) in let t,cst = constrained_type_of_constructor cu specif in let () = check_constraints cst env in - (make_judge constr t) + t (* Case. *) -let check_branch_types env (ind,u) cj (lfj,explft) = - try conv_leq_vecti env (Array.map j_type lfj) explft +let check_branch_types env (ind,u) c ct lft explft = + try conv_leq_vecti env lft explft with NotConvertibleVect i -> - error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) + error_ill_formed_branch env c ((ind,i+1),u) lft.(i) explft.(i) | Invalid_argument _ -> - error_number_branches env cj (Array.length explft) + error_number_branches env (make_judge c ct) (Array.length explft) -let judge_of_case env ci pj cj lfj = +let type_of_case env ci p pt c ct lf lft = let (pind, _ as indspec) = - try find_rectype env cj.uj_type - with Not_found -> error_case_not_inductive env cj in + try find_rectype env ct + with Not_found -> error_case_not_inductive env (make_judge c ct) in let () = check_case_info env pind ci in let (bty,rslty) = - type_case_branches env indspec pj cj.uj_val in - let () = check_branch_types env pind cj (lfj,bty) in - ({ uj_val = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, - Array.map j_val lfj); - uj_type = rslty }) + type_case_branches env indspec (make_judge p pt) c in + let () = check_branch_types env pind c ct lft bty in + rslty -let judge_of_projection env p cj = +let type_of_projection env p c ct = let pb = lookup_projection p env in let (ind,u), args = - try find_rectype env cj.uj_type - with Not_found -> error_case_not_inductive env cj + try find_rectype env ct + with Not_found -> error_case_not_inductive env (make_judge c ct) in - assert(eq_mind pb.proj_ind (fst ind)); - let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in - let ty = substl (cj.uj_val :: List.rev args) ty in - {uj_val = mkProj (p,cj.uj_val); - uj_type = ty} + assert(eq_mind pb.proj_ind (fst ind)); + let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in + substl (c :: List.rev args) ty + (* Fixpoints. *) (* Checks the type of a general (co)fixpoint, i.e. without checking *) (* the specific guard condition. *) -let type_fixpoint env lna lar vdefj = - let lt = Array.length vdefj in +let check_fixpoint env lna lar vdef vdeft = + let lt = Array.length vdeft in assert (Int.equal (Array.length lar) lt); try - conv_leq_vecti env (Array.map j_type vdefj) (Array.map (fun ty -> lift lt ty) lar) + conv_leq_vecti env vdeft (Array.map (fun ty -> lift lt ty) lar) with NotConvertibleVect i -> - error_ill_typed_rec_body env i lna vdefj lar + error_ill_typed_rec_body env i lna (make_judgev vdef vdeft) lar (************************************************************************) (************************************************************************) @@ -419,95 +339,96 @@ let type_fixpoint env lna lar vdefj = Ind et Constructsi un jour cela devient des constructions arbitraires et non plus des variables *) let rec execute env cstr = + let open Context.Rel.Declaration in match kind_of_term cstr with (* Atomic terms *) | Sort (Prop c) -> - judge_of_prop_contents c + type1 | Sort (Type u) -> - judge_of_type u + type_of_type u | Rel n -> - judge_of_relative env n + type_of_relative env n | Var id -> - judge_of_variable env id + type_of_variable env id | Const c -> - judge_of_constant env c + type_of_constant env c | Proj (p, c) -> - let cj = execute env c in - judge_of_projection env p cj + let ct = execute env c in + type_of_projection env p c ct (* Lambda calculus operators *) | App (f,args) -> - let jl = execute_array env args in - let j = + let argst = execute_array env args in + let ft = match kind_of_term f with - | Ind ind when Environ.template_polymorphic_pind ind env -> - (* Sort-polymorphism of inductive types *) - let args = Array.map (fun j -> lazy j.uj_type) jl in - judge_of_inductive_knowing_parameters env ind args - | Const cst when Environ.template_polymorphic_pconstant cst env -> - (* Sort-polymorphism of constant *) - let args = Array.map (fun j -> lazy j.uj_type) jl in - judge_of_constant_knowing_parameters env cst args - | _ -> - (* No sort-polymorphism *) - execute env f + | Ind ind when Environ.template_polymorphic_pind ind env -> + (* Template sort-polymorphism of inductive types *) + let args = Array.map (fun t -> lazy t) argst in + type_of_inductive_knowing_parameters env ind args + | Const cst when Environ.template_polymorphic_pconstant cst env -> + (* Template sort-polymorphism of constants *) + let args = Array.map (fun t -> lazy t) argst in + type_of_constant_knowing_parameters env cst args + | _ -> + (* Full or no sort-polymorphism *) + execute env f in - judge_of_apply env j jl + + type_of_apply env f ft args argst | Lambda (name,c1,c2) -> - let varj = execute_type env c1 in - let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in - let j' = execute env1 c2 in - judge_of_abstraction env name varj j' + let _ = execute_is_type env c1 in + let env1 = push_rel (LocalAssum (name,c1)) env in + let c2t = execute env1 c2 in + type_of_abstraction env name c1 c2t | Prod (name,c1,c2) -> - let varj = execute_type env c1 in - let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in - let varj' = execute_type env1 c2 in - judge_of_product env name varj varj' + let vars = execute_is_type env c1 in + let env1 = push_rel (LocalAssum (name,c1)) env in + let vars' = execute_is_type env1 c2 in + type_of_product env name vars vars' | LetIn (name,c1,c2,c3) -> - let j1 = execute env c1 in - let j2 = execute_type env c2 in - let _ = judge_of_cast env j1 DEFAULTcast j2 in - let env1 = push_rel (LocalDef (name,j1.uj_val,j2.utj_val)) env in - let j' = execute env1 c3 in - judge_of_letin env name j1 j2 j' + let c1t = execute env c1 in + let _c2s = execute_is_type env c2 in + let () = check_cast env c1 c1t DEFAULTcast c2 in + let env1 = push_rel (LocalDef (name,c1,c2)) env in + let c3t = execute env1 c3 in + subst1 c1 c3t | Cast (c,k,t) -> - let cj = execute env c in - let tj = execute_type env t in - judge_of_cast env cj k tj + let ct = execute env c in + let _ts = (check_type env t (execute env t)) in + let () = check_cast env c ct k t in + t (* Inductive types *) | Ind ind -> - judge_of_inductive env ind + type_of_inductive env ind | Construct c -> - judge_of_constructor env c + type_of_constructor env c | Case (ci,p,c,lf) -> - let cj = execute env c in - let pj = execute env p in - let lfj = execute_array env lf in - judge_of_case env ci pj cj lfj + let ct = execute env c in + let pt = execute env p in + let lft = execute_array env lf in + type_of_case env ci p pt c ct lf lft | Fix ((vn,i as vni),recdef) -> let (fix_ty,recdef') = execute_recdef env recdef i in let fix = (vni,recdef') in - check_fix env fix; - make_judge (mkFix fix) fix_ty + check_fix env fix; fix_ty | CoFix (i,recdef) -> let (fix_ty,recdef') = execute_recdef env recdef i in let cofix = (i,recdef') in - check_cofix env cofix; - (make_judge (mkCoFix cofix) fix_ty) + check_cofix env cofix; fix_ty (* Partial proofs: unsupported by the kernel *) | Meta _ -> @@ -516,53 +437,158 @@ let rec execute env cstr = | Evar _ -> anomaly (Pp.str "the kernel does not support existential variables") -and execute_type env constr = - let j = execute env constr in - type_judgment env j +and execute_is_type env constr = + let t = execute env constr in + check_type env constr t and execute_recdef env (names,lar,vdef) i = - let larj = execute_array env lar in - let lara = Array.map (assumption_of_judgment env) larj in + let lart = execute_array env lar in + let lara = Array.map2 (check_assumption env) lar lart in let env1 = push_rec_types (names,lara,vdef) env in - let vdefj = execute_array env1 vdef in - let vdefv = Array.map j_val vdefj in - let () = type_fixpoint env1 names lara vdefj in - (lara.(i),(names,lara,vdefv)) + let vdeft = execute_array env1 vdef in + let () = check_fixpoint env1 names lara vdef vdeft in + (lara.(i),(names,lara,vdef)) and execute_array env = Array.map (execute env) (* Derived functions *) let infer env constr = - let j = execute env constr in - assert (eq_constr j.uj_val constr); - j + let t = execute env constr in + make_judge constr t + +let infer = + if Flags.profile then + let infer_key = Profile.declare_profile "Fast_infer" in + Profile.profile2 infer_key (fun b c -> infer b c) + else (fun b c -> infer b c) + +let assumption_of_judgment env {uj_val=c; uj_type=t} = + check_assumption env c t -(* let infer_key = Profile.declare_profile "infer" *) -(* let infer = Profile.profile2 infer_key infer *) +let type_judgment env {uj_val=c; uj_type=t} = + let s = check_type env c t in + {utj_val = c; utj_type = s } let infer_type env constr = - let j = execute_type env constr in - j + let t = execute env constr in + let s = check_type env constr t in + {utj_val = constr; utj_type = s} let infer_v env cv = let jv = execute_array env cv in - jv + make_judgev cv jv (* Typing of several terms. *) let infer_local_decl env id = function - | LocalDefEntry c -> - let j = infer env c in - LocalDef (Name id, j.uj_val, j.uj_type) - | LocalAssumEntry c -> - let j = infer env c in - LocalAssum (Name id, assumption_of_judgment env j) + | Entries.LocalDefEntry c -> + let t = execute env c in + RelDecl.LocalDef (Name id, c, t) + | Entries.LocalAssumEntry c -> + let t = execute env c in + RelDecl.LocalAssum (Name id, check_assumption env c t) let infer_local_decls env decls = let rec inferec env = function | (id, d) :: l -> let (env, l) = inferec env l in let d = infer_local_decl env id d in - (push_rel d env, Context.Rel.add d l) - | [] -> (env, Context.Rel.empty) in + (push_rel d env, Context.Rel.add d l) + | [] -> (env, Context.Rel.empty) + in inferec env decls + +let judge_of_prop = make_judge mkProp type1 +let judge_of_set = make_judge mkSet type1 +let judge_of_type u = make_judge (mkType u) (type_of_type u) + +let judge_of_prop_contents = function + | Null -> judge_of_prop + | Pos -> judge_of_set + +let judge_of_relative env k = make_judge (mkRel k) (type_of_relative env k) + +let judge_of_variable env x = make_judge (mkVar x) (type_of_variable env x) + +let judge_of_constant env cst = make_judge (mkConstU cst) (type_of_constant env cst) +let judge_of_constant_knowing_parameters env cst args = + make_judge (mkConstU cst) (type_of_constant_knowing_parameters env cst args) + +let judge_of_projection env p cj = + make_judge (mkProj (p,cj.uj_val)) (type_of_projection env p cj.uj_val cj.uj_type) + +let dest_judgev v = + Array.map j_val v, Array.map j_type v + +let judge_of_apply env funj argjv = + let args, argtys = dest_judgev argjv in + make_judge (mkApp (funj.uj_val, args)) (type_of_apply env funj.uj_val funj.uj_type args argtys) + +let judge_of_abstraction env x varj bodyj = + make_judge (mkLambda (x, varj.utj_val, bodyj.uj_val)) + (type_of_abstraction env x varj.utj_val bodyj.uj_type) + +let judge_of_product env x varj outj = + make_judge (mkProd (x, varj.utj_val, outj.utj_val)) + (mkSort (sort_of_product env varj.utj_type outj.utj_type)) + +let judge_of_letin env name defj typj j = + make_judge (mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val)) + (subst1 defj.uj_val j.uj_type) + +let judge_of_cast env cj k tj = + let () = check_cast env cj.uj_val cj.uj_type k tj.utj_val in + let c = match k with | REVERTcast -> cj.uj_val | _ -> mkCast (cj.uj_val, k, tj.utj_val) in + make_judge c tj.utj_val + +let judge_of_inductive env indu = + make_judge (mkIndU indu) (type_of_inductive env indu) + +let judge_of_constructor env cu = + make_judge (mkConstructU cu) (type_of_constructor env cu) + +let judge_of_case env ci pj cj lfj = + let lf, lft = dest_judgev lfj in + make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft)) + (type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft) + +let type_of_projection_constant env (p,u) = + let cst = Projection.constant p in + let cb = lookup_constant cst env in + match cb.const_proj with + | Some pb -> + if cb.const_polymorphic then + Vars.subst_instance_constr u pb.proj_type + else pb.proj_type + | None -> raise (Invalid_argument "type_of_projection: not a projection") + +(* Instantiation of terms on real arguments. *) + +(* Make a type polymorphic if an arity *) + +let extract_level env p = + let _,c = dest_prod_assum env p in + match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None + +let extract_context_levels env l = + let fold l = function + | RelDecl.LocalAssum (_,p) -> extract_level env p :: l + | RelDecl.LocalDef _ -> l + in + List.fold_left fold [] l + +let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} = + let params, ccl = dest_prod_assum env t in + match kind_of_term ccl with + | Sort (Type u) -> + let ind, l = decompose_app (whd_all env c) in + if isInd ind && List.is_empty l then + let mis = lookup_mind_specif env (fst (destInd ind)) in + let nparams = Inductive.inductive_params mis in + let paramsl = CList.lastn nparams params in + let param_ccls = extract_context_levels env paramsl in + let s = { template_param_levels = param_ccls; template_level = u} in + TemplateArity (params,s) + else RegularArity t + | _ -> + RegularArity t diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 2112284ea..007acae60 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -15,7 +15,7 @@ open Declarations (** {6 Typing functions (not yet tagged as safe) } - They return unsafe judgments that are "in context" of a set of + They return unsafe judgments that are "in context" of a set of (local) universe variables (the ones that appear in the term) and associated constraints. In case of polymorphic definitions, these variables and constraints will be generalized. @@ -91,9 +91,6 @@ val judge_of_cast : val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment -(* val judge_of_inductive_knowing_parameters : *) -(* env -> inductive -> unsafe_judgment array -> unsafe_judgment *) - val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment (** {6 Type of Cases. } *) @@ -101,24 +98,15 @@ val judge_of_case : env -> case_info -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment -(** Typecheck general fixpoint (not checking guard conditions) *) -val type_fixpoint : env -> Name.t array -> types array - -> unsafe_judgment array -> unit - -val type_of_constant : env -> pconstant -> types constrained - val type_of_constant_type : env -> constant_type -> types -val type_of_projection : env -> Names.projection puniverses -> types +val type_of_projection_constant : env -> Names.projection puniverses -> types val type_of_constant_in : env -> pconstant -> types val type_of_constant_type_knowing_parameters : env -> constant_type -> types Lazy.t array -> types -val type_of_constant_knowing_parameters : - env -> pconstant -> types Lazy.t array -> types constrained - val type_of_constant_knowing_parameters_in : env -> pconstant -> types Lazy.t array -> types @@ -127,4 +115,4 @@ val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> constant_type (** Check that hyps are included in env and fails with error otherwise *) -val check_hyps_inclusion : env -> constr -> Context.section_context -> unit +val check_hyps_inclusion : env -> ('a -> constr) -> 'a -> Context.Named.t -> unit diff --git a/kernel/vars.ml b/kernel/vars.ml index 2ca749d50..4affb5f9f 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -8,7 +8,8 @@ open Names open Esubst -open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration (*********************) (* Occurring *) @@ -160,14 +161,15 @@ let substnl laml n c = substn_many (make_subst laml) n c let substl laml c = substn_many (make_subst laml) 0 c let subst1 lam c = substn_many [|make_substituend lam|] 0 c -let substnl_decl laml k r = map_constr (fun c -> substnl laml k c) r -let substl_decl laml r = map_constr (fun c -> substnl laml 0 c) r -let subst1_decl lam r = map_constr (fun c -> subst1 lam c) r +let substnl_decl laml k r = RelDecl.map_constr (fun c -> substnl laml k c) r +let substl_decl laml r = RelDecl.map_constr (fun c -> substnl laml 0 c) r +let subst1_decl lam r = RelDecl.map_constr (fun c -> subst1 lam c) r (* Build a substitution from an instance, inserting missing let-ins *) let subst_of_rel_context_instance sign l = let rec aux subst sign l = + let open RelDecl in match sign, l with | LocalAssum _ :: sign', a::args' -> aux (a::subst) sign' args' | LocalDef (_,c,_)::sign', args' -> @@ -179,6 +181,15 @@ let subst_of_rel_context_instance sign l = let adjust_subst_to_rel_context sign l = List.rev (subst_of_rel_context_instance sign l) +let adjust_rel_to_rel_context sign n = + let rec aux sign = + let open RelDecl in + match sign with + | LocalAssum _ :: sign' -> let (n',p) = aux sign' in (n'+1,p) + | LocalDef (_,c,_)::sign' -> let (n',p) = aux sign' in (n'+1,if n'<n then p+1 else p) + | [] -> (0,n) + in snd (aux sign) + (* (thin_val sigma) removes identity substitutions from sigma *) let rec thin_val = function diff --git a/kernel/vars.mli b/kernel/vars.mli index 574d50ecc..f7535e6d8 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -73,6 +73,10 @@ val subst_of_rel_context_instance : Context.Rel.t -> constr list -> substl (** For compatibility: returns the substitution reversed *) val adjust_subst_to_rel_context : Context.Rel.t -> constr list -> constr list +(** Take an index in an instance of a context and returns its index wrt to + the full context (e.g. 2 in [x:A;y:=b;z:C] is 3, i.e. a reference to z) *) +val adjust_rel_to_rel_context : Context.Rel.t -> int -> int + (** [substnl [a₁;...;an] k c] substitutes in parallel [a₁],...,[an] for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates accordingly indexes in [an],...,[a1] and [c]. In terms of typing, if diff --git a/lib/aux_file.ml b/lib/aux_file.ml index c6c7b4242..1b6651a55 100644 --- a/lib/aux_file.ml +++ b/lib/aux_file.ml @@ -72,14 +72,15 @@ let load_aux_file_for vfile = let add loc k v = h := set !h loc k v in let aux_fname = aux_file_name_for vfile in try - let ic = open_in aux_fname in - let ver, hash, fname = Scanf.fscanf ic "COQAUX%d %s %s\n" ret3 in + let ib = Scanf.Scanning.from_channel (open_in aux_fname) in + let ver, hash, fname = + Scanf.bscanf ib "COQAUX%d %s %s\n" ret3 in if ver <> version then raise (Failure "aux file version mismatch"); if fname <> vfile then raise (Failure "aux file name mismatch"); let only_dummyloc = Digest.to_hex (Digest.file vfile) <> hash in while true do - let i, j, k, v = Scanf.fscanf ic "%d %d %s %S\n" ret4 in + let i, j, k, v = Scanf.bscanf ib "%d %d %s %S\n" ret4 in if not only_dummyloc || (i = 0 && j = 0) then add (i,j) k v; done; raise End_of_file diff --git a/lib/cErrors.ml b/lib/cErrors.ml index 5c56192fc..99b763602 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -16,16 +16,6 @@ let push = Backtrace.add_backtrace exception Anomaly of string option * std_ppcmds (* System errors *) -(* XXX: To move to common tagging functions in Pp, blocked on tag - * system cleanup as we cannot define generic error tags now. - * - * Anyways, tagging should not happen here, but in the specific - * listener to the msg_* stuff. - *) -let tag_err_str s = tag Ppstyle.(Tag.inj error_tag tag) (str s) ++ spc () -let err_str = tag_err_str "Error:" -let ann_str = tag_err_str "Anomaly:" - let _ = let pr = function | Anomaly (s, pp) -> Some ("\"Anomaly: " ^ string_of_ppcmds pp ^ "\"") @@ -36,25 +26,24 @@ let _ = let make_anomaly ?label pp = Anomaly (label, pp) -let anomaly ?loc ?label pp = match loc with - | None -> raise (Anomaly (label, pp)) - | Some loc -> Loc.raise loc (Anomaly (label, pp)) +let anomaly ?loc ?label pp = + Loc.raise ?loc (Anomaly (label, pp)) let is_anomaly = function | Anomaly _ -> true | _ -> false -exception UserError of string * std_ppcmds (* User errors *) -let error string = raise (UserError("_", str string)) -let errorlabstrm l pps = raise (UserError(l,pps)) - -exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *) -let alreadydeclared pps = raise (AlreadyDeclared(pps)) +exception UserError of string option * std_ppcmds (* User errors *) let todo s = prerr_string ("TODO: "^s^"\n") -let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm)) -let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s) +let user_err ?loc ?hdr strm = Loc.raise ?loc (UserError (hdr, strm)) +let error string = user_err (str string) + +let invalid_arg ?loc s = Loc.raise ?loc (Invalid_argument s) + +exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *) +let alreadydeclared pps = raise (AlreadyDeclared(pps)) exception Timeout exception Drop @@ -103,7 +92,7 @@ let print_backtrace e = match Backtrace.get_backtrace e with let print_anomaly askreport e = if askreport then - hov 0 (ann_str ++ raw_anomaly e ++ spc () ++ + hov 0 (raw_anomaly e ++ spc () ++ strbrk "Please report at " ++ str Coq_config.wwwbugtracker ++ str ".") else @@ -125,7 +114,7 @@ let iprint_no_report (e, info) = let _ = register_handler begin function | UserError(s, pps) -> - hov 0 (err_str ++ where (Some s) ++ pps) + hov 0 (where s ++ pps) | _ -> raise Unhandled end @@ -148,13 +137,3 @@ let handled e = let bottom _ = raise Bottom in try let _ = print_gen bottom !handle_stack e in true with Bottom -> false - -(** Prints info which is either an error or - an anomaly and then exits with the appropriate - error code *) - -let fatal_error info anomaly = - let msg = info ++ fnl () in - pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft msg; - Format.pp_print_flush !Pp_control.err_ft (); - exit (if anomaly then 129 else 1) diff --git a/lib/cErrors.mli b/lib/cErrors.mli index e5dad93fd..0665a8ce7 100644 --- a/lib/cErrors.mli +++ b/lib/cErrors.mli @@ -33,15 +33,21 @@ val is_anomaly : exn -> bool This is mostly provided for compatibility. Please avoid doing specific tricks with anomalies thanks to it. See rather [noncritical] below. *) -exception UserError of string * std_ppcmds +exception UserError of string option * std_ppcmds +(** Main error signaling exception. It carries a header plus a pretty printing + doc *) + +val user_err : ?loc:Loc.t -> ?hdr:string -> std_ppcmds -> 'a +(** Main error raising primitive. [user_err ?loc ?hdr pp] signals an + error [pp] with optional header and location [hdr] [loc] *) + val error : string -> 'a -val errorlabstrm : string -> std_ppcmds -> 'a -val user_err_loc : Loc.t * string * std_ppcmds -> 'a +(** [error s] just calls [user_error "_" (str s)] *) exception AlreadyDeclared of std_ppcmds val alreadydeclared : std_ppcmds -> 'a -val invalid_arg_loc : Loc.t * string -> 'a +val invalid_arg : ?loc:Loc.t -> string -> 'a (** [todo] is for running of an incomplete code its implementation is "do nothing" (or print a message), but this function should not be @@ -92,8 +98,3 @@ val noncritical : exn -> bool (** Check whether an exception is handled by some toplevel printer. The [Anomaly] exception is never handled. *) val handled : exn -> bool - -(** Prints info which is either an error or - an anomaly and then exits with the appropriate - error code *) -val fatal_error : Pp.std_ppcmds -> bool -> 'a diff --git a/lib/cString.ml b/lib/cString.ml index 0c2ed2e7c..61ed03083 100644 --- a/lib/cString.ml +++ b/lib/cString.ml @@ -17,7 +17,6 @@ sig val explode : string -> string list val implode : string list -> string val strip : string -> string - val map : (char -> char) -> string -> string val drop_simple_quotes : string -> string val string_index_from : string -> int -> string -> int val string_contains : where:string -> what:string -> bool @@ -78,12 +77,6 @@ let strip s = let a = lstrip_rec 0 and b = rstrip_rec (n-1) in String.sub s a (b-a+1) -let map f s = - let l = String.length s in - let r = String.create l in - for i = 0 to (l - 1) do r.[i] <- f (s.[i]) done; - r - let drop_simple_quotes s = let n = String.length s in if n > 2 && s.[0] = '\'' && s.[n-1] = '\'' then String.sub s 1 (n-2) else s diff --git a/lib/cString.mli b/lib/cString.mli index 5292b34d0..65edfbbe6 100644 --- a/lib/cString.mli +++ b/lib/cString.mli @@ -32,9 +32,6 @@ sig val strip : string -> string (** Remove the surrounding blank characters from a string *) - val map : (char -> char) -> string -> string - (** Apply a function on a string character-wise. *) - val drop_simple_quotes : string -> string (** Remove the eventual first surrounding simple quotes of a string. *) diff --git a/lib/cThread.ml b/lib/cThread.ml index 4f60a6974..9f642b3ce 100644 --- a/lib/cThread.ml +++ b/lib/cThread.ml @@ -36,7 +36,7 @@ let really_read_fd fd s off len = let really_read_fd_2_oc fd oc len = let i = ref 0 in let size = 4096 in - let s = String.create size in + let s = Bytes.create size in while !i < len do let len = len - !i in let r = thread_friendly_read_fd fd s ~off:0 ~len:(min len size) in @@ -55,11 +55,13 @@ let thread_friendly_really_read_line ic = try let fd = Unix.descr_of_in_channel ic in let b = Buffer.create 1024 in - let s = String.make 1 '\000' in - while s <> "\n" do + let s = Bytes.make 1 '\000' in + let endl = Bytes.of_string "\n" in + (* Bytes.equal is in 4.03.0 *) + while Bytes.compare s endl <> 0 do let n = thread_friendly_read_fd fd s ~off:0 ~len:1 in if n = 0 then raise End_of_file; - if s <> "\n" then Buffer.add_string b s; + if Bytes.compare s endl <> 0 then Buffer.add_bytes b s; done; Buffer.contents b with Unix.Unix_error _ -> raise End_of_file @@ -67,15 +69,15 @@ let thread_friendly_really_read_line ic = let thread_friendly_input_value ic = try let fd = Unix.descr_of_in_channel ic in - let header = String.create Marshal.header_size in + let header = Bytes.create Marshal.header_size in really_read_fd fd header 0 Marshal.header_size; let body_size = Marshal.data_size header 0 in let desired_size = body_size + Marshal.header_size in if desired_size <= Sys.max_string_length then begin - let msg = String.create desired_size in - String.blit header 0 msg 0 Marshal.header_size; + let msg = Bytes.create desired_size in + Bytes.blit header 0 msg 0 Marshal.header_size; really_read_fd fd msg Marshal.header_size body_size; - Marshal.from_string msg 0 + Marshal.from_bytes msg 0 end else begin (* Workaround for 32 bit systems and data > 16M *) let name, oc = diff --git a/lib/cThread.mli b/lib/cThread.mli index 7302dfb55..36477a116 100644 --- a/lib/cThread.mli +++ b/lib/cThread.mli @@ -19,8 +19,8 @@ val prepare_in_channel_for_thread_friendly_io : in_channel -> thread_ic val thread_friendly_input_value : thread_ic -> 'a val thread_friendly_read : - thread_ic -> string -> off:int -> len:int -> int + thread_ic -> Bytes.t -> off:int -> len:int -> int val thread_friendly_really_read : - thread_ic -> string -> off:int -> len:int -> unit + thread_ic -> Bytes.t -> off:int -> len:int -> unit val thread_friendly_really_read_line : thread_ic -> string diff --git a/lib/cUnix.ml b/lib/cUnix.ml index cb436511f..2542b9751 100644 --- a/lib/cUnix.ml +++ b/lib/cUnix.ml @@ -91,15 +91,15 @@ let rec waitpid_non_intr pid = let run_command ?(hook=(fun _ ->())) c = let result = Buffer.create 127 in let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in - let buff = String.make 127 ' ' in - let buffe = String.make 127 ' ' in + let buff = Bytes.make 127 ' ' in + let buffe = Bytes.make 127 ' ' in let n = ref 0 in let ne = ref 0 in while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; !n+ !ne <> 0 do - let r = String.sub buff 0 !n in (hook r; Buffer.add_string result r); - let r = String.sub buffe 0 !ne in (hook r; Buffer.add_string result r); + let r = Bytes.sub buff 0 !n in (hook r; Buffer.add_bytes result r); + let r = Bytes.sub buffe 0 !ne in (hook r; Buffer.add_bytes result r); done; (Unix.close_process_full (cin,cout,cerr), Buffer.contents result) diff --git a/lib/cUnix.mli b/lib/cUnix.mli index f03719c3d..c6bcf6347 100644 --- a/lib/cUnix.mli +++ b/lib/cUnix.mli @@ -46,7 +46,7 @@ val file_readable_p : string -> bool is called on each elements read on stdout or stderr. *) val run_command : - ?hook:(string->unit) -> string -> Unix.process_status * string + ?hook:(bytes->unit) -> string -> Unix.process_status * string (** [sys_command] launches program [prog] with arguments [args]. It behaves like [Sys.command], except that we rely on diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index cc2463e22..2f569d284 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -49,8 +49,8 @@ let create ~name ~category ?(default=Enabled) pp = | Disabled -> () | AsError -> begin match refine_loc loc with - | Some loc -> CErrors.user_err_loc (loc,"_",pp x) - | None -> CErrors.errorlabstrm "_" (pp x) + | Some loc -> CErrors.user_err ~loc (pp x) + | None -> CErrors.user_err (pp x) end | Enabled -> let msg = diff --git a/lib/clib.mllib b/lib/clib.mllib index 1e33173ee..c73ae9b90 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -15,7 +15,6 @@ Store Exninfo Backtrace IStream -Pp_control Flags Control Loc @@ -28,8 +27,6 @@ CStack Util Stateid Pp -Ppstyle -Richpp Feedback CUnix Envars diff --git a/lib/feedback.ml b/lib/feedback.ml index 44b3ee35d..7d9d6bf7f 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -27,7 +27,6 @@ type feedback_content = | ProcessingIn of string | InProgress of int | WorkerStatus of string * string - | Goals of Loc.t * string | AddedAxiom | GlobRef of Loc.t * string * string * string * string | GlobDef of Loc.t * string * string * string @@ -36,7 +35,7 @@ type feedback_content = (* Extra metadata *) | Custom of Loc.t * string * xml (* Generic messages *) - | Message of level * Loc.t option * Richpp.richpp + | Message of level * Loc.t option * Pp.std_ppcmds type feedback = { id : edit_or_state_id; @@ -46,146 +45,16 @@ type feedback = { let default_route = 0 -(** Feedback and logging *) -open Pp -open Pp_control - -type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit - -let msgnl_with ?pp_tag fmt strm = msg_with ?pp_tag fmt (strm ++ fnl ()) - -(* XXX: This is really painful! *) -module Emacs = struct - - (* Special chars for emacs, to detect warnings inside goal output *) - let emacs_quote_start = String.make 1 (Char.chr 254) - let emacs_quote_end = String.make 1 (Char.chr 255) - - let emacs_quote_err g = - hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end) - - let emacs_quote_info_start = "<infomsg>" - let emacs_quote_info_end = "</infomsg>" - - let emacs_quote_info g = - hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end) - -end - -open Emacs - -let dbg_str = tag Ppstyle.(Tag.inj debug_tag tag) (str "Debug:") ++ spc () -let info_str = mt () -let warn_str = tag Ppstyle.(Tag.inj warning_tag tag) (str "Warning:") ++ spc () -let err_str = tag Ppstyle.(Tag.inj error_tag tag) (str "Error:" ) ++ spc () - -let make_body quoter info ?loc s = - let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in - quoter (hov 0 (loc ++ info ++ s)) - -(* Generic logger *) -let gen_logger dbg err ?pp_tag ?loc level msg = match level with - | Debug -> msgnl_with ?pp_tag !std_ft (make_body dbg dbg_str ?loc msg) - | Info -> msgnl_with ?pp_tag !std_ft (make_body dbg info_str ?loc msg) - | Notice -> msgnl_with ?pp_tag !std_ft msg - | Warning -> Flags.if_warn (fun () -> - msgnl_with ?pp_tag !err_ft (make_body err warn_str ?loc msg)) () - | Error -> msgnl_with ?pp_tag !err_ft (make_body err err_str ?loc msg) - -(* We provide a generic clear_log_backend callback for backends - wanting to do clenaup after the print. -*) -let std_logger_tag = ref None -let std_logger_cleanup = ref (fun () -> ()) - -let std_logger ?loc level msg = - gen_logger (fun x -> x) (fun x -> x) ?pp_tag:!std_logger_tag ?loc level msg; - !std_logger_cleanup () - -(* Rules for emacs: - - Debug/info: emacs_quote_info - - Warning/Error: emacs_quote_err - - Notice: unquoted - - Note the inconsistency. - *) -let emacs_logger = gen_logger emacs_quote_info emacs_quote_err ?pp_tag:None - -(** Color logging. Moved from pp_style, it may need some more refactoring *) - -(** Not thread-safe. We should put a lock somewhere if we print from - different threads. Do we? *) -let make_style_stack () = - (** Default tag is to reset everything *) - let empty = Terminal.make () in - let default_tag = Terminal.({ - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; - }) - in - let style_stack = ref [] in - let peek () = match !style_stack with - | [] -> default_tag (** Anomalous case, but for robustness *) - | st :: _ -> st - in - let push tag = - let style = match Ppstyle.get_style tag with - | None -> empty - | Some st -> st - in - (** Use the merging of the latest tag and the one being currently pushed. - This may be useful if for instance the latest tag changes the background and - the current one the foreground, so that the two effects are additioned. *) - let style = Terminal.merge (peek ()) style in - style_stack := style :: !style_stack; - Terminal.eval style - in - let pop _ = match !style_stack with - | [] -> (** Something went wrong, we fallback *) - Terminal.eval default_tag - | _ :: rem -> style_stack := rem; - Terminal.eval (peek ()) - in - let clear () = style_stack := [] in - push, pop, clear - -let init_color_output () = - let open Pp_control in - let push_tag, pop_tag, clear_tag = make_style_stack () in - std_logger_cleanup := clear_tag; - std_logger_tag := Some Ppstyle.pp_tag; - let tag_handler = { - Format.mark_open_tag = push_tag; - Format.mark_close_tag = pop_tag; - Format.print_open_tag = ignore; - Format.print_close_tag = ignore; - } in - Format.pp_set_mark_tags !std_ft true; - Format.pp_set_mark_tags !err_ft true; - Format.pp_set_formatter_tag_functions !std_ft tag_handler; - Format.pp_set_formatter_tag_functions !err_ft tag_handler - -let logger = ref std_logger -let set_logger l = logger := l - -let msg_info ?loc x = !logger ?loc Info x -let msg_notice ?loc x = !logger ?loc Notice x -let msg_warning ?loc x = !logger ?loc Warning x -let msg_error ?loc x = !logger ?loc Error x -let msg_debug ?loc x = !logger ?loc Debug x - (** Feeders *) -let feeders = ref [] -let add_feeder f = feeders := f :: !feeders +let feeders : (int, feedback -> unit) Hashtbl.t = Hashtbl.create 7 -let debug_feeder = function - | { contents = Message (Debug, loc, pp) } -> - msg_debug ?loc (Pp.str (Richpp.raw_print pp)) - | _ -> () +let add_feeder = + let f_id = ref 0 in fun f -> + incr f_id; + Hashtbl.add feeders !f_id f; + !f_id + +let del_feeder fid = Hashtbl.remove feeders fid let feedback_id = ref (Edit 0) let feedback_route = ref default_route @@ -199,34 +68,14 @@ let feedback ?id ?route what = route = Option.default !feedback_route route; id = Option.default !feedback_id id; } in - List.iter (fun f -> f m) !feeders + Hashtbl.iter (fun _ f -> f m) feeders +(* Logging messages *) let feedback_logger ?loc lvl msg = - feedback ~route:!feedback_route ~id:!feedback_id - (Message (lvl, loc, Richpp.richpp_of_pp msg)) - -(* Output to file *) -let ft_logger old_logger ft ?loc level mesg = - let id x = x in - match level with - | Debug -> msgnl_with ft (make_body id dbg_str mesg) - | Info -> msgnl_with ft (make_body id info_str mesg) - | Notice -> msgnl_with ft mesg - | Warning -> old_logger ?loc level mesg - | Error -> old_logger ?loc level mesg - -let with_output_to_file fname func input = - let old_logger = !logger in - let channel = open_out (String.concat "." [fname; "out"]) in - logger := ft_logger old_logger (Format.formatter_of_out_channel channel); - try - let output = func input in - logger := old_logger; - close_out channel; - output - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - logger := old_logger; - close_out channel; - Exninfo.iraise reraise + feedback ~route:!feedback_route ~id:!feedback_id (Message (lvl, loc, msg)) +let msg_info ?loc x = feedback_logger ?loc Info x +let msg_notice ?loc x = feedback_logger ?loc Notice x +let msg_warning ?loc x = feedback_logger ?loc Warning x +let msg_error ?loc x = feedback_logger ?loc Error x +let msg_debug ?loc x = feedback_logger ?loc Debug x diff --git a/lib/feedback.mli b/lib/feedback.mli index 5160bd5bc..4bbdfcb5b 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -8,7 +8,7 @@ open Xml_datatype -(* Old plain messages (used to be in Pp) *) +(* Legacy-style logging messages (used to be in Pp) *) type level = | Debug | Info @@ -16,7 +16,6 @@ type level = | Warning | Error - (** Coq "semantic" infos obtained during parsing/execution *) type edit_id = int type state_id = Stateid.t @@ -36,7 +35,6 @@ type feedback_content = | InProgress of int | WorkerStatus of string * string (* Generally useful metadata *) - | Goals of Loc.t * string | AddedAxiom | GlobRef of Loc.t * string * string * string * string | GlobDef of Loc.t * string * string * string @@ -45,7 +43,7 @@ type feedback_content = (* Extra metadata *) | Custom of Loc.t * string * xml (* Generic messages *) - | Message of level * Loc.t option * Richpp.richpp + | Message of level * Loc.t option * Pp.std_ppcmds type feedback = { id : edit_or_state_id; (* The document part concerned *) @@ -54,37 +52,17 @@ type feedback = { } (** {6 Feedback sent, even asynchronously, to the user interface} *) - -(** Moved here from pp.ml *) - (* Morally the parser gets a string and an edit_id, and gives back an AST. * Feedbacks during the parsing phase are attached to this edit_id. * The interpreter assignes an exec_id to the ast, and feedbacks happening * during interpretation are attached to the exec_id. * Only one among state_id and edit_id can be provided. *) -(** A [logger] takes a level plus a pretty printing doc and logs it *) -type logger = ?loc:Loc.t -> level -> Pp.std_ppcmds -> unit - -(** [set_logger l] makes the [msg_*] to use [l] for logging *) -val set_logger : logger -> unit - -(** [std_logger] standard logger to [stdout/stderr] *) -val std_logger : logger - -(** [init_color_output ()] Enable color in the std_logger *) -val init_color_output : unit -> unit - -(** [feedback_logger] will produce feedback messages instead IO events *) -val feedback_logger : logger -val emacs_logger : logger +(** [add_feeder f] adds a feeder listiner [f], returning its id *) +val add_feeder : (feedback -> unit) -> int - -(** [add_feeder] feeders observe the feedback *) -val add_feeder : (feedback -> unit) -> unit - -(** Prints feedback messages of kind Message(Debug,_) using msg_debug *) -val debug_feeder : feedback -> unit +(** [del_feeder fid] removes the feeder with id [fid] *) +val del_feeder : int -> unit (** [feedback ?id ?route fb] produces feedback fb, with [route] and [id] set appropiatedly, if absent, it will use the defaults set by @@ -95,10 +73,6 @@ val feedback : (** [set_id_for_feedback route id] Set the defaults for feedback *) val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit -(** [with_output_to_file file f x] executes [f x] with logging - redirected to a file [file] *) -val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b - (** {6 output functions} [msg_notice] do not put any decoration on output by default. If @@ -126,7 +100,3 @@ val msg_error : ?loc:Loc.t -> Pp.std_ppcmds -> unit val msg_debug : ?loc:Loc.t -> Pp.std_ppcmds -> unit (** For debugging purposes *) - - - - diff --git a/lib/flags.ml b/lib/flags.ml index 0e2f7e5a6..5b080151c 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -108,24 +108,27 @@ let we_are_parsing = ref false (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current +type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | V8_6 | Current let compat_version = ref Current let version_compare v1 v2 = match v1, v2 with | V8_2, V8_2 -> 0 -| V8_2, (V8_3 | V8_4 | V8_5 | Current) -> -1 +| V8_2, (V8_3 | V8_4 | V8_5 | V8_6 | Current) -> -1 | V8_3, V8_2 -> 1 | V8_3, V8_3 -> 0 -| V8_3, (V8_4 | V8_5 | Current) -> -1 +| V8_3, (V8_4 | V8_5 | V8_6 | Current) -> -1 | V8_4, (V8_2 | V8_3) -> 1 | V8_4, V8_4 -> 0 -| V8_4, (V8_5 | Current) -> -1 +| V8_4, (V8_5 | V8_6 | Current) -> -1 | V8_5, (V8_2 | V8_3 | V8_4) -> 1 | V8_5, V8_5 -> 0 -| V8_5, Current -> -1 +| V8_5, (V8_6 | Current) -> -1 +| V8_6, (V8_2 | V8_3 | V8_4 | V8_5) -> 1 +| V8_6, V8_6 -> 0 +| V8_6, Current -> -1 | Current, Current -> 0 -| Current, (V8_2 | V8_3 | V8_4 | V8_5) -> 1 +| Current, (V8_2 | V8_3 | V8_4 | V8_5 | V8_6) -> 1 let version_strictly_greater v = version_compare !compat_version v > 0 let version_less_or_equal v = not (version_strictly_greater v) @@ -135,6 +138,7 @@ let pr_version = function | V8_3 -> "8.3" | V8_4 -> "8.4" | V8_5 -> "8.5" + | V8_6 -> "8.6" | Current -> "current" (* Translate *) diff --git a/lib/flags.mli b/lib/flags.mli index 897602641..bd365e653 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -62,7 +62,7 @@ val raw_print : bool ref val record_print : bool ref val univ_print : bool ref -type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current +type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | V8_6 | Current val compat_version : compat_version ref val version_compare : compat_version -> compat_version -> int val version_strictly_greater : compat_version -> bool diff --git a/lib/future.ml b/lib/future.ml index ca73d5e39..1360b7ac4 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -191,9 +191,9 @@ let transactify f x = let purify_future f x = if is_over x then f x else purify f x let compute x = purify_future (compute ~pure:false) x let force ~pure x = purify_future (force ~pure) x -let chain ?(greedy=true) ~pure x f = +let chain ~pure x f = let y = chain ~pure x f in - if is_over x && greedy then ignore(force ~pure y); + if is_over x then ignore(force ~pure y); y let force x = force ~pure:false x @@ -204,13 +204,13 @@ let join kx = let sink kx = if is_val kx then ignore(join kx) -let split2 ?greedy x = - chain ?greedy ~pure:true x (fun x -> fst x), - chain ?greedy ~pure:true x (fun x -> snd x) +let split2 x = + chain ~pure:true x (fun x -> fst x), + chain ~pure:true x (fun x -> snd x) -let map2 ?greedy f x l = +let map2 f x l = CList.map_i (fun i y -> - let xi = chain ?greedy ~pure:true x (fun x -> + let xi = chain ~pure:true x (fun x -> try List.nth x i with Failure _ | Invalid_argument _ -> CErrors.anomaly (Pp.str "Future.map2 length mismatch")) in diff --git a/lib/future.mli b/lib/future.mli index 114c59176..2a025ae84 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -87,7 +87,7 @@ val from_val : ?fix_exn:fix_exn -> 'a -> 'a computation the value is not just the 'a but also the global system state *) val from_here : ?fix_exn:fix_exn -> 'a -> 'a computation -(* To get the fix_exn of a computation and build a Tacexpr.declaration_hook. +(* To get the fix_exn of a computation and build a Lemmas.declaration_hook. * When a future enters the environment a corresponding hook is run to perform * some work. If this fails, then its failure has to be annotated with the * same state id that corresponds to the future computation end. I.e. Qed @@ -113,8 +113,9 @@ val is_exn : 'a computation -> bool val peek_val : 'a computation -> 'a option val uuid : 'a computation -> UUID.t -(* [chain greedy pure c f] chains computation [c] with [f]. - * The [greedy] and [pure] parameters are tricky: +(* [chain pure c f] chains computation [c] with [f]. + * [chain] forces immediately the new computation if the old one is_over (Exn or Val). + * The [pure] parameter is tricky: * [pure]: * When pure is true, the returned computation will not keep a copy * of the global state. @@ -124,10 +125,8 @@ val uuid : 'a computation -> UUID.t * one forces c' and then c''. * [join c; chain ~pure:false c g] is invalid and fails at runtime. * [force c; chain ~pure:false c g] is correct. - * [greedy]: - * The [greedy] parameter forces immediately the new computation if - * the old one is_over (Exn or Val). Defaults to true. *) -val chain : ?greedy:bool -> pure:bool -> + *) +val chain : pure:bool -> 'a computation -> ('a -> 'b) -> 'b computation (* Forcing a computation *) @@ -143,9 +142,9 @@ val join : 'a computation -> 'a val sink : 'a computation -> unit (*** Utility functions ************************************************* ***) -val split2 : ?greedy:bool -> +val split2 : ('a * 'b) computation -> 'a computation * 'b computation -val map2 : ?greedy:bool -> +val map2 : ('a computation -> 'b -> 'c) -> 'a list computation -> 'b list -> 'c list diff --git a/lib/loc.ml b/lib/loc.ml index 0f9864a9a..e373a760c 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -71,6 +71,9 @@ let add_loc e loc = Exninfo.add e location loc let get_loc e = Exninfo.get e location -let raise loc e = - let info = Exninfo.add Exninfo.null location loc in - Exninfo.iraise (e, info) +let raise ?loc e = + match loc with + | None -> raise e + | Some loc -> + let info = Exninfo.add Exninfo.null location loc in + Exninfo.iraise (e, info) diff --git a/lib/loc.mli b/lib/loc.mli index c08e097a8..bb88f8642 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -51,7 +51,7 @@ val add_loc : Exninfo.info -> t -> Exninfo.info val get_loc : Exninfo.info -> t option (** Retrieving the optional location of an exception *) -val raise : t -> exn -> 'a +val raise : ?loc:t -> exn -> 'a (** [raise loc e] is the same as [Pervasives.raise (add_loc e loc)]. *) (** {5 Location utilities} *) diff --git a/lib/monad.mli b/lib/monad.mli index f7de71f53..7b0a3e600 100644 --- a/lib/monad.mli +++ b/lib/monad.mli @@ -66,7 +66,8 @@ module type ListS = sig its second argument in a tail position. *) val iter : ('a -> unit t) -> 'a list -> unit t - (** Like the regular {!CList.map_filter}. The monadic effects are threaded left*) + (** Like the regular {!CList.map_filter}. The monadic effects are + threaded left to right. *) val map_filter : ('a -> 'b option t) -> 'a list -> 'b list t @@ -6,64 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -module Glue : sig - - (** The [Glue] module implements a container data structure with - efficient concatenation. *) - - type 'a t - - val atom : 'a -> 'a t - val glue : 'a t -> 'a t -> 'a t - val empty : 'a t - val is_empty : 'a t -> bool - val iter : ('a -> unit) -> 'a t -> unit - -end = struct - - type 'a t = GEmpty | GLeaf of 'a | GNode of 'a t * 'a t - - let atom x = GLeaf x - - let glue x y = - match x, y with - | GEmpty, _ -> y - | _, GEmpty -> x - | _, _ -> GNode (x,y) - - let empty = GEmpty - - let is_empty x = x = GEmpty - - let rec iter f = function - | GEmpty -> () - | GLeaf x -> f x - | GNode (x,y) -> iter f x; iter f y - -end - -module Tag : -sig - type t - type 'a key - val create : string -> 'a key - val inj : 'a -> 'a key -> t - val prj : t -> 'a key -> 'a option -end = -struct - -module Dyn = Dyn.Make(struct end) - -type t = Dyn.t -type 'a key = 'a Dyn.tag -let create = Dyn.create -let inj = Dyn.Easy.inj -let prj = Dyn.Easy.prj - -end - -open Pp_control - (* The different kinds of blocks are: \begin{description} \item[hbox:] Horizontal block no line breaking; @@ -72,54 +14,35 @@ open Pp_control this block is small enough to fit on a single line \item[hovbox:] Horizontal or Vertical block: breaks lead to new line only when necessary to print the content of the block - \item[tbox:] Tabulation block: go to tabulation marks and no line breaking - (except if no mark yet on the reste of the line) \end{description} *) +type pp_tag = string + type block_type = - | Pp_hbox of int - | Pp_vbox of int - | Pp_hvbox of int + | Pp_hbox of int + | Pp_vbox of int + | Pp_hvbox of int | Pp_hovbox of int - | Pp_tbox - -type str_token = -| Str_def of string -| Str_len of string * int (** provided length *) -type 'a ppcmd_token = - | Ppcmd_print of 'a - | Ppcmd_box of block_type * ('a ppcmd_token Glue.t) +type doc_view = + | Ppcmd_empty + | Ppcmd_string of string + | Ppcmd_glue of doc_view list + | Ppcmd_box of block_type * doc_view + | Ppcmd_tag of pp_tag * doc_view + (* Are those redundant? *) | Ppcmd_print_break of int * int - | Ppcmd_set_tab - | Ppcmd_print_tbreak of int * int - | Ppcmd_white_space of int | Ppcmd_force_newline - | Ppcmd_print_if_broken - | Ppcmd_open_box of block_type - | Ppcmd_close_box - | Ppcmd_close_tbox | Ppcmd_comment of string list - | Ppcmd_open_tag of Tag.t - | Ppcmd_close_tag - -type 'a ppdir_token = - | Ppdir_ppcmds of 'a ppcmd_token Glue.t - | Ppdir_print_newline - | Ppdir_print_flush - -type ppcmd = str_token ppcmd_token -type std_ppcmds = ppcmd Glue.t +(* Following discussion on #390, we play on the safe side and make the + internal representation opaque here. *) +type t = doc_view +type std_ppcmds = t -type 'a ppdirs = 'a ppdir_token Glue.t - -let (++) = Glue.glue - -let app = Glue.glue - -let is_empty g = Glue.is_empty g +let repr x = x +let unrepr x = x (* Compute length of an UTF-8 encoded string Rem 1 : utf8_length <= String.length (equal if pure ascii) @@ -157,25 +80,32 @@ let utf8_length s = done ; !cnt +let app s1 s2 = match s1, s2 with + | Ppcmd_empty, s + | s, Ppcmd_empty -> s + | s1, s2 -> Ppcmd_glue [s1; s2] + +let seq s = Ppcmd_glue s + +let (++) = app + (* formatting commands *) -let str s = Glue.atom(Ppcmd_print (Str_def s)) -let stras (i, s) = Glue.atom(Ppcmd_print (Str_len (s, i))) -let brk (a,b) = Glue.atom(Ppcmd_print_break (a,b)) -let tbrk (a,b) = Glue.atom(Ppcmd_print_tbreak (a,b)) -let tab () = Glue.atom(Ppcmd_set_tab) -let fnl () = Glue.atom(Ppcmd_force_newline) -let pifb () = Glue.atom(Ppcmd_print_if_broken) -let ws n = Glue.atom(Ppcmd_white_space n) -let comment l = Glue.atom(Ppcmd_comment l) +let str s = Ppcmd_string s +let brk (a,b) = Ppcmd_print_break (a,b) +let fnl () = Ppcmd_force_newline +let ws n = Ppcmd_print_break (n,0) +let comment l = Ppcmd_comment l (* derived commands *) -let mt () = Glue.empty -let spc () = Glue.atom(Ppcmd_print_break (1,0)) -let cut () = Glue.atom(Ppcmd_print_break (0,0)) -let align () = Glue.atom(Ppcmd_print_break (0,0)) -let int n = str (string_of_int n) -let real r = str (string_of_float r) -let bool b = str (string_of_bool b) +let mt () = Ppcmd_empty +let spc () = Ppcmd_print_break (1,0) +let cut () = Ppcmd_print_break (0,0) +let align () = Ppcmd_print_break (0,0) +let int n = str (string_of_int n) +let real r = str (string_of_float r) +let bool b = str (string_of_bool b) + +(* XXX: To Remove *) let strbrk s = let rec aux p n = if n < String.length s then @@ -184,7 +114,7 @@ let strbrk s = else str (String.sub s p (n-p)) :: spc () :: aux (n+1) (n+1) else aux p (n + 1) else if p = n then [] else [str (String.sub s p (n-p))] - in List.fold_left (++) Glue.empty (aux 0 0) + in Ppcmd_glue (aux 0 0) let pr_loc_pos loc = if Loc.is_ghost loc then (str"<unknown>") @@ -205,29 +135,16 @@ let pr_loc loc = int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++ str":" ++ fnl()) -let ismt = is_empty +let ismt = function | Ppcmd_empty -> true | _ -> false (* boxing commands *) -let h n s = Glue.atom(Ppcmd_box(Pp_hbox n,s)) -let v n s = Glue.atom(Ppcmd_box(Pp_vbox n,s)) -let hv n s = Glue.atom(Ppcmd_box(Pp_hvbox n,s)) -let hov n s = Glue.atom(Ppcmd_box(Pp_hovbox n,s)) -let t s = Glue.atom(Ppcmd_box(Pp_tbox,s)) - -(* Opening and closing of boxes *) -let hb n = Glue.atom(Ppcmd_open_box(Pp_hbox n)) -let vb n = Glue.atom(Ppcmd_open_box(Pp_vbox n)) -let hvb n = Glue.atom(Ppcmd_open_box(Pp_hvbox n)) -let hovb n = Glue.atom(Ppcmd_open_box(Pp_hovbox n)) -let tb () = Glue.atom(Ppcmd_open_box Pp_tbox) -let close () = Glue.atom(Ppcmd_close_box) -let tclose () = Glue.atom(Ppcmd_close_tbox) +let h n s = Ppcmd_box(Pp_hbox n,s) +let v n s = Ppcmd_box(Pp_vbox n,s) +let hv n s = Ppcmd_box(Pp_hvbox n,s) +let hov n s = Ppcmd_box(Pp_hovbox n,s) (* Opening and closed of tags *) -let open_tag t = Glue.atom(Ppcmd_open_tag t) -let close_tag () = Glue.atom(Ppcmd_close_tag) -let tag t s = open_tag t ++ s ++ close_tag () -let eval_ppcmds l = l +let tag t s = Ppcmd_tag(t,s) (* In new syntax only double quote char is escaped by repeating it *) let escape_string s = @@ -254,71 +171,34 @@ let rec pr_com ft s = Some s2 -> Format.pp_force_newline ft (); pr_com ft s2 | None -> () -type tag_handler = Tag.t -> Format.tag - (* pretty printing functions *) -let pp_dirs ?pp_tag ft = - let pp_open_box = function +let pp_with ft = + let cpp_open_box = function | Pp_hbox n -> Format.pp_open_hbox ft () | Pp_vbox n -> Format.pp_open_vbox ft n | Pp_hvbox n -> Format.pp_open_hvbox ft n | Pp_hovbox n -> Format.pp_open_hovbox ft n - | Pp_tbox -> Format.pp_open_tbox ft () in - let rec pp_cmd = function - | Ppcmd_print tok -> - begin match tok with - | Str_def s -> - let n = utf8_length s in - Format.pp_print_as ft n s - | Str_len (s, n) -> - Format.pp_print_as ft n s - end - | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) - pp_open_box bty ; - if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss; - Format.pp_close_box ft () - | Ppcmd_open_box bty -> pp_open_box bty - | Ppcmd_close_box -> Format.pp_close_box ft () - | Ppcmd_close_tbox -> Format.pp_close_tbox ft () - | Ppcmd_white_space n -> Format.pp_print_break ft n 0 - | Ppcmd_print_break(m,n) -> Format.pp_print_break ft m n - | Ppcmd_set_tab -> Format.pp_set_tab ft () - | Ppcmd_print_tbreak(m,n) -> Format.pp_print_tbreak ft m n - | Ppcmd_force_newline -> Format.pp_force_newline ft () - | Ppcmd_print_if_broken -> Format.pp_print_if_newline ft () + let rec pp_cmd = let open Format in function + | Ppcmd_empty -> () + | Ppcmd_glue sl -> List.iter pp_cmd sl + | Ppcmd_string str -> let n = utf8_length str in + pp_print_as ft n str + | Ppcmd_box(bty,ss) -> cpp_open_box bty ; + if not (over_max_boxes ()) then pp_cmd ss; + pp_close_box ft () + | Ppcmd_print_break(m,n) -> pp_print_break ft m n + | Ppcmd_force_newline -> pp_force_newline ft () | Ppcmd_comment coms -> List.iter (pr_com ft) coms - | Ppcmd_open_tag tag -> - begin match pp_tag with - | None -> () - | Some f -> Format.pp_open_tag ft (f tag) - end - | Ppcmd_close_tag -> - begin match pp_tag with - | None -> () - | Some _ -> Format.pp_close_tag ft () - end - in - let pp_dir = function - | Ppdir_ppcmds cmdstream -> Glue.iter pp_cmd cmdstream - | Ppdir_print_newline -> Format.pp_print_newline ft () - | Ppdir_print_flush -> Format.pp_print_flush ft () + | Ppcmd_tag(tag, s) -> pp_open_tag ft tag; + pp_cmd s; + pp_close_tag ft () in - fun (dirstream : _ ppdirs) -> - try - Glue.iter pp_dir dirstream - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - let () = Format.pp_print_flush ft () in - Exninfo.iraise reraise - -(* pretty printing functions WITHOUT FLUSH *) -let pp_with ?pp_tag ft strm = - pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm)) - -(* pretty printing functions WITH FLUSH *) -let msg_with ?pp_tag ft strm = - pp_dirs ?pp_tag ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush)) + try pp_cmd + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + let () = Format.pp_print_flush ft () in + Exninfo.iraise reraise (* If mixing some output and a goal display, please use msg_warning, so that interfaces (proofgeneral for example) can easily dispatch @@ -326,7 +206,7 @@ let msg_with ?pp_tag ft strm = (** Output to a string formatter *) let string_of_ppcmds c = - Format.fprintf Format.str_formatter "@[%a@]" (msg_with ?pp_tag:None) c; + Format.fprintf Format.str_formatter "@[%a@]" pp_with c; Format.flush_str_formatter () (* Copy paste from Util *) @@ -353,7 +233,7 @@ let pr_nth n = (* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *) -let prlist pr l = List.fold_left (fun x e -> x ++ pr e) Glue.empty l +let prlist pr l = Ppcmd_glue (List.map pr l) (* unlike all other functions below, [prlist] works lazily. if a strict behavior is needed, use [prlist_strict] instead. @@ -418,4 +298,3 @@ let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v let prvect elem v = prvect_with_sep mt elem v let surround p = hov 1 (str"(" ++ p ++ str")") - diff --git a/lib/pp.mli b/lib/pp.mli index 8342a983d..802ffe8e7 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -6,19 +6,65 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Pretty-printers. *) +(** Coq document type. *) + +(** Pretty printing guidelines ******************************************) +(* *) +(* `Pp.t` or `Pp.std_ppcmds` is the main pretty printing document type *) +(* in the Coq system. Documents are composed laying out boxes, and *) +(* users can add arbitrary tag metadata that backends are free *) +(* *) +(* The datatype has a public view to allow serialization or advanced *) +(* uses, however regular users are _strongly_ warned againt its use, *) +(* they should instead rely on the available functions below. *) +(* *) +(* Box order and number is indeed an important factor. Try to create *) +(* a proper amount of boxes. The `++` operator provides "efficient" *) +(* concatenation, but using the list constructors is usually preferred. *) +(* *) +(* That is to say, this: *) +(* *) +(* `hov [str "Term"; hov (pr_term t); str "is defined"]` *) +(* *) +(* is preferred to: *) +(* *) +(* `hov (str "Term" ++ hov (pr_term t) ++ str "is defined")` *) +(* *) +(************************************************************************) -type std_ppcmds +(* XXX: Improve and add attributes *) +type pp_tag = string + +(* Following discussion on #390, we play on the safe side and make the + internal representation opaque here. *) +type t +type std_ppcmds = t + +type block_type = + | Pp_hbox of int + | Pp_vbox of int + | Pp_hvbox of int + | Pp_hovbox of int + +type doc_view = + | Ppcmd_empty + | Ppcmd_string of string + | Ppcmd_glue of t list + | Ppcmd_box of block_type * t + | Ppcmd_tag of pp_tag * t + (* Are those redundant? *) + | Ppcmd_print_break of int * int + | Ppcmd_force_newline + | Ppcmd_comment of string list + +val repr : std_ppcmds -> doc_view +val unrepr : doc_view -> std_ppcmds (** {6 Formatting commands} *) val str : string -> std_ppcmds -val stras : int * string -> std_ppcmds val brk : int * int -> std_ppcmds -val tbrk : int * int -> std_ppcmds -val tab : unit -> std_ppcmds val fnl : unit -> std_ppcmds -val pifb : unit -> std_ppcmds val ws : int -> std_ppcmds val mt : unit -> std_ppcmds val ismt : std_ppcmds -> bool @@ -30,15 +76,12 @@ val comment : string list -> std_ppcmds val app : std_ppcmds -> std_ppcmds -> std_ppcmds (** Concatenation. *) +val seq : std_ppcmds list -> std_ppcmds +(** Multi-Concatenation. *) + val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds (** Infix alias for [app]. *) -val eval_ppcmds : std_ppcmds -> std_ppcmds -(** Force computation. *) - -val is_empty : std_ppcmds -> bool -(** Test emptyness. *) - (** {6 Derived commands} *) val spc : unit -> std_ppcmds @@ -58,46 +101,10 @@ val h : int -> std_ppcmds -> std_ppcmds val v : int -> std_ppcmds -> std_ppcmds val hv : int -> std_ppcmds -> std_ppcmds val hov : int -> std_ppcmds -> std_ppcmds -val t : std_ppcmds -> std_ppcmds - -(** {6 Opening and closing of boxes} *) - -val hb : int -> std_ppcmds -val vb : int -> std_ppcmds -val hvb : int -> std_ppcmds -val hovb : int -> std_ppcmds -val tb : unit -> std_ppcmds -val close : unit -> std_ppcmds -val tclose : unit -> std_ppcmds - -(** {6 Opening and closing of tags} *) - -module Tag : -sig - type t - (** Type of tags. Tags are dynamic types comparable to {Dyn.t}. *) - - type 'a key - (** Keys used to inject tags *) - val create : string -> 'a key - (** Create a key with the given name. Two keys cannot share the same name, if - ever this is the case this function raises an assertion failure. *) +(** {6 Tagging} *) - val inj : 'a -> 'a key -> t - (** Inject an object into a tag. *) - - val prj : t -> 'a key -> 'a option - (** Project an object from a tag. *) -end - -val tag : Tag.t -> std_ppcmds -> std_ppcmds -val open_tag : Tag.t -> std_ppcmds -val close_tag : unit -> std_ppcmds - -(** {6 Utilities} *) - -val string_of_ppcmds : std_ppcmds -> string +val tag : pp_tag -> std_ppcmds -> std_ppcmds (** {6 Printing combinators} *) @@ -164,16 +171,11 @@ val surround : std_ppcmds -> std_ppcmds (** Surround with parenthesis. *) val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds - val pr_loc : Loc.t -> std_ppcmds -(** {6 Low-level pretty-printing functions with and without flush} *) +(** {6 Main renderers, to formatter and to string } *) -(** FIXME: These ignore the logging settings and call [Format] directly *) -type tag_handler = Tag.t -> Format.tag +(** [pp_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) +val pp_with : Format.formatter -> std_ppcmds -> unit -(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and flush [fmt] *) -val msg_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit - -(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) -val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit +val string_of_ppcmds : std_ppcmds -> string diff --git a/lib/pp_control.ml b/lib/pp_control.ml deleted file mode 100644 index 890ffe0a1..000000000 --- a/lib/pp_control.ml +++ /dev/null @@ -1,93 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Parameters of pretty-printing *) - -type pp_global_params = { - margin : int; - max_indent : int; - max_depth : int; - ellipsis : string } - -(* Default parameters of pretty-printing *) - -let dflt_gp = { - margin = 78; - max_indent = 50; - max_depth = 50; - ellipsis = "..." } - -(* A deeper pretty-printer to print proof scripts *) - -let deep_gp = { - margin = 78; - max_indent = 50; - max_depth = 10000; - ellipsis = "..." } - -(* set_gp : Format.formatter -> pp_global_params -> unit - * set the parameters of a formatter *) - -let set_gp ft gp = - Format.pp_set_margin ft gp.margin ; - Format.pp_set_max_indent ft gp.max_indent ; - Format.pp_set_max_boxes ft gp.max_depth ; - Format.pp_set_ellipsis_text ft gp.ellipsis - -let set_dflt_gp ft = set_gp ft dflt_gp - -let get_gp ft = - { margin = Format.pp_get_margin ft (); - max_indent = Format.pp_get_max_indent ft (); - max_depth = Format.pp_get_max_boxes ft (); - ellipsis = Format.pp_get_ellipsis_text ft () } - -(* with_fp : 'a pp_formatter_params -> Format.formatter - * returns of formatter for given formatter functions *) - -let with_fp chan out_function flush_function = - let ft = Format.make_formatter out_function flush_function in - Format.pp_set_formatter_out_channel ft chan; - ft - -(* Output on a channel ch *) - -let with_output_to ch = - let ft = with_fp ch (output ch) (fun () -> flush ch) in - set_gp ft deep_gp; - ft - -let std_ft = ref Format.std_formatter -let _ = set_dflt_gp !std_ft - -let err_ft = ref Format.err_formatter -let _ = set_gp !err_ft deep_gp - -let deep_ft = ref (with_output_to stdout) -let _ = set_gp !deep_ft deep_gp - -(* For parametrization through vernacular *) -let default = Format.pp_get_max_boxes !std_ft () -let default_margin = Format.pp_get_margin !std_ft () - -let get_depth_boxes () = Some (Format.pp_get_max_boxes !std_ft ()) -let set_depth_boxes v = - Format.pp_set_max_boxes !std_ft (match v with None -> default | Some v -> v) - -let get_margin () = Some (Format.pp_get_margin !std_ft ()) -let set_margin v = - let v = match v with None -> default_margin | Some v -> v in - Format.pp_set_margin Format.str_formatter v; - Format.pp_set_margin !std_ft v; - Format.pp_set_margin !deep_ft v; - (* Heuristic, based on usage: the column on the right of max_indent - column is 20% of width, capped to 30 characters *) - let m = max (64 * v / 100) (v-30) in - Format.pp_set_max_indent Format.str_formatter m; - Format.pp_set_max_indent !std_ft m; - Format.pp_set_max_indent !deep_ft m diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml deleted file mode 100644 index aa47c5167..000000000 --- a/lib/ppstyle.ml +++ /dev/null @@ -1,73 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -module String = CString - -type t = string -(** We use the concatenated string, with dots separating each string. We - forbid the use of dots in the strings. *) - -let tags : Terminal.style option String.Map.t ref = ref String.Map.empty - -let make ?style tag = - let check s = if String.contains s '.' then invalid_arg "Ppstyle.make" in - let () = List.iter check tag in - let name = String.concat "." tag in - let () = assert (not (String.Map.mem name !tags)) in - let () = tags := String.Map.add name style !tags in - name - -let repr t = String.split '.' t - -let get_style tag = - try String.Map.find tag !tags with Not_found -> assert false - -let set_style tag st = - try tags := String.Map.update tag st !tags with Not_found -> assert false - -let clear_styles () = - tags := String.Map.map (fun _ -> None) !tags - -let dump () = String.Map.bindings !tags - -let parse_config s = - let styles = Terminal.parse s in - let set accu (name, st) = - try String.Map.update name (Some st) accu with Not_found -> accu - in - tags := List.fold_left set !tags styles - -let tag = Pp.Tag.create "ppstyle" - -(** Default tag is to reset everything *) -let default = Terminal.({ - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; -}) - -let empty = Terminal.make () - -let error_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () in - make ~style ["message"; "error"] - -let warning_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`YELLOW () in - make ~style ["message"; "warning"] - -let debug_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () in - make ~style ["message"; "debug"] - -let pp_tag t = match Pp.Tag.prj t tag with -| None -> "" -| Some key -> key diff --git a/lib/ppstyle.mli b/lib/ppstyle.mli deleted file mode 100644 index d9fd75765..000000000 --- a/lib/ppstyle.mli +++ /dev/null @@ -1,63 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** Highlighting of printers. Used for pretty-printing terms that should be - displayed on a color-capable terminal. *) - -(** {5 Style tags} *) - -type t = string - -(** Style tags *) - -val make : ?style:Terminal.style -> string list -> t -(** Create a new tag with the given name. Each name must be unique. The optional - style is taken as the default one. *) - -val repr : t -> string list -(** Gives back the original name of the style tag where each string has been - concatenated and separated with a dot. *) - -val tag : t Pp.Tag.key -(** An annotation for styles *) - -(** {5 Manipulating global styles} *) - -val get_style : t -> Terminal.style option -(** Get the style associated to a tag. *) - -val set_style : t -> Terminal.style option -> unit -(** Set a style associated to a tag. *) - -val clear_styles : unit -> unit -(** Clear all styles. *) - -val parse_config : string -> unit -(** Add all styles from the given string as parsed by {!Terminal.parse}. - Unregistered tags are ignored. *) - -val dump : unit -> (t * Terminal.style option) list -(** Recover the list of known tags together with their current style. *) - -(** {5 Color output} *) - -val pp_tag : Pp.tag_handler -(** Returns the name of a style tag that is understandable by the formatters - that have been inititialized through {!init_color_output}. To be used with - {!Pp.pp_with}. *) - -(** {5 Tags} *) - -val error_tag : t -(** Tag used by the {!Pp.msg_error} function. *) - -val warning_tag : t -(** Tag used by the {!Pp.msg_warning} function. *) - -val debug_tag : t -(** Tag used by the {!Pp.msg_debug} function. *) diff --git a/lib/system.ml b/lib/system.ml index 1817aed1f..e0e2c829d 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -131,7 +131,7 @@ let find_file_in_path ?(warn=true) paths filename = let root = Filename.dirname filename in root, filename else - CErrors.errorlabstrm "System.find_file_in_path" + CErrors.user_err ~hdr:"System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename)) else (* the name is considered to be the transcription as a relative @@ -139,7 +139,7 @@ let find_file_in_path ?(warn=true) paths filename = to be locate respecting case *) try where_in_path ~warn paths filename with Not_found -> - CErrors.errorlabstrm "System.find_file_in_path" + CErrors.user_err ~hdr:"System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ str "on loadpath")) @@ -162,7 +162,7 @@ let is_in_system_path filename = let open_trapping_failure name = try open_out_bin name with e when CErrors.noncritical e -> - CErrors.errorlabstrm "System.open" (str "Can't open " ++ str name) + CErrors.user_err ~hdr:"System.open" (str "Can't open " ++ str name) let warn_cannot_remove_file = CWarnings.create ~name:"cannot-remove-file" ~category:"filesystem" @@ -174,7 +174,7 @@ let try_remove filename = warn_cannot_remove_file filename let error_corrupted file s = - CErrors.errorlabstrm "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") + CErrors.user_err ~hdr:"System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") let input_binary_int f ch = try input_binary_int ch @@ -251,7 +251,7 @@ let extern_state magic filename val_0 = let () = try_remove filename in iraise reraise with Sys_error s -> - CErrors.errorlabstrm "System.extern_state" (str "System error: " ++ str s) + CErrors.user_err ~hdr:"System.extern_state" (str "System error: " ++ str s) let intern_state magic filename = try @@ -260,12 +260,12 @@ let intern_state magic filename = close_in channel; v with Sys_error s -> - CErrors.errorlabstrm "System.intern_state" (str "System error: " ++ str s) + CErrors.user_err ~hdr:"System.intern_state" (str "System error: " ++ str s) let with_magic_number_check f a = try f a with Bad_magic_number {filename=fname;actual=actual;expected=expected} -> - CErrors.errorlabstrm "with_magic_number_check" + CErrors.user_err ~hdr:"with_magic_number_check" (str"File " ++ str fname ++ strbrk" has bad magic number " ++ int actual ++ str" (expected " ++ int expected ++ str")." ++ spc () ++ diff --git a/lib/unicode.ml b/lib/unicode.ml index ced5e258c..959ccaf73 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -124,27 +124,11 @@ exception End_of_input let utf8_of_unicode n = if n < 128 then String.make 1 (Char.chr n) - else if n < 2048 then - let s = String.make 2 (Char.chr (128 + n mod 64)) in - begin - s.[0] <- Char.chr (192 + n / 64); - s - end - else if n < 65536 then - let s = String.make 3 (Char.chr (128 + n mod 64)) in - begin - s.[1] <- Char.chr (128 + (n / 64) mod 64); - s.[0] <- Char.chr (224 + n / 4096); - s - end else - let s = String.make 4 (Char.chr (128 + n mod 64)) in - begin - s.[2] <- Char.chr (128 + (n / 64) mod 64); - s.[1] <- Char.chr (128 + (n / 4096) mod 64); - s.[0] <- Char.chr (240 + n / 262144); - s - end + let (m,s) = if n < 2048 then (2,192) else if n < 65536 then (3,224) else (4,240) in + String.init m (fun i -> + let j = (n lsr ((m - 1 - i) * 6)) land 63 in + Char.chr (j + if i = 0 then s else 128)) (* If [s] is some UTF-8 encoded string and [i] is a position of some UTF-8 character within [s] diff --git a/lib/unicodetable.ml b/lib/unicodetable.ml index f4e978d69..b607058c6 100644 --- a/lib/unicodetable.ml +++ b/lib/unicodetable.ml @@ -1,5 +1,4 @@ - -(** Unicode tables generated from Camomile. *) +(** Unicode tables generated using UUCD. *) (* Letter, Uppercase *) let lu = [ @@ -139,12 +138,25 @@ let lu = [ (0x0022E,0x0022E); (0x00230,0x00230); (0x00232,0x00232); + (0x0023A,0x0023B); + (0x0023D,0x0023E); + (0x00241,0x00241); + (0x00243,0x00246); + (0x00248,0x00248); + (0x0024A,0x0024A); + (0x0024C,0x0024C); + (0x0024E,0x0024E); + (0x00370,0x00370); + (0x00372,0x00372); + (0x00376,0x00376); + (0x0037F,0x0037F); (0x00386,0x00386); (0x00388,0x0038A); (0x0038C,0x0038C); (0x0038E,0x0038F); (0x00391,0x003A1); (0x003A3,0x003AB); + (0x003CF,0x003CF); (0x003D2,0x003D4); (0x003D8,0x003D8); (0x003DA,0x003DA); @@ -159,7 +171,9 @@ let lu = [ (0x003EC,0x003EC); (0x003EE,0x003EE); (0x003F4,0x003F4); - (0x00400,0x0042F); + (0x003F7,0x003F7); + (0x003F9,0x003FA); + (0x003FD,0x0042F); (0x00460,0x00460); (0x00462,0x00462); (0x00464,0x00464); @@ -230,7 +244,11 @@ let lu = [ (0x004F0,0x004F0); (0x004F2,0x004F2); (0x004F4,0x004F4); + (0x004F6,0x004F6); (0x004F8,0x004F8); + (0x004FA,0x004FA); + (0x004FC,0x004FC); + (0x004FE,0x004FE); (0x00500,0x00500); (0x00502,0x00502); (0x00504,0x00504); @@ -239,8 +257,27 @@ let lu = [ (0x0050A,0x0050A); (0x0050C,0x0050C); (0x0050E,0x0050E); + (0x00510,0x00510); + (0x00512,0x00512); + (0x00514,0x00514); + (0x00516,0x00516); + (0x00518,0x00518); + (0x0051A,0x0051A); + (0x0051C,0x0051C); + (0x0051E,0x0051E); + (0x00520,0x00520); + (0x00522,0x00522); + (0x00524,0x00524); + (0x00526,0x00526); + (0x00528,0x00528); + (0x0052A,0x0052A); + (0x0052C,0x0052C); + (0x0052E,0x0052E); (0x00531,0x00556); (0x010A0,0x010C5); + (0x010C7,0x010C7); + (0x010CD,0x010CD); + (0x013A0,0x013F5); (0x01E00,0x01E00); (0x01E02,0x01E02); (0x01E04,0x01E04); @@ -316,6 +353,7 @@ let lu = [ (0x01E90,0x01E90); (0x01E92,0x01E92); (0x01E94,0x01E94); + (0x01E9E,0x01E9E); (0x01EA0,0x01EA0); (0x01EA2,0x01EA2); (0x01EA4,0x01EA4); @@ -361,6 +399,9 @@ let lu = [ (0x01EF4,0x01EF4); (0x01EF6,0x01EF6); (0x01EF8,0x01EF8); + (0x01EFA,0x01EFA); + (0x01EFC,0x01EFC); + (0x01EFE,0x01EFE); (0x01F08,0x01F0F); (0x01F18,0x01F1D); (0x01F28,0x01F2F); @@ -386,12 +427,176 @@ let lu = [ (0x02126,0x02126); (0x02128,0x02128); (0x0212A,0x0212D); - (0x02130,0x02131); - (0x02133,0x02133); + (0x02130,0x02133); (0x0213E,0x0213F); (0x02145,0x02145); + (0x02183,0x02183); + (0x02C00,0x02C2E); + (0x02C60,0x02C60); + (0x02C62,0x02C64); + (0x02C67,0x02C67); + (0x02C69,0x02C69); + (0x02C6B,0x02C6B); + (0x02C6D,0x02C70); + (0x02C72,0x02C72); + (0x02C75,0x02C75); + (0x02C7E,0x02C80); + (0x02C82,0x02C82); + (0x02C84,0x02C84); + (0x02C86,0x02C86); + (0x02C88,0x02C88); + (0x02C8A,0x02C8A); + (0x02C8C,0x02C8C); + (0x02C8E,0x02C8E); + (0x02C90,0x02C90); + (0x02C92,0x02C92); + (0x02C94,0x02C94); + (0x02C96,0x02C96); + (0x02C98,0x02C98); + (0x02C9A,0x02C9A); + (0x02C9C,0x02C9C); + (0x02C9E,0x02C9E); + (0x02CA0,0x02CA0); + (0x02CA2,0x02CA2); + (0x02CA4,0x02CA4); + (0x02CA6,0x02CA6); + (0x02CA8,0x02CA8); + (0x02CAA,0x02CAA); + (0x02CAC,0x02CAC); + (0x02CAE,0x02CAE); + (0x02CB0,0x02CB0); + (0x02CB2,0x02CB2); + (0x02CB4,0x02CB4); + (0x02CB6,0x02CB6); + (0x02CB8,0x02CB8); + (0x02CBA,0x02CBA); + (0x02CBC,0x02CBC); + (0x02CBE,0x02CBE); + (0x02CC0,0x02CC0); + (0x02CC2,0x02CC2); + (0x02CC4,0x02CC4); + (0x02CC6,0x02CC6); + (0x02CC8,0x02CC8); + (0x02CCA,0x02CCA); + (0x02CCC,0x02CCC); + (0x02CCE,0x02CCE); + (0x02CD0,0x02CD0); + (0x02CD2,0x02CD2); + (0x02CD4,0x02CD4); + (0x02CD6,0x02CD6); + (0x02CD8,0x02CD8); + (0x02CDA,0x02CDA); + (0x02CDC,0x02CDC); + (0x02CDE,0x02CDE); + (0x02CE0,0x02CE0); + (0x02CE2,0x02CE2); + (0x02CEB,0x02CEB); + (0x02CED,0x02CED); + (0x02CF2,0x02CF2); + (0x0A640,0x0A640); + (0x0A642,0x0A642); + (0x0A644,0x0A644); + (0x0A646,0x0A646); + (0x0A648,0x0A648); + (0x0A64A,0x0A64A); + (0x0A64C,0x0A64C); + (0x0A64E,0x0A64E); + (0x0A650,0x0A650); + (0x0A652,0x0A652); + (0x0A654,0x0A654); + (0x0A656,0x0A656); + (0x0A658,0x0A658); + (0x0A65A,0x0A65A); + (0x0A65C,0x0A65C); + (0x0A65E,0x0A65E); + (0x0A660,0x0A660); + (0x0A662,0x0A662); + (0x0A664,0x0A664); + (0x0A666,0x0A666); + (0x0A668,0x0A668); + (0x0A66A,0x0A66A); + (0x0A66C,0x0A66C); + (0x0A680,0x0A680); + (0x0A682,0x0A682); + (0x0A684,0x0A684); + (0x0A686,0x0A686); + (0x0A688,0x0A688); + (0x0A68A,0x0A68A); + (0x0A68C,0x0A68C); + (0x0A68E,0x0A68E); + (0x0A690,0x0A690); + (0x0A692,0x0A692); + (0x0A694,0x0A694); + (0x0A696,0x0A696); + (0x0A698,0x0A698); + (0x0A69A,0x0A69A); + (0x0A722,0x0A722); + (0x0A724,0x0A724); + (0x0A726,0x0A726); + (0x0A728,0x0A728); + (0x0A72A,0x0A72A); + (0x0A72C,0x0A72C); + (0x0A72E,0x0A72E); + (0x0A732,0x0A732); + (0x0A734,0x0A734); + (0x0A736,0x0A736); + (0x0A738,0x0A738); + (0x0A73A,0x0A73A); + (0x0A73C,0x0A73C); + (0x0A73E,0x0A73E); + (0x0A740,0x0A740); + (0x0A742,0x0A742); + (0x0A744,0x0A744); + (0x0A746,0x0A746); + (0x0A748,0x0A748); + (0x0A74A,0x0A74A); + (0x0A74C,0x0A74C); + (0x0A74E,0x0A74E); + (0x0A750,0x0A750); + (0x0A752,0x0A752); + (0x0A754,0x0A754); + (0x0A756,0x0A756); + (0x0A758,0x0A758); + (0x0A75A,0x0A75A); + (0x0A75C,0x0A75C); + (0x0A75E,0x0A75E); + (0x0A760,0x0A760); + (0x0A762,0x0A762); + (0x0A764,0x0A764); + (0x0A766,0x0A766); + (0x0A768,0x0A768); + (0x0A76A,0x0A76A); + (0x0A76C,0x0A76C); + (0x0A76E,0x0A76E); + (0x0A779,0x0A779); + (0x0A77B,0x0A77B); + (0x0A77D,0x0A77E); + (0x0A780,0x0A780); + (0x0A782,0x0A782); + (0x0A784,0x0A784); + (0x0A786,0x0A786); + (0x0A78B,0x0A78B); + (0x0A78D,0x0A78D); + (0x0A790,0x0A790); + (0x0A792,0x0A792); + (0x0A796,0x0A796); + (0x0A798,0x0A798); + (0x0A79A,0x0A79A); + (0x0A79C,0x0A79C); + (0x0A79E,0x0A79E); + (0x0A7A0,0x0A7A0); + (0x0A7A2,0x0A7A2); + (0x0A7A4,0x0A7A4); + (0x0A7A6,0x0A7A6); + (0x0A7A8,0x0A7A8); + (0x0A7AA,0x0A7AE); + (0x0A7B0,0x0A7B4); + (0x0A7B6,0x0A7B6); (0x0FF21,0x0FF3A); - (0x10400,0x10425); + (0x10400,0x10427); + (0x104B0,0x104D3); + (0x10C80,0x10CB2); + (0x118A0,0x118BF); (0x1D400,0x1D419); (0x1D434,0x1D44D); (0x1D468,0x1D481); @@ -421,14 +626,13 @@ let lu = [ (0x1D6E2,0x1D6FA); (0x1D71C,0x1D734); (0x1D756,0x1D76E); - (0x1D790,0x1D7A8) + (0x1D790,0x1D7A8); + (0x1D7CA,0x1D7CA) ] (* Letter, Lowercase *) let ll = [ (0x00061,0x0007A); - (0x000AA,0x000AA); (0x000B5,0x000B5); - (0x000BA,0x000BA); (0x000DF,0x000F6); (0x000F8,0x000FF); (0x00101,0x00101); @@ -554,6 +758,7 @@ let ll = [ (0x0021B,0x0021B); (0x0021D,0x0021D); (0x0021F,0x0021F); + (0x00221,0x00221); (0x00223,0x00223); (0x00225,0x00225); (0x00227,0x00227); @@ -562,8 +767,20 @@ let ll = [ (0x0022D,0x0022D); (0x0022F,0x0022F); (0x00231,0x00231); - (0x00233,0x00233); - (0x00250,0x002AD); + (0x00233,0x00239); + (0x0023C,0x0023C); + (0x0023F,0x00240); + (0x00242,0x00242); + (0x00247,0x00247); + (0x00249,0x00249); + (0x0024B,0x0024B); + (0x0024D,0x0024D); + (0x0024F,0x00293); + (0x00295,0x002AF); + (0x00371,0x00371); + (0x00373,0x00373); + (0x00377,0x00377); + (0x0037B,0x0037D); (0x00390,0x00390); (0x003AC,0x003CE); (0x003D0,0x003D1); @@ -581,6 +798,8 @@ let ll = [ (0x003ED,0x003ED); (0x003EF,0x003F3); (0x003F5,0x003F5); + (0x003F8,0x003F8); + (0x003FB,0x003FC); (0x00430,0x0045F); (0x00461,0x00461); (0x00463,0x00463); @@ -632,7 +851,7 @@ let ll = [ (0x004C8,0x004C8); (0x004CA,0x004CA); (0x004CC,0x004CC); - (0x004CE,0x004CE); + (0x004CE,0x004CF); (0x004D1,0x004D1); (0x004D3,0x004D3); (0x004D5,0x004D5); @@ -652,7 +871,11 @@ let ll = [ (0x004F1,0x004F1); (0x004F3,0x004F3); (0x004F5,0x004F5); + (0x004F7,0x004F7); (0x004F9,0x004F9); + (0x004FB,0x004FB); + (0x004FD,0x004FD); + (0x004FF,0x004FF); (0x00501,0x00501); (0x00503,0x00503); (0x00505,0x00505); @@ -661,7 +884,28 @@ let ll = [ (0x0050B,0x0050B); (0x0050D,0x0050D); (0x0050F,0x0050F); + (0x00511,0x00511); + (0x00513,0x00513); + (0x00515,0x00515); + (0x00517,0x00517); + (0x00519,0x00519); + (0x0051B,0x0051B); + (0x0051D,0x0051D); + (0x0051F,0x0051F); + (0x00521,0x00521); + (0x00523,0x00523); + (0x00525,0x00525); + (0x00527,0x00527); + (0x00529,0x00529); + (0x0052B,0x0052B); + (0x0052D,0x0052D); + (0x0052F,0x0052F); (0x00561,0x00587); + (0x013F8,0x013FD); + (0x01C80,0x01C88); + (0x01D00,0x01D2B); + (0x01D6B,0x01D77); + (0x01D79,0x01D9A); (0x01E01,0x01E01); (0x01E03,0x01E03); (0x01E05,0x01E05); @@ -736,7 +980,8 @@ let ll = [ (0x01E8F,0x01E8F); (0x01E91,0x01E91); (0x01E93,0x01E93); - (0x01E95,0x01E9B); + (0x01E95,0x01E9D); + (0x01E9F,0x01E9F); (0x01EA1,0x01EA1); (0x01EA3,0x01EA3); (0x01EA5,0x01EA5); @@ -782,7 +1027,9 @@ let ll = [ (0x01EF5,0x01EF5); (0x01EF7,0x01EF7); (0x01EF9,0x01EF9); - (0x01F00,0x01F07); + (0x01EFB,0x01EFB); + (0x01EFD,0x01EFD); + (0x01EFF,0x01F07); (0x01F10,0x01F15); (0x01F20,0x01F27); (0x01F30,0x01F37); @@ -803,28 +1050,198 @@ let ll = [ (0x01FE0,0x01FE7); (0x01FF2,0x01FF4); (0x01FF6,0x01FF7); - (0x02071,0x02071); - (0x0207F,0x0207F); (0x0210A,0x0210A); (0x0210E,0x0210F); (0x02113,0x02113); (0x0212F,0x0212F); (0x02134,0x02134); (0x02139,0x02139); - (0x0213D,0x0213D); + (0x0213C,0x0213D); (0x02146,0x02149); + (0x0214E,0x0214E); + (0x02184,0x02184); + (0x02C30,0x02C5E); + (0x02C61,0x02C61); + (0x02C65,0x02C66); + (0x02C68,0x02C68); + (0x02C6A,0x02C6A); + (0x02C6C,0x02C6C); + (0x02C71,0x02C71); + (0x02C73,0x02C74); + (0x02C76,0x02C7B); + (0x02C81,0x02C81); + (0x02C83,0x02C83); + (0x02C85,0x02C85); + (0x02C87,0x02C87); + (0x02C89,0x02C89); + (0x02C8B,0x02C8B); + (0x02C8D,0x02C8D); + (0x02C8F,0x02C8F); + (0x02C91,0x02C91); + (0x02C93,0x02C93); + (0x02C95,0x02C95); + (0x02C97,0x02C97); + (0x02C99,0x02C99); + (0x02C9B,0x02C9B); + (0x02C9D,0x02C9D); + (0x02C9F,0x02C9F); + (0x02CA1,0x02CA1); + (0x02CA3,0x02CA3); + (0x02CA5,0x02CA5); + (0x02CA7,0x02CA7); + (0x02CA9,0x02CA9); + (0x02CAB,0x02CAB); + (0x02CAD,0x02CAD); + (0x02CAF,0x02CAF); + (0x02CB1,0x02CB1); + (0x02CB3,0x02CB3); + (0x02CB5,0x02CB5); + (0x02CB7,0x02CB7); + (0x02CB9,0x02CB9); + (0x02CBB,0x02CBB); + (0x02CBD,0x02CBD); + (0x02CBF,0x02CBF); + (0x02CC1,0x02CC1); + (0x02CC3,0x02CC3); + (0x02CC5,0x02CC5); + (0x02CC7,0x02CC7); + (0x02CC9,0x02CC9); + (0x02CCB,0x02CCB); + (0x02CCD,0x02CCD); + (0x02CCF,0x02CCF); + (0x02CD1,0x02CD1); + (0x02CD3,0x02CD3); + (0x02CD5,0x02CD5); + (0x02CD7,0x02CD7); + (0x02CD9,0x02CD9); + (0x02CDB,0x02CDB); + (0x02CDD,0x02CDD); + (0x02CDF,0x02CDF); + (0x02CE1,0x02CE1); + (0x02CE3,0x02CE4); + (0x02CEC,0x02CEC); + (0x02CEE,0x02CEE); + (0x02CF3,0x02CF3); + (0x02D00,0x02D25); + (0x02D27,0x02D27); + (0x02D2D,0x02D2D); + (0x0A641,0x0A641); + (0x0A643,0x0A643); + (0x0A645,0x0A645); + (0x0A647,0x0A647); + (0x0A649,0x0A649); + (0x0A64B,0x0A64B); + (0x0A64D,0x0A64D); + (0x0A64F,0x0A64F); + (0x0A651,0x0A651); + (0x0A653,0x0A653); + (0x0A655,0x0A655); + (0x0A657,0x0A657); + (0x0A659,0x0A659); + (0x0A65B,0x0A65B); + (0x0A65D,0x0A65D); + (0x0A65F,0x0A65F); + (0x0A661,0x0A661); + (0x0A663,0x0A663); + (0x0A665,0x0A665); + (0x0A667,0x0A667); + (0x0A669,0x0A669); + (0x0A66B,0x0A66B); + (0x0A66D,0x0A66D); + (0x0A681,0x0A681); + (0x0A683,0x0A683); + (0x0A685,0x0A685); + (0x0A687,0x0A687); + (0x0A689,0x0A689); + (0x0A68B,0x0A68B); + (0x0A68D,0x0A68D); + (0x0A68F,0x0A68F); + (0x0A691,0x0A691); + (0x0A693,0x0A693); + (0x0A695,0x0A695); + (0x0A697,0x0A697); + (0x0A699,0x0A699); + (0x0A69B,0x0A69B); + (0x0A723,0x0A723); + (0x0A725,0x0A725); + (0x0A727,0x0A727); + (0x0A729,0x0A729); + (0x0A72B,0x0A72B); + (0x0A72D,0x0A72D); + (0x0A72F,0x0A731); + (0x0A733,0x0A733); + (0x0A735,0x0A735); + (0x0A737,0x0A737); + (0x0A739,0x0A739); + (0x0A73B,0x0A73B); + (0x0A73D,0x0A73D); + (0x0A73F,0x0A73F); + (0x0A741,0x0A741); + (0x0A743,0x0A743); + (0x0A745,0x0A745); + (0x0A747,0x0A747); + (0x0A749,0x0A749); + (0x0A74B,0x0A74B); + (0x0A74D,0x0A74D); + (0x0A74F,0x0A74F); + (0x0A751,0x0A751); + (0x0A753,0x0A753); + (0x0A755,0x0A755); + (0x0A757,0x0A757); + (0x0A759,0x0A759); + (0x0A75B,0x0A75B); + (0x0A75D,0x0A75D); + (0x0A75F,0x0A75F); + (0x0A761,0x0A761); + (0x0A763,0x0A763); + (0x0A765,0x0A765); + (0x0A767,0x0A767); + (0x0A769,0x0A769); + (0x0A76B,0x0A76B); + (0x0A76D,0x0A76D); + (0x0A76F,0x0A76F); + (0x0A771,0x0A778); + (0x0A77A,0x0A77A); + (0x0A77C,0x0A77C); + (0x0A77F,0x0A77F); + (0x0A781,0x0A781); + (0x0A783,0x0A783); + (0x0A785,0x0A785); + (0x0A787,0x0A787); + (0x0A78C,0x0A78C); + (0x0A78E,0x0A78E); + (0x0A791,0x0A791); + (0x0A793,0x0A795); + (0x0A797,0x0A797); + (0x0A799,0x0A799); + (0x0A79B,0x0A79B); + (0x0A79D,0x0A79D); + (0x0A79F,0x0A79F); + (0x0A7A1,0x0A7A1); + (0x0A7A3,0x0A7A3); + (0x0A7A5,0x0A7A5); + (0x0A7A7,0x0A7A7); + (0x0A7A9,0x0A7A9); + (0x0A7B5,0x0A7B5); + (0x0A7B7,0x0A7B7); + (0x0A7FA,0x0A7FA); + (0x0AB30,0x0AB5A); + (0x0AB60,0x0AB65); + (0x0AB70,0x0ABBF); (0x0FB00,0x0FB06); (0x0FB13,0x0FB17); (0x0FF41,0x0FF5A); - (0x10428,0x1044D); + (0x10428,0x1044F); + (0x104D8,0x104FB); + (0x10CC0,0x10CF2); + (0x118C0,0x118DF); (0x1D41A,0x1D433); (0x1D44E,0x1D454); (0x1D456,0x1D467); (0x1D482,0x1D49B); (0x1D4B6,0x1D4B9); (0x1D4BB,0x1D4BB); - (0x1D4BD,0x1D4C0); - (0x1D4C2,0x1D4C3); + (0x1D4BD,0x1D4C3); (0x1D4C5,0x1D4CF); (0x1D4EA,0x1D503); (0x1D51E,0x1D537); @@ -834,7 +1251,7 @@ let ll = [ (0x1D5EE,0x1D607); (0x1D622,0x1D63B); (0x1D656,0x1D66F); - (0x1D68A,0x1D6A3); + (0x1D68A,0x1D6A5); (0x1D6C2,0x1D6DA); (0x1D6DC,0x1D6E1); (0x1D6FC,0x1D714); @@ -844,7 +1261,8 @@ let ll = [ (0x1D770,0x1D788); (0x1D78A,0x1D78F); (0x1D7AA,0x1D7C2); - (0x1D7C4,0x1D7C9) + (0x1D7C4,0x1D7C9); + (0x1D7CB,0x1D7CB) ] (* Letter, Titlecase *) let lt = [ @@ -856,21 +1274,19 @@ let lt = [ (0x01F98,0x01F9F); (0x01FA8,0x01FAF); (0x01FBC,0x01FBC); - (0x01FCC,0x01FCC); - (0x01FFC,0x01FFC) + (0x01FCC,0x01FCC) ] (* Mark, Non-Spacing *) let mn = [ - (0x00300,0x0034F); - (0x00360,0x0036F); - (0x00483,0x00486); - (0x00591,0x005A1); - (0x005A3,0x005B9); - (0x005BB,0x005BD); + (0x00300,0x0036F); + (0x00483,0x00487); + (0x00591,0x005BD); (0x005BF,0x005BF); (0x005C1,0x005C2); - (0x005C4,0x005C4); - (0x0064B,0x00655); + (0x005C4,0x005C5); + (0x005C7,0x005C7); + (0x00610,0x0061A); + (0x0064B,0x0065F); (0x00670,0x00670); (0x006D6,0x006DC); (0x006DF,0x006E4); @@ -879,46 +1295,65 @@ let mn = [ (0x00711,0x00711); (0x00730,0x0074A); (0x007A6,0x007B0); - (0x00901,0x00902); + (0x007EB,0x007F3); + (0x00816,0x00819); + (0x0081B,0x00823); + (0x00825,0x00827); + (0x00829,0x0082D); + (0x00859,0x0085B); + (0x008D4,0x008E1); + (0x008E3,0x00902); + (0x0093A,0x0093A); (0x0093C,0x0093C); (0x00941,0x00948); (0x0094D,0x0094D); - (0x00951,0x00954); + (0x00951,0x00957); (0x00962,0x00963); (0x00981,0x00981); (0x009BC,0x009BC); (0x009C1,0x009C4); (0x009CD,0x009CD); (0x009E2,0x009E3); - (0x00A02,0x00A02); + (0x00A01,0x00A02); (0x00A3C,0x00A3C); (0x00A41,0x00A42); (0x00A47,0x00A48); (0x00A4B,0x00A4D); + (0x00A51,0x00A51); (0x00A70,0x00A71); + (0x00A75,0x00A75); (0x00A81,0x00A82); (0x00ABC,0x00ABC); (0x00AC1,0x00AC5); (0x00AC7,0x00AC8); (0x00ACD,0x00ACD); + (0x00AE2,0x00AE3); (0x00B01,0x00B01); (0x00B3C,0x00B3C); (0x00B3F,0x00B3F); - (0x00B41,0x00B43); + (0x00B41,0x00B44); (0x00B4D,0x00B4D); (0x00B56,0x00B56); + (0x00B62,0x00B63); (0x00B82,0x00B82); (0x00BC0,0x00BC0); (0x00BCD,0x00BCD); + (0x00C00,0x00C00); (0x00C3E,0x00C40); (0x00C46,0x00C48); (0x00C4A,0x00C4D); (0x00C55,0x00C56); + (0x00C62,0x00C63); + (0x00C81,0x00C81); + (0x00CBC,0x00CBC); (0x00CBF,0x00CBF); (0x00CC6,0x00CC6); (0x00CCC,0x00CCD); - (0x00D41,0x00D43); + (0x00CE2,0x00CE3); + (0x00D01,0x00D01); + (0x00D41,0x00D44); (0x00D4D,0x00D4D); + (0x00D62,0x00D63); (0x00DCA,0x00DCA); (0x00DD2,0x00DD4); (0x00DD6,0x00DD6); @@ -936,46 +1371,211 @@ let mn = [ (0x00F71,0x00F7E); (0x00F80,0x00F84); (0x00F86,0x00F87); - (0x00F90,0x00F97); + (0x00F8D,0x00F97); (0x00F99,0x00FBC); (0x00FC6,0x00FC6); (0x0102D,0x01030); - (0x01032,0x01032); - (0x01036,0x01037); - (0x01039,0x01039); + (0x01032,0x01037); + (0x01039,0x0103A); + (0x0103D,0x0103E); (0x01058,0x01059); + (0x0105E,0x01060); + (0x01071,0x01074); + (0x01082,0x01082); + (0x01085,0x01086); + (0x0108D,0x0108D); + (0x0109D,0x0109D); + (0x0135D,0x0135F); (0x01712,0x01714); (0x01732,0x01734); (0x01752,0x01753); (0x01772,0x01773); + (0x017B4,0x017B5); (0x017B7,0x017BD); (0x017C6,0x017C6); (0x017C9,0x017D3); + (0x017DD,0x017DD); (0x0180B,0x0180D); + (0x01885,0x01886); (0x018A9,0x018A9); + (0x01920,0x01922); + (0x01927,0x01928); + (0x01932,0x01932); + (0x01939,0x0193B); + (0x01A17,0x01A18); + (0x01A1B,0x01A1B); + (0x01A56,0x01A56); + (0x01A58,0x01A5E); + (0x01A60,0x01A60); + (0x01A62,0x01A62); + (0x01A65,0x01A6C); + (0x01A73,0x01A7C); + (0x01A7F,0x01A7F); + (0x01AB0,0x01ABD); + (0x01B00,0x01B03); + (0x01B34,0x01B34); + (0x01B36,0x01B3A); + (0x01B3C,0x01B3C); + (0x01B42,0x01B42); + (0x01B6B,0x01B73); + (0x01B80,0x01B81); + (0x01BA2,0x01BA5); + (0x01BA8,0x01BA9); + (0x01BAB,0x01BAD); + (0x01BE6,0x01BE6); + (0x01BE8,0x01BE9); + (0x01BED,0x01BED); + (0x01BEF,0x01BF1); + (0x01C2C,0x01C33); + (0x01C36,0x01C37); + (0x01CD0,0x01CD2); + (0x01CD4,0x01CE0); + (0x01CE2,0x01CE8); + (0x01CED,0x01CED); + (0x01CF4,0x01CF4); + (0x01CF8,0x01CF9); + (0x01DC0,0x01DF5); + (0x01DFB,0x01DFF); (0x020D0,0x020DC); (0x020E1,0x020E1); - (0x020E5,0x020EA); - (0x0302A,0x0302F); + (0x020E5,0x020F0); + (0x02CEF,0x02CF1); + (0x02D7F,0x02D7F); + (0x02DE0,0x02DFF); + (0x0302A,0x0302D); (0x03099,0x0309A); + (0x0A66F,0x0A66F); + (0x0A674,0x0A67D); + (0x0A69E,0x0A69F); + (0x0A6F0,0x0A6F1); + (0x0A802,0x0A802); + (0x0A806,0x0A806); + (0x0A80B,0x0A80B); + (0x0A825,0x0A826); + (0x0A8C4,0x0A8C5); + (0x0A8E0,0x0A8F1); + (0x0A926,0x0A92D); + (0x0A947,0x0A951); + (0x0A980,0x0A982); + (0x0A9B3,0x0A9B3); + (0x0A9B6,0x0A9B9); + (0x0A9BC,0x0A9BC); + (0x0A9E5,0x0A9E5); + (0x0AA29,0x0AA2E); + (0x0AA31,0x0AA32); + (0x0AA35,0x0AA36); + (0x0AA43,0x0AA43); + (0x0AA4C,0x0AA4C); + (0x0AA7C,0x0AA7C); + (0x0AAB0,0x0AAB0); + (0x0AAB2,0x0AAB4); + (0x0AAB7,0x0AAB8); + (0x0AABE,0x0AABF); + (0x0AAC1,0x0AAC1); + (0x0AAEC,0x0AAED); + (0x0AAF6,0x0AAF6); + (0x0ABE5,0x0ABE5); + (0x0ABE8,0x0ABE8); + (0x0ABED,0x0ABED); (0x0FB1E,0x0FB1E); (0x0FE00,0x0FE0F); - (0x0FE20,0x0FE23); + (0x0FE20,0x0FE2F); + (0x101FD,0x101FD); + (0x102E0,0x102E0); + (0x10376,0x1037A); + (0x10A01,0x10A03); + (0x10A05,0x10A06); + (0x10A0C,0x10A0F); + (0x10A38,0x10A3A); + (0x10A3F,0x10A3F); + (0x10AE5,0x10AE6); + (0x11001,0x11001); + (0x11038,0x11046); + (0x1107F,0x11081); + (0x110B3,0x110B6); + (0x110B9,0x110BA); + (0x11100,0x11102); + (0x11127,0x1112B); + (0x1112D,0x11134); + (0x11173,0x11173); + (0x11180,0x11181); + (0x111B6,0x111BE); + (0x111CA,0x111CC); + (0x1122F,0x11231); + (0x11234,0x11234); + (0x11236,0x11237); + (0x1123E,0x1123E); + (0x112DF,0x112DF); + (0x112E3,0x112EA); + (0x11300,0x11301); + (0x1133C,0x1133C); + (0x11340,0x11340); + (0x11366,0x1136C); + (0x11370,0x11374); + (0x11438,0x1143F); + (0x11442,0x11444); + (0x11446,0x11446); + (0x114B3,0x114B8); + (0x114BA,0x114BA); + (0x114BF,0x114C0); + (0x114C2,0x114C3); + (0x115B2,0x115B5); + (0x115BC,0x115BD); + (0x115BF,0x115C0); + (0x115DC,0x115DD); + (0x11633,0x1163A); + (0x1163D,0x1163D); + (0x1163F,0x11640); + (0x116AB,0x116AB); + (0x116AD,0x116AD); + (0x116B0,0x116B5); + (0x116B7,0x116B7); + (0x1171D,0x1171F); + (0x11722,0x11725); + (0x11727,0x1172B); + (0x11C30,0x11C36); + (0x11C38,0x11C3D); + (0x11C3F,0x11C3F); + (0x11C92,0x11CA7); + (0x11CAA,0x11CB0); + (0x11CB2,0x11CB3); + (0x11CB5,0x11CB6); + (0x16AF0,0x16AF4); + (0x16B30,0x16B36); + (0x16F8F,0x16F92); + (0x1BC9D,0x1BC9E); (0x1D167,0x1D169); (0x1D17B,0x1D182); (0x1D185,0x1D18B); - (0x1D1AA,0x1D1AD) + (0x1D1AA,0x1D1AD); + (0x1D242,0x1D244); + (0x1DA00,0x1DA36); + (0x1DA3B,0x1DA6C); + (0x1DA75,0x1DA75); + (0x1DA84,0x1DA84); + (0x1DA9B,0x1DA9F); + (0x1DAA1,0x1DAAF); + (0x1E000,0x1E006); + (0x1E008,0x1E018); + (0x1E01B,0x1E021); + (0x1E023,0x1E024); + (0x1E026,0x1E02A); + (0x1E8D0,0x1E8D6); + (0x1E944,0x1E94A) ] (* Mark, Spacing Combining *) let mc = [ (0x00903,0x00903); + (0x0093B,0x0093B); (0x0093E,0x00940); (0x00949,0x0094C); + (0x0094E,0x0094F); (0x00982,0x00983); (0x009BE,0x009C0); (0x009C7,0x009C8); (0x009CB,0x009CC); (0x009D7,0x009D7); + (0x00A03,0x00A03); (0x00A3E,0x00A40); (0x00A83,0x00A83); (0x00ABE,0x00AC0); @@ -1011,20 +1611,119 @@ let mc = [ (0x00DF2,0x00DF3); (0x00F3E,0x00F3F); (0x00F7F,0x00F7F); - (0x0102C,0x0102C); + (0x0102B,0x0102C); (0x01031,0x01031); (0x01038,0x01038); + (0x0103B,0x0103C); (0x01056,0x01057); - (0x017B4,0x017B6); + (0x01062,0x01064); + (0x01067,0x0106D); + (0x01083,0x01084); + (0x01087,0x0108C); + (0x0108F,0x0108F); + (0x0109A,0x0109C); + (0x017B6,0x017B6); (0x017BE,0x017C5); (0x017C7,0x017C8); - (0x1D165,0x1D166); - (0x1D16D,0x1D172) + (0x01923,0x01926); + (0x01929,0x0192B); + (0x01930,0x01931); + (0x01933,0x01938); + (0x01A19,0x01A1A); + (0x01A55,0x01A55); + (0x01A57,0x01A57); + (0x01A61,0x01A61); + (0x01A63,0x01A64); + (0x01A6D,0x01A72); + (0x01B04,0x01B04); + (0x01B35,0x01B35); + (0x01B3B,0x01B3B); + (0x01B3D,0x01B41); + (0x01B43,0x01B44); + (0x01B82,0x01B82); + (0x01BA1,0x01BA1); + (0x01BA6,0x01BA7); + (0x01BAA,0x01BAA); + (0x01BE7,0x01BE7); + (0x01BEA,0x01BEC); + (0x01BEE,0x01BEE); + (0x01BF2,0x01BF3); + (0x01C24,0x01C2B); + (0x01C34,0x01C35); + (0x01CE1,0x01CE1); + (0x01CF2,0x01CF3); + (0x0302E,0x0302F); + (0x0A823,0x0A824); + (0x0A827,0x0A827); + (0x0A880,0x0A881); + (0x0A8B4,0x0A8C3); + (0x0A952,0x0A953); + (0x0A983,0x0A983); + (0x0A9B4,0x0A9B5); + (0x0A9BA,0x0A9BB); + (0x0A9BD,0x0A9C0); + (0x0AA2F,0x0AA30); + (0x0AA33,0x0AA34); + (0x0AA4D,0x0AA4D); + (0x0AA7B,0x0AA7B); + (0x0AA7D,0x0AA7D); + (0x0AAEB,0x0AAEB); + (0x0AAEE,0x0AAEF); + (0x0AAF5,0x0AAF5); + (0x0ABE3,0x0ABE4); + (0x0ABE6,0x0ABE7); + (0x0ABE9,0x0ABEA); + (0x0ABEC,0x0ABEC); + (0x11000,0x11000); + (0x11002,0x11002); + (0x11082,0x11082); + (0x110B0,0x110B2); + (0x110B7,0x110B8); + (0x1112C,0x1112C); + (0x11182,0x11182); + (0x111B3,0x111B5); + (0x111BF,0x111C0); + (0x1122C,0x1122E); + (0x11232,0x11233); + (0x11235,0x11235); + (0x112E0,0x112E2); + (0x11302,0x11303); + (0x1133E,0x1133F); + (0x11341,0x11344); + (0x11347,0x11348); + (0x1134B,0x1134D); + (0x11357,0x11357); + (0x11362,0x11363); + (0x11435,0x11437); + (0x11440,0x11441); + (0x11445,0x11445); + (0x114B0,0x114B2); + (0x114B9,0x114B9); + (0x114BB,0x114BE); + (0x114C1,0x114C1); + (0x115AF,0x115B1); + (0x115B8,0x115BB); + (0x115BE,0x115BE); + (0x11630,0x11632); + (0x1163B,0x1163C); + (0x1163E,0x1163E); + (0x116AC,0x116AC); + (0x116AE,0x116AF); + (0x116B6,0x116B6); + (0x11720,0x11721); + (0x11726,0x11726); + (0x11C2F,0x11C2F); + (0x11C3E,0x11C3E); + (0x11CA9,0x11CA9); + (0x11CB1,0x11CB1); + (0x11CB4,0x11CB4); + (0x16F51,0x16F7E); + (0x1D165,0x1D166) ] (* Mark, Enclosing *) let me = [ (0x00488,0x00489); - (0x006DE,0x006DE); + (0x01ABE,0x01ABE); (0x020DD,0x020E0); (0x020E2,0x020E4) ] @@ -1033,33 +1732,70 @@ let nd = [ (0x00030,0x00039); (0x00660,0x00669); (0x006F0,0x006F9); + (0x007C0,0x007C9); (0x00966,0x0096F); (0x009E6,0x009EF); (0x00A66,0x00A6F); (0x00AE6,0x00AEF); (0x00B66,0x00B6F); - (0x00BE7,0x00BEF); + (0x00BE6,0x00BEF); (0x00C66,0x00C6F); (0x00CE6,0x00CEF); (0x00D66,0x00D6F); + (0x00DE6,0x00DEF); (0x00E50,0x00E59); (0x00ED0,0x00ED9); (0x00F20,0x00F29); (0x01040,0x01049); - (0x01369,0x01371); + (0x01090,0x01099); (0x017E0,0x017E9); (0x01810,0x01819); + (0x01946,0x0194F); + (0x019D0,0x019D9); + (0x01A80,0x01A89); + (0x01A90,0x01A99); + (0x01B50,0x01B59); + (0x01BB0,0x01BB9); + (0x01C40,0x01C49); + (0x01C50,0x01C59); + (0x0A620,0x0A629); + (0x0A8D0,0x0A8D9); + (0x0A900,0x0A909); + (0x0A9D0,0x0A9D9); + (0x0A9F0,0x0A9F9); + (0x0AA50,0x0AA59); + (0x0ABF0,0x0ABF9); (0x0FF10,0x0FF19); + (0x104A0,0x104A9); + (0x11066,0x1106F); + (0x110F0,0x110F9); + (0x11136,0x1113F); + (0x111D0,0x111D9); + (0x112F0,0x112F9); + (0x11450,0x11459); + (0x114D0,0x114D9); + (0x11650,0x11659); + (0x116C0,0x116C9); + (0x11730,0x11739); + (0x118E0,0x118E9); + (0x11C50,0x11C59); + (0x16A60,0x16A69); + (0x16B50,0x16B59); (0x1D7CE,0x1D7FF) ] (* Number, Letter *) let nl = [ (0x016EE,0x016F0); - (0x02160,0x02183); + (0x02160,0x02182); + (0x02185,0x02188); (0x03007,0x03007); (0x03021,0x03029); (0x03038,0x0303A); - (0x1034A,0x1034A) + (0x0A6E6,0x0A6EF); + (0x10140,0x10174); + (0x10341,0x10341); + (0x1034A,0x1034A); + (0x103D1,0x103D5) ] (* Number, Other *) let no = [ @@ -1067,116 +1803,139 @@ let no = [ (0x000B9,0x000B9); (0x000BC,0x000BE); (0x009F4,0x009F9); + (0x00B72,0x00B77); (0x00BF0,0x00BF2); + (0x00C78,0x00C7E); + (0x00D58,0x00D5E); + (0x00D70,0x00D78); (0x00F2A,0x00F33); - (0x01372,0x0137C); + (0x01369,0x0137C); + (0x017F0,0x017F9); + (0x019DA,0x019DA); (0x02070,0x02070); (0x02074,0x02079); (0x02080,0x02089); - (0x02153,0x0215F); + (0x02150,0x0215F); + (0x02189,0x02189); (0x02460,0x0249B); - (0x024EA,0x024FE); + (0x024EA,0x024FF); (0x02776,0x02793); + (0x02CFD,0x02CFD); (0x03192,0x03195); (0x03220,0x03229); + (0x03248,0x0324F); (0x03251,0x0325F); (0x03280,0x03289); (0x032B1,0x032BF); - (0x10320,0x10323) + (0x0A830,0x0A835); + (0x10107,0x10133); + (0x10175,0x10178); + (0x1018A,0x1018B); + (0x102E1,0x102FB); + (0x10320,0x10323); + (0x10858,0x1085F); + (0x10879,0x1087F); + (0x108A7,0x108AF); + (0x108FB,0x108FF); + (0x10916,0x1091B); + (0x109BC,0x109BD); + (0x109C0,0x109CF); + (0x109D2,0x109FF); + (0x10A40,0x10A47); + (0x10A7D,0x10A7E); + (0x10A9D,0x10A9F); + (0x10AEB,0x10AEF); + (0x10B58,0x10B5F); + (0x10B78,0x10B7F); + (0x10BA9,0x10BAF); + (0x10CFA,0x10CFF); + (0x10E60,0x10E7E); + (0x11052,0x11065); + (0x111E1,0x111F4); + (0x1173A,0x1173B); + (0x118EA,0x118F2); + (0x11C5A,0x11C6C); + (0x16B5B,0x16B61); + (0x1D360,0x1D371); + (0x1E8C7,0x1E8CF) ] (* Separator, Space *) let zs = [ (0x00020,0x00020); (0x000A0,0x000A0); (0x01680,0x01680); - (0x02000,0x0200B); + (0x02000,0x0200A); (0x0202F,0x0202F); - (0x0205F,0x0205F); - (0x03000,0x03000) + (0x0205F,0x0205F) ] (* Separator, Line *) let zl = [ - (0x02028,0x02028) + ] (* Separator, Paragraph *) let zp = [ - (0x02029,0x02029) + ] (* Other, Control *) let cc = [ - (0x00000,0x0001F); - (0x0007F,0x0009F) + (0x00000,0x0001F) ] (* Other, Format *) let cf = [ + (0x000AD,0x000AD); + (0x00600,0x00605); + (0x0061C,0x0061C); (0x006DD,0x006DD); (0x0070F,0x0070F); + (0x008E2,0x008E2); (0x0180E,0x0180E); - (0x0200C,0x0200F); + (0x0200B,0x0200F); (0x0202A,0x0202E); - (0x02060,0x02063); - (0x0206A,0x0206F); + (0x02060,0x02064); + (0x02066,0x0206F); (0x0FEFF,0x0FEFF); (0x0FFF9,0x0FFFB); + (0x110BD,0x110BD); + (0x1BCA0,0x1BCA3); (0x1D173,0x1D17A); - (0xE0001,0xE0001); - (0xE0020,0xE007F) + (0xE0001,0xE0001) ] (* Other, Surrogate *) let cs = [ - (0x0D800,0x0DEFE); - (0x0DFFF,0x0DFFF) + ] (* Other, Private Use *) let co = [ - (0x0E000,0x0F8FF) + (0x0E000,0x0F8FF); + (0xF0000,0xFFFFD) ] (* Other, Not Assigned *) let cn = [ - (0x00221,0x00221); - (0x00234,0x0024F); - (0x002AE,0x002AF); - (0x002EF,0x002FF); - (0x00350,0x0035F); - (0x00370,0x00373); - (0x00376,0x00379); - (0x0037B,0x0037D); - (0x0037F,0x00383); + (0x00378,0x00379); + (0x00380,0x00383); (0x0038B,0x0038B); (0x0038D,0x0038D); (0x003A2,0x003A2); - (0x003CF,0x003CF); - (0x003F7,0x003FF); - (0x00487,0x00487); - (0x004CF,0x004CF); - (0x004F6,0x004F7); - (0x004FA,0x004FF); - (0x00510,0x00530); + (0x00530,0x00530); (0x00557,0x00558); (0x00560,0x00560); (0x00588,0x00588); - (0x0058B,0x00590); - (0x005A2,0x005A2); - (0x005BA,0x005BA); - (0x005C5,0x005CF); + (0x0058B,0x0058C); + (0x00590,0x00590); + (0x005C8,0x005CF); (0x005EB,0x005EF); - (0x005F5,0x0060B); - (0x0060D,0x0061A); - (0x0061C,0x0061E); - (0x00620,0x00620); - (0x0063B,0x0063F); - (0x00656,0x0065F); - (0x006EE,0x006EF); - (0x006FF,0x006FF); + (0x005F5,0x005FF); + (0x0061D,0x0061D); (0x0070E,0x0070E); - (0x0072D,0x0072F); - (0x0074B,0x0077F); - (0x007B2,0x00900); - (0x00904,0x00904); - (0x0093A,0x0093B); - (0x0094E,0x0094F); - (0x00955,0x00957); - (0x00971,0x00980); + (0x0074B,0x0074C); + (0x007B2,0x007BF); + (0x007FB,0x007FF); + (0x0082E,0x0082F); + (0x0083F,0x0083F); + (0x0085C,0x0085D); + (0x0085F,0x0089F); + (0x008B5,0x008B5); + (0x008BE,0x008D3); (0x00984,0x00984); (0x0098D,0x0098E); (0x00991,0x00992); @@ -1184,15 +1943,14 @@ let cn = [ (0x009B1,0x009B1); (0x009B3,0x009B5); (0x009BA,0x009BB); - (0x009BD,0x009BD); (0x009C5,0x009C6); (0x009C9,0x009CA); - (0x009CE,0x009D6); + (0x009CF,0x009D6); (0x009D8,0x009DB); (0x009DE,0x009DE); (0x009E4,0x009E5); - (0x009FB,0x00A01); - (0x00A03,0x00A04); + (0x009FC,0x00A00); + (0x00A04,0x00A04); (0x00A0B,0x00A0E); (0x00A11,0x00A12); (0x00A29,0x00A29); @@ -1203,12 +1961,12 @@ let cn = [ (0x00A3D,0x00A3D); (0x00A43,0x00A46); (0x00A49,0x00A4A); - (0x00A4E,0x00A58); + (0x00A4E,0x00A50); + (0x00A52,0x00A58); (0x00A5D,0x00A5D); (0x00A5F,0x00A65); - (0x00A75,0x00A80); + (0x00A76,0x00A80); (0x00A84,0x00A84); - (0x00A8C,0x00A8C); (0x00A8E,0x00A8E); (0x00A92,0x00A92); (0x00AA9,0x00AA9); @@ -1219,22 +1977,23 @@ let cn = [ (0x00ACA,0x00ACA); (0x00ACE,0x00ACF); (0x00AD1,0x00ADF); - (0x00AE1,0x00AE5); - (0x00AF0,0x00B00); + (0x00AE4,0x00AE5); + (0x00AF2,0x00AF8); + (0x00AFA,0x00B00); (0x00B04,0x00B04); (0x00B0D,0x00B0E); (0x00B11,0x00B12); (0x00B29,0x00B29); (0x00B31,0x00B31); - (0x00B34,0x00B35); + (0x00B34,0x00B34); (0x00B3A,0x00B3B); - (0x00B44,0x00B46); + (0x00B45,0x00B46); (0x00B49,0x00B4A); (0x00B4E,0x00B55); (0x00B58,0x00B5B); (0x00B5E,0x00B5E); - (0x00B62,0x00B65); - (0x00B71,0x00B81); + (0x00B64,0x00B65); + (0x00B78,0x00B81); (0x00B84,0x00B84); (0x00B8B,0x00B8D); (0x00B91,0x00B91); @@ -1244,49 +2003,48 @@ let cn = [ (0x00BA0,0x00BA2); (0x00BA5,0x00BA7); (0x00BAB,0x00BAD); - (0x00BB6,0x00BB6); (0x00BBA,0x00BBD); (0x00BC3,0x00BC5); (0x00BC9,0x00BC9); - (0x00BCE,0x00BD6); - (0x00BD8,0x00BE6); - (0x00BF3,0x00C00); + (0x00BCE,0x00BCF); + (0x00BD1,0x00BD6); + (0x00BD8,0x00BE5); + (0x00BFB,0x00BFF); (0x00C04,0x00C04); (0x00C0D,0x00C0D); (0x00C11,0x00C11); (0x00C29,0x00C29); - (0x00C34,0x00C34); - (0x00C3A,0x00C3D); + (0x00C3A,0x00C3C); (0x00C45,0x00C45); (0x00C49,0x00C49); (0x00C4E,0x00C54); - (0x00C57,0x00C5F); - (0x00C62,0x00C65); - (0x00C70,0x00C81); + (0x00C57,0x00C57); + (0x00C5B,0x00C5F); + (0x00C64,0x00C65); + (0x00C70,0x00C77); (0x00C84,0x00C84); (0x00C8D,0x00C8D); (0x00C91,0x00C91); (0x00CA9,0x00CA9); (0x00CB4,0x00CB4); - (0x00CBA,0x00CBD); + (0x00CBA,0x00CBB); (0x00CC5,0x00CC5); (0x00CC9,0x00CC9); (0x00CCE,0x00CD4); (0x00CD7,0x00CDD); (0x00CDF,0x00CDF); - (0x00CE2,0x00CE5); - (0x00CF0,0x00D01); + (0x00CE4,0x00CE5); + (0x00CF0,0x00CF0); + (0x00CF3,0x00D00); (0x00D04,0x00D04); (0x00D0D,0x00D0D); (0x00D11,0x00D11); - (0x00D29,0x00D29); - (0x00D3A,0x00D3D); - (0x00D44,0x00D45); + (0x00D3B,0x00D3C); + (0x00D45,0x00D45); (0x00D49,0x00D49); - (0x00D4E,0x00D56); - (0x00D58,0x00D5F); - (0x00D62,0x00D65); - (0x00D70,0x00D81); + (0x00D50,0x00D53); + (0x00D64,0x00D65); + (0x00D80,0x00D81); (0x00D84,0x00D84); (0x00D97,0x00D99); (0x00DB2,0x00DB2); @@ -1296,7 +2054,8 @@ let cn = [ (0x00DCB,0x00DCE); (0x00DD5,0x00DD5); (0x00DD7,0x00DD7); - (0x00DE0,0x00DF1); + (0x00DE0,0x00DE5); + (0x00DF0,0x00DF1); (0x00DF5,0x00E00); (0x00E3B,0x00E3E); (0x00E5C,0x00E80); @@ -1317,56 +2076,38 @@ let cn = [ (0x00EC7,0x00EC7); (0x00ECE,0x00ECF); (0x00EDA,0x00EDB); - (0x00EDE,0x00EFF); + (0x00EE0,0x00EFF); (0x00F48,0x00F48); - (0x00F6B,0x00F70); - (0x00F8C,0x00F8F); + (0x00F6D,0x00F70); (0x00F98,0x00F98); (0x00FBD,0x00FBD); - (0x00FCD,0x00FCE); - (0x00FD0,0x00FFF); - (0x01022,0x01022); - (0x01028,0x01028); - (0x0102B,0x0102B); - (0x01033,0x01035); - (0x0103A,0x0103F); - (0x0105A,0x0109F); - (0x010C6,0x010CF); - (0x010F9,0x010FA); - (0x010FC,0x010FF); - (0x0115A,0x0115E); - (0x011A3,0x011A7); - (0x011FA,0x011FF); - (0x01207,0x01207); - (0x01247,0x01247); + (0x00FCD,0x00FCD); + (0x00FDB,0x00FFF); + (0x010C6,0x010C6); + (0x010C8,0x010CC); + (0x010CE,0x010CF); (0x01249,0x01249); (0x0124E,0x0124F); (0x01257,0x01257); (0x01259,0x01259); (0x0125E,0x0125F); - (0x01287,0x01287); (0x01289,0x01289); (0x0128E,0x0128F); - (0x012AF,0x012AF); (0x012B1,0x012B1); (0x012B6,0x012B7); (0x012BF,0x012BF); (0x012C1,0x012C1); (0x012C6,0x012C7); - (0x012CF,0x012CF); (0x012D7,0x012D7); - (0x012EF,0x012EF); - (0x0130F,0x0130F); (0x01311,0x01311); (0x01316,0x01317); - (0x0131F,0x0131F); - (0x01347,0x01347); - (0x0135B,0x01360); - (0x0137D,0x0139F); - (0x013F5,0x01400); - (0x01677,0x0167F); + (0x0135B,0x0135C); + (0x0137D,0x0137F); + (0x0139A,0x0139F); + (0x013F6,0x013F7); + (0x013FE,0x013FF); (0x0169D,0x0169F); - (0x016F1,0x016FF); + (0x016F9,0x016FF); (0x0170D,0x0170D); (0x01715,0x0171F); (0x01737,0x0173F); @@ -1374,14 +2115,40 @@ let cn = [ (0x0176D,0x0176D); (0x01771,0x01771); (0x01774,0x0177F); - (0x017DD,0x017DF); - (0x017EA,0x017FF); + (0x017DE,0x017DF); + (0x017EA,0x017EF); + (0x017FA,0x017FF); (0x0180F,0x0180F); (0x0181A,0x0181F); (0x01878,0x0187F); - (0x018AA,0x01DFF); - (0x01E9C,0x01E9F); - (0x01EFA,0x01EFF); + (0x018AB,0x018AF); + (0x018F6,0x018FF); + (0x0191F,0x0191F); + (0x0192C,0x0192F); + (0x0193C,0x0193F); + (0x01941,0x01943); + (0x0196E,0x0196F); + (0x01975,0x0197F); + (0x019AC,0x019AF); + (0x019CA,0x019CF); + (0x019DB,0x019DD); + (0x01A1C,0x01A1D); + (0x01A5F,0x01A5F); + (0x01A7D,0x01A7E); + (0x01A8A,0x01A8F); + (0x01A9A,0x01A9F); + (0x01AAE,0x01AAF); + (0x01ABF,0x01AFF); + (0x01B4C,0x01B4F); + (0x01B7D,0x01B7F); + (0x01BF4,0x01BFB); + (0x01C38,0x01C3A); + (0x01C4A,0x01C4C); + (0x01C89,0x01CBF); + (0x01CC8,0x01CCF); + (0x01CF7,0x01CF7); + (0x01CFA,0x01CFF); + (0x01DF6,0x01DFA); (0x01F16,0x01F17); (0x01F1E,0x01F1F); (0x01F46,0x01F47); @@ -1398,37 +2165,40 @@ let cn = [ (0x01FF0,0x01FF1); (0x01FF5,0x01FF5); (0x01FFF,0x01FFF); - (0x02053,0x02056); - (0x02058,0x0205E); - (0x02064,0x02069); + (0x02065,0x02065); (0x02072,0x02073); - (0x0208F,0x0209F); - (0x020B2,0x020CF); - (0x020EB,0x020FF); - (0x0213B,0x0213C); - (0x0214C,0x02152); - (0x02184,0x0218F); - (0x023CF,0x023FF); + (0x0208F,0x0208F); + (0x0209D,0x0209F); + (0x020BF,0x020CF); + (0x020F1,0x020FF); + (0x0218C,0x0218F); + (0x023FF,0x023FF); (0x02427,0x0243F); (0x0244B,0x0245F); - (0x024FF,0x024FF); - (0x02614,0x02615); - (0x02618,0x02618); - (0x0267E,0x0267F); - (0x0268A,0x02700); - (0x02705,0x02705); - (0x0270A,0x0270B); - (0x02728,0x02728); - (0x0274C,0x0274C); - (0x0274E,0x0274E); - (0x02753,0x02755); - (0x02757,0x02757); - (0x0275F,0x02760); - (0x02795,0x02797); - (0x027B0,0x027B0); - (0x027BF,0x027CF); - (0x027EC,0x027EF); - (0x02B00,0x02E7F); + (0x02B74,0x02B75); + (0x02B96,0x02B97); + (0x02BBA,0x02BBC); + (0x02BC9,0x02BC9); + (0x02BD2,0x02BEB); + (0x02BF0,0x02BFF); + (0x02C2F,0x02C2F); + (0x02C5F,0x02C5F); + (0x02CF4,0x02CF8); + (0x02D26,0x02D26); + (0x02D28,0x02D2C); + (0x02D2E,0x02D2F); + (0x02D68,0x02D6E); + (0x02D71,0x02D7E); + (0x02D97,0x02D9F); + (0x02DA7,0x02DA7); + (0x02DAF,0x02DAF); + (0x02DB7,0x02DB7); + (0x02DBF,0x02DBF); + (0x02DC7,0x02DC7); + (0x02DCF,0x02DCF); + (0x02DD7,0x02DD7); + (0x02DDF,0x02DDF); + (0x02E45,0x02E7F); (0x02E9A,0x02E9A); (0x02EF4,0x02EFF); (0x02FD6,0x02FEF); @@ -1436,25 +2206,49 @@ let cn = [ (0x03040,0x03040); (0x03097,0x03098); (0x03100,0x03104); - (0x0312D,0x03130); + (0x0312E,0x03130); (0x0318F,0x0318F); - (0x031B8,0x031EF); - (0x0321D,0x0321F); - (0x03244,0x03250); - (0x0327C,0x0327E); - (0x032CC,0x032CF); + (0x031BB,0x031BF); + (0x031E4,0x031EF); + (0x0321F,0x0321F); (0x032FF,0x032FF); - (0x03377,0x0337A); - (0x033DE,0x033DF); - (0x033FF,0x033FF); - (0x04DB6,0x04DFF); - (0x09FA6,0x09FFF); + (0x04DB6,0x04DBF); + (0x09FD6,0x09FFF); (0x0A48D,0x0A48F); - (0x0A4C7,0x0ABFF); - (0x0D7A4,0x0D7FF); - (0x0DEFF,0x0DFFE); - (0x0FA2E,0x0FA2F); - (0x0FA6B,0x0FAFF); + (0x0A4C7,0x0A4CF); + (0x0A62C,0x0A63F); + (0x0A6F8,0x0A6FF); + (0x0A7AF,0x0A7AF); + (0x0A7B8,0x0A7F6); + (0x0A82C,0x0A82F); + (0x0A83A,0x0A83F); + (0x0A878,0x0A87F); + (0x0A8C6,0x0A8CD); + (0x0A8DA,0x0A8DF); + (0x0A8FE,0x0A8FF); + (0x0A954,0x0A95E); + (0x0A97D,0x0A97F); + (0x0A9CE,0x0A9CE); + (0x0A9DA,0x0A9DD); + (0x0A9FF,0x0A9FF); + (0x0AA37,0x0AA3F); + (0x0AA4E,0x0AA4F); + (0x0AA5A,0x0AA5B); + (0x0AAC3,0x0AADA); + (0x0AAF7,0x0AB00); + (0x0AB07,0x0AB08); + (0x0AB0F,0x0AB10); + (0x0AB17,0x0AB1F); + (0x0AB27,0x0AB27); + (0x0AB2F,0x0AB2F); + (0x0AB66,0x0AB6F); + (0x0ABEE,0x0ABEF); + (0x0ABFA,0x0ABFF); + (0x0D7A4,0x0D7AF); + (0x0D7C7,0x0D7CA); + (0x0D7FC,0x0D7FF); + (0x0FA6E,0x0FA6F); + (0x0FADA,0x0FAFF); (0x0FB07,0x0FB12); (0x0FB18,0x0FB1C); (0x0FB37,0x0FB37); @@ -1462,14 +2256,12 @@ let cn = [ (0x0FB3F,0x0FB3F); (0x0FB42,0x0FB42); (0x0FB45,0x0FB45); - (0x0FBB2,0x0FBD2); + (0x0FBC2,0x0FBD2); (0x0FD40,0x0FD4F); (0x0FD90,0x0FD91); (0x0FDC8,0x0FDEF); - (0x0FDFD,0x0FDFF); - (0x0FE10,0x0FE1F); - (0x0FE24,0x0FE2F); - (0x0FE47,0x0FE48); + (0x0FDFE,0x0FDFF); + (0x0FE1A,0x0FE1F); (0x0FE53,0x0FE53); (0x0FE67,0x0FE67); (0x0FE6C,0x0FE6F); @@ -1483,15 +2275,171 @@ let cn = [ (0x0FFDD,0x0FFDF); (0x0FFE7,0x0FFE7); (0x0FFEF,0x0FFF8); - (0x0FFFE,0x102FF); - (0x1031F,0x1031F); + (0x0FFFE,0x0FFFF); + (0x1000C,0x1000C); + (0x10027,0x10027); + (0x1003B,0x1003B); + (0x1003E,0x1003E); + (0x1004E,0x1004F); + (0x1005E,0x1007F); + (0x100FB,0x100FF); + (0x10103,0x10106); + (0x10134,0x10136); + (0x1018F,0x1018F); + (0x1019C,0x1019F); + (0x101A1,0x101CF); + (0x101FE,0x1027F); + (0x1029D,0x1029F); + (0x102D1,0x102DF); + (0x102FC,0x102FF); (0x10324,0x1032F); - (0x1034B,0x103FF); - (0x10426,0x10427); - (0x1044E,0x1CFFF); + (0x1034B,0x1034F); + (0x1037B,0x1037F); + (0x1039E,0x1039E); + (0x103C4,0x103C7); + (0x103D6,0x103FF); + (0x1049E,0x1049F); + (0x104AA,0x104AF); + (0x104D4,0x104D7); + (0x104FC,0x104FF); + (0x10528,0x1052F); + (0x10564,0x1056E); + (0x10570,0x105FF); + (0x10737,0x1073F); + (0x10756,0x1075F); + (0x10768,0x107FF); + (0x10806,0x10807); + (0x10809,0x10809); + (0x10836,0x10836); + (0x10839,0x1083B); + (0x1083D,0x1083E); + (0x10856,0x10856); + (0x1089F,0x108A6); + (0x108B0,0x108DF); + (0x108F3,0x108F3); + (0x108F6,0x108FA); + (0x1091C,0x1091E); + (0x1093A,0x1093E); + (0x10940,0x1097F); + (0x109B8,0x109BB); + (0x109D0,0x109D1); + (0x10A04,0x10A04); + (0x10A07,0x10A0B); + (0x10A14,0x10A14); + (0x10A18,0x10A18); + (0x10A34,0x10A37); + (0x10A3B,0x10A3E); + (0x10A48,0x10A4F); + (0x10A59,0x10A5F); + (0x10AA0,0x10ABF); + (0x10AE7,0x10AEA); + (0x10AF7,0x10AFF); + (0x10B36,0x10B38); + (0x10B56,0x10B57); + (0x10B73,0x10B77); + (0x10B92,0x10B98); + (0x10B9D,0x10BA8); + (0x10BB0,0x10BFF); + (0x10C49,0x10C7F); + (0x10CB3,0x10CBF); + (0x10CF3,0x10CF9); + (0x10D00,0x10E5F); + (0x10E7F,0x10FFF); + (0x1104E,0x11051); + (0x11070,0x1107E); + (0x110C2,0x110CF); + (0x110E9,0x110EF); + (0x110FA,0x110FF); + (0x11135,0x11135); + (0x11144,0x1114F); + (0x11177,0x1117F); + (0x111CE,0x111CF); + (0x111E0,0x111E0); + (0x111F5,0x111FF); + (0x11212,0x11212); + (0x1123F,0x1127F); + (0x11287,0x11287); + (0x11289,0x11289); + (0x1128E,0x1128E); + (0x1129E,0x1129E); + (0x112AA,0x112AF); + (0x112EB,0x112EF); + (0x112FA,0x112FF); + (0x11304,0x11304); + (0x1130D,0x1130E); + (0x11311,0x11312); + (0x11329,0x11329); + (0x11331,0x11331); + (0x11334,0x11334); + (0x1133A,0x1133B); + (0x11345,0x11346); + (0x11349,0x1134A); + (0x1134E,0x1134F); + (0x11351,0x11356); + (0x11358,0x1135C); + (0x11364,0x11365); + (0x1136D,0x1136F); + (0x11375,0x113FF); + (0x1145A,0x1145A); + (0x1145C,0x1145C); + (0x1145E,0x1147F); + (0x114C8,0x114CF); + (0x114DA,0x1157F); + (0x115B6,0x115B7); + (0x115DE,0x115FF); + (0x11645,0x1164F); + (0x1165A,0x1165F); + (0x1166D,0x1167F); + (0x116B8,0x116BF); + (0x116CA,0x116FF); + (0x1171A,0x1171C); + (0x1172C,0x1172F); + (0x11740,0x1189F); + (0x118F3,0x118FE); + (0x11900,0x11ABF); + (0x11AF9,0x11BFF); + (0x11C09,0x11C09); + (0x11C37,0x11C37); + (0x11C46,0x11C4F); + (0x11C6D,0x11C6F); + (0x11C90,0x11C91); + (0x11CA8,0x11CA8); + (0x11CB7,0x11FFF); + (0x1239A,0x123FF); + (0x1246F,0x1246F); + (0x12475,0x1247F); + (0x12544,0x12FFF); + (0x1342F,0x143FF); + (0x14647,0x167FF); + (0x16A39,0x16A3F); + (0x16A5F,0x16A5F); + (0x16A6A,0x16A6D); + (0x16A70,0x16ACF); + (0x16AEE,0x16AEF); + (0x16AF6,0x16AFF); + (0x16B46,0x16B4F); + (0x16B5A,0x16B5A); + (0x16B62,0x16B62); + (0x16B78,0x16B7C); + (0x16B90,0x16EFF); + (0x16F45,0x16F4F); + (0x16F7F,0x16F8E); + (0x16FA0,0x16FDF); + (0x16FE1,0x16FFF); + (0x187ED,0x187FF); + (0x18AF3,0x1AFFF); + (0x1B002,0x1BBFF); + (0x1BC6B,0x1BC6F); + (0x1BC7D,0x1BC7F); + (0x1BC89,0x1BC8F); + (0x1BC9A,0x1BC9B); + (0x1BCA4,0x1CFFF); (0x1D0F6,0x1D0FF); - (0x1D127,0x1D129); - (0x1D1DE,0x1D3FF); + (0x1D127,0x1D128); + (0x1D1E9,0x1D1FF); + (0x1D246,0x1D2FF); + (0x1D357,0x1D35F); + (0x1D372,0x1D3FF); (0x1D455,0x1D455); (0x1D49D,0x1D49D); (0x1D4A0,0x1D4A1); @@ -1500,7 +2448,6 @@ let cn = [ (0x1D4AD,0x1D4AD); (0x1D4BA,0x1D4BA); (0x1D4BC,0x1D4BC); - (0x1D4C1,0x1D4C1); (0x1D4C4,0x1D4C4); (0x1D506,0x1D506); (0x1D50B,0x1D50C); @@ -1511,63 +2458,195 @@ let cn = [ (0x1D545,0x1D545); (0x1D547,0x1D549); (0x1D551,0x1D551); - (0x1D6A4,0x1D6A7); - (0x1D7CA,0x1D7CD); - (0x1D800,0x1FFFF); - (0x2A6D7,0x2F7FF); + (0x1D6A6,0x1D6A7); + (0x1D7CC,0x1D7CD); + (0x1DA8C,0x1DA9A); + (0x1DAA0,0x1DAA0); + (0x1DAB0,0x1DFFF); + (0x1E007,0x1E007); + (0x1E019,0x1E01A); + (0x1E022,0x1E022); + (0x1E025,0x1E025); + (0x1E02B,0x1E7FF); + (0x1E8C5,0x1E8C6); + (0x1E8D7,0x1E8FF); + (0x1E94B,0x1E94F); + (0x1E95A,0x1E95D); + (0x1E960,0x1EDFF); + (0x1EE04,0x1EE04); + (0x1EE20,0x1EE20); + (0x1EE23,0x1EE23); + (0x1EE25,0x1EE26); + (0x1EE28,0x1EE28); + (0x1EE33,0x1EE33); + (0x1EE38,0x1EE38); + (0x1EE3A,0x1EE3A); + (0x1EE3C,0x1EE41); + (0x1EE43,0x1EE46); + (0x1EE48,0x1EE48); + (0x1EE4A,0x1EE4A); + (0x1EE4C,0x1EE4C); + (0x1EE50,0x1EE50); + (0x1EE53,0x1EE53); + (0x1EE55,0x1EE56); + (0x1EE58,0x1EE58); + (0x1EE5A,0x1EE5A); + (0x1EE5C,0x1EE5C); + (0x1EE5E,0x1EE5E); + (0x1EE60,0x1EE60); + (0x1EE63,0x1EE63); + (0x1EE65,0x1EE66); + (0x1EE6B,0x1EE6B); + (0x1EE73,0x1EE73); + (0x1EE78,0x1EE78); + (0x1EE7D,0x1EE7D); + (0x1EE7F,0x1EE7F); + (0x1EE8A,0x1EE8A); + (0x1EE9C,0x1EEA0); + (0x1EEA4,0x1EEA4); + (0x1EEAA,0x1EEAA); + (0x1EEBC,0x1EEEF); + (0x1EEF2,0x1EFFF); + (0x1F02C,0x1F02F); + (0x1F094,0x1F09F); + (0x1F0AF,0x1F0B0); + (0x1F0C0,0x1F0C0); + (0x1F0D0,0x1F0D0); + (0x1F0F6,0x1F0FF); + (0x1F10D,0x1F10F); + (0x1F12F,0x1F12F); + (0x1F16C,0x1F16F); + (0x1F1AD,0x1F1E5); + (0x1F203,0x1F20F); + (0x1F23C,0x1F23F); + (0x1F249,0x1F24F); + (0x1F252,0x1F2FF); + (0x1F6D3,0x1F6DF); + (0x1F6ED,0x1F6EF); + (0x1F6F7,0x1F6FF); + (0x1F774,0x1F77F); + (0x1F7D5,0x1F7FF); + (0x1F80C,0x1F80F); + (0x1F848,0x1F84F); + (0x1F85A,0x1F85F); + (0x1F888,0x1F88F); + (0x1F8AE,0x1F90F); + (0x1F91F,0x1F91F); + (0x1F928,0x1F92F); + (0x1F931,0x1F932); + (0x1F93F,0x1F93F); + (0x1F94C,0x1F94F); + (0x1F95F,0x1F97F); + (0x1F992,0x1F9BF); + (0x1F9C1,0x1FFFF); + (0x2A6D7,0x2A6FF); + (0x2B735,0x2B73F); + (0x2B81E,0x2B81F); + (0x2CEA2,0x2F7FF); (0x2FA1E,0xE0000); (0xE0002,0xE001F); - (0xE0080,0x7FFFFFFF) + (0xE0080,0xE00FF); + (0xE01F0,0xEFFFF); + (0xFFFFE,0xFFFFF) ] (* Letter, Modifier *) let lm = [ - (0x002B0,0x002B8); - (0x002BB,0x002C1); - (0x002D0,0x002D1); + (0x002B0,0x002C1); + (0x002C6,0x002D1); (0x002E0,0x002E4); + (0x002EC,0x002EC); (0x002EE,0x002EE); + (0x00374,0x00374); (0x0037A,0x0037A); (0x00559,0x00559); (0x00640,0x00640); (0x006E5,0x006E6); + (0x007F4,0x007F5); + (0x007FA,0x007FA); + (0x0081A,0x0081A); + (0x00824,0x00824); + (0x00828,0x00828); + (0x00971,0x00971); (0x00E46,0x00E46); (0x00EC6,0x00EC6); + (0x010FC,0x010FC); (0x017D7,0x017D7); (0x01843,0x01843); + (0x01AA7,0x01AA7); + (0x01C78,0x01C7D); + (0x01D2C,0x01D6A); + (0x01D78,0x01D78); + (0x01D9B,0x01DBF); + (0x02071,0x02071); + (0x0207F,0x0207F); + (0x02090,0x0209C); + (0x02C7C,0x02C7D); + (0x02D6F,0x02D6F); + (0x02E2F,0x02E2F); (0x03005,0x03005); (0x03031,0x03035); (0x0303B,0x0303B); (0x0309D,0x0309E); (0x030FC,0x030FE); + (0x0A015,0x0A015); + (0x0A4F8,0x0A4FD); + (0x0A60C,0x0A60C); + (0x0A67F,0x0A67F); + (0x0A69C,0x0A69D); + (0x0A717,0x0A71F); + (0x0A770,0x0A770); + (0x0A788,0x0A788); + (0x0A7F8,0x0A7F9); + (0x0A9CF,0x0A9CF); + (0x0A9E6,0x0A9E6); + (0x0AA70,0x0AA70); + (0x0AADD,0x0AADD); + (0x0AAF3,0x0AAF4); + (0x0AB5C,0x0AB5F); (0x0FF70,0x0FF70); - (0x0FF9E,0x0FF9F) + (0x0FF9E,0x0FF9F); + (0x16B40,0x16B43); + (0x16F93,0x16F9F) ] (* Letter, Other *) let lo = [ + (0x000AA,0x000AA); + (0x000BA,0x000BA); (0x001BB,0x001BB); (0x001C0,0x001C3); + (0x00294,0x00294); (0x005D0,0x005EA); (0x005F0,0x005F2); - (0x00621,0x0063A); + (0x00620,0x0063F); (0x00641,0x0064A); (0x0066E,0x0066F); (0x00671,0x006D3); (0x006D5,0x006D5); + (0x006EE,0x006EF); (0x006FA,0x006FC); + (0x006FF,0x006FF); (0x00710,0x00710); - (0x00712,0x0072C); - (0x00780,0x007A5); + (0x00712,0x0072F); + (0x0074D,0x007A5); (0x007B1,0x007B1); - (0x00905,0x00939); + (0x007CA,0x007EA); + (0x00800,0x00815); + (0x00840,0x00858); + (0x008A0,0x008B4); + (0x008B6,0x008BD); + (0x00904,0x00939); (0x0093D,0x0093D); (0x00950,0x00950); (0x00958,0x00961); + (0x00972,0x00980); (0x00985,0x0098C); (0x0098F,0x00990); (0x00993,0x009A8); (0x009AA,0x009B0); (0x009B2,0x009B2); (0x009B6,0x009B9); + (0x009BD,0x009BD); + (0x009CE,0x009CE); (0x009DC,0x009DD); (0x009DF,0x009E1); (0x009F0,0x009F1); @@ -1581,8 +2660,7 @@ let lo = [ (0x00A59,0x00A5C); (0x00A5E,0x00A5E); (0x00A72,0x00A74); - (0x00A85,0x00A8B); - (0x00A8D,0x00A8D); + (0x00A85,0x00A8D); (0x00A8F,0x00A91); (0x00A93,0x00AA8); (0x00AAA,0x00AB0); @@ -1590,16 +2668,18 @@ let lo = [ (0x00AB5,0x00AB9); (0x00ABD,0x00ABD); (0x00AD0,0x00AD0); - (0x00AE0,0x00AE0); + (0x00AE0,0x00AE1); + (0x00AF9,0x00AF9); (0x00B05,0x00B0C); (0x00B0F,0x00B10); (0x00B13,0x00B28); (0x00B2A,0x00B30); (0x00B32,0x00B33); - (0x00B36,0x00B39); + (0x00B35,0x00B39); (0x00B3D,0x00B3D); (0x00B5C,0x00B5D); (0x00B5F,0x00B61); + (0x00B71,0x00B71); (0x00B83,0x00B83); (0x00B85,0x00B8A); (0x00B8E,0x00B90); @@ -1609,26 +2689,33 @@ let lo = [ (0x00B9E,0x00B9F); (0x00BA3,0x00BA4); (0x00BA8,0x00BAA); - (0x00BAE,0x00BB5); - (0x00BB7,0x00BB9); + (0x00BAE,0x00BB9); + (0x00BD0,0x00BD0); (0x00C05,0x00C0C); (0x00C0E,0x00C10); (0x00C12,0x00C28); - (0x00C2A,0x00C33); - (0x00C35,0x00C39); + (0x00C2A,0x00C39); + (0x00C3D,0x00C3D); + (0x00C58,0x00C5A); (0x00C60,0x00C61); + (0x00C80,0x00C80); (0x00C85,0x00C8C); (0x00C8E,0x00C90); (0x00C92,0x00CA8); (0x00CAA,0x00CB3); (0x00CB5,0x00CB9); + (0x00CBD,0x00CBD); (0x00CDE,0x00CDE); (0x00CE0,0x00CE1); + (0x00CF1,0x00CF2); (0x00D05,0x00D0C); (0x00D0E,0x00D10); - (0x00D12,0x00D28); - (0x00D2A,0x00D39); - (0x00D60,0x00D61); + (0x00D12,0x00D3A); + (0x00D3D,0x00D3D); + (0x00D4E,0x00D4E); + (0x00D54,0x00D56); + (0x00D5F,0x00D61); + (0x00D7A,0x00D7F); (0x00D85,0x00D96); (0x00D9A,0x00DB1); (0x00DB3,0x00DBB); @@ -1652,49 +2739,43 @@ let lo = [ (0x00EB2,0x00EB3); (0x00EBD,0x00EBD); (0x00EC0,0x00EC4); - (0x00EDC,0x00EDD); + (0x00EDC,0x00EDF); (0x00F00,0x00F00); (0x00F40,0x00F47); - (0x00F49,0x00F6A); - (0x00F88,0x00F8B); - (0x01000,0x01021); - (0x01023,0x01027); - (0x01029,0x0102A); + (0x00F49,0x00F6C); + (0x00F88,0x00F8C); + (0x01000,0x0102A); + (0x0103F,0x0103F); (0x01050,0x01055); - (0x010D0,0x010F8); - (0x01100,0x01159); - (0x0115F,0x011A2); - (0x011A8,0x011F9); - (0x01200,0x01206); - (0x01208,0x01246); - (0x01248,0x01248); + (0x0105A,0x0105D); + (0x01061,0x01061); + (0x01065,0x01066); + (0x0106E,0x01070); + (0x01075,0x01081); + (0x0108E,0x0108E); + (0x010D0,0x010FA); + (0x010FD,0x01248); (0x0124A,0x0124D); (0x01250,0x01256); (0x01258,0x01258); (0x0125A,0x0125D); - (0x01260,0x01286); - (0x01288,0x01288); + (0x01260,0x01288); (0x0128A,0x0128D); - (0x01290,0x012AE); - (0x012B0,0x012B0); + (0x01290,0x012B0); (0x012B2,0x012B5); (0x012B8,0x012BE); (0x012C0,0x012C0); (0x012C2,0x012C5); - (0x012C8,0x012CE); - (0x012D0,0x012D6); - (0x012D8,0x012EE); - (0x012F0,0x0130E); - (0x01310,0x01310); + (0x012C8,0x012D6); + (0x012D8,0x01310); (0x01312,0x01315); - (0x01318,0x0131E); - (0x01320,0x01346); - (0x01348,0x0135A); - (0x013A0,0x013F4); + (0x01318,0x0135A); + (0x01380,0x0138F); (0x01401,0x0166C); - (0x0166F,0x01676); + (0x0166F,0x0167F); (0x01681,0x0169A); (0x016A0,0x016EA); + (0x016F1,0x016F8); (0x01700,0x0170C); (0x0170E,0x01711); (0x01720,0x01731); @@ -1705,24 +2786,103 @@ let lo = [ (0x017DC,0x017DC); (0x01820,0x01842); (0x01844,0x01877); - (0x01880,0x018A8); + (0x01880,0x01884); + (0x01887,0x018A8); + (0x018AA,0x018AA); + (0x018B0,0x018F5); + (0x01900,0x0191E); + (0x01950,0x0196D); + (0x01970,0x01974); + (0x01980,0x019AB); + (0x019B0,0x019C9); + (0x01A00,0x01A16); + (0x01A20,0x01A54); + (0x01B05,0x01B33); + (0x01B45,0x01B4B); + (0x01B83,0x01BA0); + (0x01BAE,0x01BAF); + (0x01BBA,0x01BE5); + (0x01C00,0x01C23); + (0x01C4D,0x01C4F); + (0x01C5A,0x01C77); + (0x01CE9,0x01CEC); + (0x01CEE,0x01CF1); + (0x01CF5,0x01CF6); (0x02135,0x02138); + (0x02D30,0x02D67); + (0x02D80,0x02D96); + (0x02DA0,0x02DA6); + (0x02DA8,0x02DAE); + (0x02DB0,0x02DB6); + (0x02DB8,0x02DBE); + (0x02DC0,0x02DC6); + (0x02DC8,0x02DCE); + (0x02DD0,0x02DD6); + (0x02DD8,0x02DDE); (0x03006,0x03006); (0x0303C,0x0303C); (0x03041,0x03096); (0x0309F,0x0309F); (0x030A1,0x030FA); (0x030FF,0x030FF); - (0x03105,0x0312C); + (0x03105,0x0312D); (0x03131,0x0318E); - (0x031A0,0x031B7); + (0x031A0,0x031BA); (0x031F0,0x031FF); (0x03400,0x04DB5); - (0x04E00,0x09FA5); - (0x0A000,0x0A48C); + (0x04E00,0x09FD5); + (0x0A000,0x0A014); + (0x0A016,0x0A48C); + (0x0A4D0,0x0A4F7); + (0x0A500,0x0A60B); + (0x0A610,0x0A61F); + (0x0A62A,0x0A62B); + (0x0A66E,0x0A66E); + (0x0A6A0,0x0A6E5); + (0x0A78F,0x0A78F); + (0x0A7F7,0x0A7F7); + (0x0A7FB,0x0A801); + (0x0A803,0x0A805); + (0x0A807,0x0A80A); + (0x0A80C,0x0A822); + (0x0A840,0x0A873); + (0x0A882,0x0A8B3); + (0x0A8F2,0x0A8F7); + (0x0A8FB,0x0A8FB); + (0x0A8FD,0x0A8FD); + (0x0A90A,0x0A925); + (0x0A930,0x0A946); + (0x0A960,0x0A97C); + (0x0A984,0x0A9B2); + (0x0A9E0,0x0A9E4); + (0x0A9E7,0x0A9EF); + (0x0A9FA,0x0A9FE); + (0x0AA00,0x0AA28); + (0x0AA40,0x0AA42); + (0x0AA44,0x0AA4B); + (0x0AA60,0x0AA6F); + (0x0AA71,0x0AA76); + (0x0AA7A,0x0AA7A); + (0x0AA7E,0x0AAAF); + (0x0AAB1,0x0AAB1); + (0x0AAB5,0x0AAB6); + (0x0AAB9,0x0AABD); + (0x0AAC0,0x0AAC0); + (0x0AAC2,0x0AAC2); + (0x0AADB,0x0AADC); + (0x0AAE0,0x0AAEA); + (0x0AAF2,0x0AAF2); + (0x0AB01,0x0AB06); + (0x0AB09,0x0AB0E); + (0x0AB11,0x0AB16); + (0x0AB20,0x0AB26); + (0x0AB28,0x0AB2E); + (0x0ABC0,0x0ABE2); (0x0AC00,0x0D7A3); - (0x0F900,0x0FA2D); - (0x0FA30,0x0FA6A); + (0x0D7B0,0x0D7C6); + (0x0D7CB,0x0D7FB); + (0x0F900,0x0FA6D); + (0x0FA70,0x0FAD9); (0x0FB1D,0x0FB1D); (0x0FB1F,0x0FB28); (0x0FB2A,0x0FB36); @@ -1744,35 +2904,183 @@ let lo = [ (0x0FFCA,0x0FFCF); (0x0FFD2,0x0FFD7); (0x0FFDA,0x0FFDC); - (0x10300,0x1031E); - (0x10330,0x10349); + (0x10000,0x1000B); + (0x1000D,0x10026); + (0x10028,0x1003A); + (0x1003C,0x1003D); + (0x1003F,0x1004D); + (0x10050,0x1005D); + (0x10080,0x100FA); + (0x10280,0x1029C); + (0x102A0,0x102D0); + (0x10300,0x1031F); + (0x10330,0x10340); + (0x10342,0x10349); + (0x10350,0x10375); + (0x10380,0x1039D); + (0x103A0,0x103C3); + (0x103C8,0x103CF); + (0x10450,0x1049D); + (0x10500,0x10527); + (0x10530,0x10563); + (0x10600,0x10736); + (0x10740,0x10755); + (0x10760,0x10767); + (0x10800,0x10805); + (0x10808,0x10808); + (0x1080A,0x10835); + (0x10837,0x10838); + (0x1083C,0x1083C); + (0x1083F,0x10855); + (0x10860,0x10876); + (0x10880,0x1089E); + (0x108E0,0x108F2); + (0x108F4,0x108F5); + (0x10900,0x10915); + (0x10920,0x10939); + (0x10980,0x109B7); + (0x109BE,0x109BF); + (0x10A00,0x10A00); + (0x10A10,0x10A13); + (0x10A15,0x10A17); + (0x10A19,0x10A33); + (0x10A60,0x10A7C); + (0x10A80,0x10A9C); + (0x10AC0,0x10AC7); + (0x10AC9,0x10AE4); + (0x10B00,0x10B35); + (0x10B40,0x10B55); + (0x10B60,0x10B72); + (0x10B80,0x10B91); + (0x10C00,0x10C48); + (0x11003,0x11037); + (0x11083,0x110AF); + (0x110D0,0x110E8); + (0x11103,0x11126); + (0x11150,0x11172); + (0x11176,0x11176); + (0x11183,0x111B2); + (0x111C1,0x111C4); + (0x111DA,0x111DA); + (0x111DC,0x111DC); + (0x11200,0x11211); + (0x11213,0x1122B); + (0x11280,0x11286); + (0x11288,0x11288); + (0x1128A,0x1128D); + (0x1128F,0x1129D); + (0x1129F,0x112A8); + (0x112B0,0x112DE); + (0x11305,0x1130C); + (0x1130F,0x11310); + (0x11313,0x11328); + (0x1132A,0x11330); + (0x11332,0x11333); + (0x11335,0x11339); + (0x1133D,0x1133D); + (0x11350,0x11350); + (0x1135D,0x11361); + (0x11400,0x11434); + (0x11447,0x1144A); + (0x11480,0x114AF); + (0x114C4,0x114C5); + (0x114C7,0x114C7); + (0x11580,0x115AE); + (0x115D8,0x115DB); + (0x11600,0x1162F); + (0x11644,0x11644); + (0x11680,0x116AA); + (0x11700,0x11719); + (0x118FF,0x118FF); + (0x11AC0,0x11AF8); + (0x11C00,0x11C08); + (0x11C0A,0x11C2E); + (0x11C40,0x11C40); + (0x11C72,0x11C8F); + (0x12000,0x12399); + (0x12480,0x12543); + (0x13000,0x1342E); + (0x14400,0x14646); + (0x16800,0x16A38); + (0x16A40,0x16A5E); + (0x16AD0,0x16AED); + (0x16B00,0x16B2F); + (0x16B63,0x16B77); + (0x16B7D,0x16B8F); + (0x16F00,0x16F44); + (0x16F50,0x16F50); + (0x17000,0x187EC); + (0x18800,0x18AF2); + (0x1B000,0x1B001); + (0x1BC00,0x1BC6A); + (0x1BC70,0x1BC7C); + (0x1BC80,0x1BC88); + (0x1BC90,0x1BC99); + (0x1E800,0x1E8C4); + (0x1EE00,0x1EE03); + (0x1EE05,0x1EE1F); + (0x1EE21,0x1EE22); + (0x1EE24,0x1EE24); + (0x1EE27,0x1EE27); + (0x1EE29,0x1EE32); + (0x1EE34,0x1EE37); + (0x1EE39,0x1EE39); + (0x1EE3B,0x1EE3B); + (0x1EE42,0x1EE42); + (0x1EE47,0x1EE47); + (0x1EE49,0x1EE49); + (0x1EE4B,0x1EE4B); + (0x1EE4D,0x1EE4F); + (0x1EE51,0x1EE52); + (0x1EE54,0x1EE54); + (0x1EE57,0x1EE57); + (0x1EE59,0x1EE59); + (0x1EE5B,0x1EE5B); + (0x1EE5D,0x1EE5D); + (0x1EE5F,0x1EE5F); + (0x1EE61,0x1EE62); + (0x1EE64,0x1EE64); + (0x1EE67,0x1EE6A); + (0x1EE6C,0x1EE72); + (0x1EE74,0x1EE77); + (0x1EE79,0x1EE7C); + (0x1EE7E,0x1EE7E); + (0x1EE80,0x1EE89); + (0x1EE8B,0x1EE9B); + (0x1EEA1,0x1EEA3); + (0x1EEA5,0x1EEA9); + (0x1EEAB,0x1EEBB); (0x20000,0x2A6D6); - (0x2F800,0x2FA1D) + (0x2A700,0x2B734); + (0x2B740,0x2B81D); + (0x2B820,0x2CEA1) ] (* Punctuation, Connector *) let pc = [ (0x0005F,0x0005F); (0x0203F,0x02040); - (0x030FB,0x030FB); + (0x02054,0x02054); (0x0FE33,0x0FE34); - (0x0FE4D,0x0FE4F); - (0x0FF3F,0x0FF3F); - (0x0FF65,0x0FF65) + (0x0FE4D,0x0FE4F) ] (* Punctuation, Dash *) let pd = [ (0x0002D,0x0002D); - (0x000AD,0x000AD); (0x0058A,0x0058A); + (0x005BE,0x005BE); + (0x01400,0x01400); (0x01806,0x01806); (0x02010,0x02015); + (0x02E17,0x02E17); + (0x02E1A,0x02E1A); + (0x02E3A,0x02E3B); + (0x02E40,0x02E40); (0x0301C,0x0301C); (0x03030,0x03030); (0x030A0,0x030A0); (0x0FE31,0x0FE32); (0x0FE58,0x0FE58); - (0x0FE63,0x0FE63); - (0x0FF0D,0x0FF0D) + (0x0FE63,0x0FE63) ] (* Punctuation, Open *) let ps = [ @@ -1787,8 +3095,9 @@ let ps = [ (0x02045,0x02045); (0x0207D,0x0207D); (0x0208D,0x0208D); + (0x02308,0x02308); + (0x0230A,0x0230A); (0x02329,0x02329); - (0x023B4,0x023B4); (0x02768,0x02768); (0x0276A,0x0276A); (0x0276C,0x0276C); @@ -1796,9 +3105,12 @@ let ps = [ (0x02770,0x02770); (0x02772,0x02772); (0x02774,0x02774); + (0x027C5,0x027C5); (0x027E6,0x027E6); (0x027E8,0x027E8); (0x027EA,0x027EA); + (0x027EC,0x027EC); + (0x027EE,0x027EE); (0x02983,0x02983); (0x02985,0x02985); (0x02987,0x02987); @@ -1813,6 +3125,11 @@ let ps = [ (0x029D8,0x029D8); (0x029DA,0x029DA); (0x029FC,0x029FC); + (0x02E22,0x02E22); + (0x02E24,0x02E24); + (0x02E26,0x02E26); + (0x02E28,0x02E28); + (0x02E42,0x02E42); (0x03008,0x03008); (0x0300A,0x0300A); (0x0300C,0x0300C); @@ -1823,7 +3140,8 @@ let ps = [ (0x03018,0x03018); (0x0301A,0x0301A); (0x0301D,0x0301D); - (0x0FD3E,0x0FD3E); + (0x0FD3F,0x0FD3F); + (0x0FE17,0x0FE17); (0x0FE35,0x0FE35); (0x0FE37,0x0FE37); (0x0FE39,0x0FE39); @@ -1832,14 +3150,14 @@ let ps = [ (0x0FE3F,0x0FE3F); (0x0FE41,0x0FE41); (0x0FE43,0x0FE43); + (0x0FE47,0x0FE47); (0x0FE59,0x0FE59); (0x0FE5B,0x0FE5B); (0x0FE5D,0x0FE5D); (0x0FF08,0x0FF08); (0x0FF3B,0x0FF3B); (0x0FF5B,0x0FF5B); - (0x0FF5F,0x0FF5F); - (0x0FF62,0x0FF62) + (0x0FF5F,0x0FF5F) ] (* Punctuation, Close *) let pe = [ @@ -1852,8 +3170,9 @@ let pe = [ (0x02046,0x02046); (0x0207E,0x0207E); (0x0208E,0x0208E); + (0x02309,0x02309); + (0x0230B,0x0230B); (0x0232A,0x0232A); - (0x023B5,0x023B5); (0x02769,0x02769); (0x0276B,0x0276B); (0x0276D,0x0276D); @@ -1861,9 +3180,12 @@ let pe = [ (0x02771,0x02771); (0x02773,0x02773); (0x02775,0x02775); + (0x027C6,0x027C6); (0x027E7,0x027E7); (0x027E9,0x027E9); (0x027EB,0x027EB); + (0x027ED,0x027ED); + (0x027EF,0x027EF); (0x02984,0x02984); (0x02986,0x02986); (0x02988,0x02988); @@ -1878,6 +3200,10 @@ let pe = [ (0x029D9,0x029D9); (0x029DB,0x029DB); (0x029FD,0x029FD); + (0x02E23,0x02E23); + (0x02E25,0x02E25); + (0x02E27,0x02E27); + (0x02E29,0x02E29); (0x03009,0x03009); (0x0300B,0x0300B); (0x0300D,0x0300D); @@ -1888,7 +3214,8 @@ let pe = [ (0x03019,0x03019); (0x0301B,0x0301B); (0x0301E,0x0301F); - (0x0FD3F,0x0FD3F); + (0x0FD3E,0x0FD3E); + (0x0FE18,0x0FE18); (0x0FE36,0x0FE36); (0x0FE38,0x0FE38); (0x0FE3A,0x0FE3A); @@ -1897,14 +3224,14 @@ let pe = [ (0x0FE40,0x0FE40); (0x0FE42,0x0FE42); (0x0FE44,0x0FE44); + (0x0FE48,0x0FE48); (0x0FE5A,0x0FE5A); (0x0FE5C,0x0FE5C); (0x0FE5E,0x0FE5E); (0x0FF09,0x0FF09); (0x0FF3D,0x0FF3D); (0x0FF5D,0x0FF5D); - (0x0FF60,0x0FF60); - (0x0FF63,0x0FF63) + (0x0FF60,0x0FF60) ] (* Punctuation, Initial quote *) let pi = [ @@ -1912,14 +3239,24 @@ let pi = [ (0x02018,0x02018); (0x0201B,0x0201C); (0x0201F,0x0201F); - (0x02039,0x02039) + (0x02039,0x02039); + (0x02E02,0x02E02); + (0x02E04,0x02E04); + (0x02E09,0x02E09); + (0x02E0C,0x02E0C); + (0x02E1C,0x02E1C) ] (* Punctuation, Final quote *) let pf = [ (0x000BB,0x000BB); (0x02019,0x02019); (0x0201D,0x0201D); - (0x0203A,0x0203A) + (0x0203A,0x0203A); + (0x02E03,0x02E03); + (0x02E05,0x02E05); + (0x02E0A,0x02E0A); + (0x02E0D,0x02E0D); + (0x02E1D,0x02E1D) ] (* Punctuation, Other *) let po = [ @@ -1932,32 +3269,41 @@ let po = [ (0x0003F,0x00040); (0x0005C,0x0005C); (0x000A1,0x000A1); - (0x000B7,0x000B7); + (0x000A7,0x000A7); + (0x000B6,0x000B7); (0x000BF,0x000BF); (0x0037E,0x0037E); (0x00387,0x00387); (0x0055A,0x0055F); (0x00589,0x00589); - (0x005BE,0x005BE); (0x005C0,0x005C0); (0x005C3,0x005C3); + (0x005C6,0x005C6); (0x005F3,0x005F4); - (0x0060C,0x0060C); + (0x00609,0x0060A); + (0x0060C,0x0060D); (0x0061B,0x0061B); - (0x0061F,0x0061F); + (0x0061E,0x0061F); (0x0066A,0x0066D); (0x006D4,0x006D4); (0x00700,0x0070D); + (0x007F7,0x007F9); + (0x00830,0x0083E); + (0x0085E,0x0085E); (0x00964,0x00965); (0x00970,0x00970); + (0x00AF0,0x00AF0); (0x00DF4,0x00DF4); (0x00E4F,0x00E4F); (0x00E5A,0x00E5B); (0x00F04,0x00F12); + (0x00F14,0x00F14); (0x00F85,0x00F85); + (0x00FD0,0x00FD4); + (0x00FD9,0x00FDA); (0x0104A,0x0104F); (0x010FB,0x010FB); - (0x01361,0x01368); + (0x01360,0x01368); (0x0166D,0x0166E); (0x016EB,0x016ED); (0x01735,0x01736); @@ -1965,16 +3311,61 @@ let po = [ (0x017D8,0x017DA); (0x01800,0x01805); (0x01807,0x0180A); + (0x01944,0x01945); + (0x01A1E,0x01A1F); + (0x01AA0,0x01AA6); + (0x01AA8,0x01AAD); + (0x01B5A,0x01B60); + (0x01BFC,0x01BFF); + (0x01C3B,0x01C3F); + (0x01C7E,0x01C7F); + (0x01CC0,0x01CC7); + (0x01CD3,0x01CD3); (0x02016,0x02017); (0x02020,0x02027); (0x02030,0x02038); (0x0203B,0x0203E); (0x02041,0x02043); (0x02047,0x02051); - (0x02057,0x02057); - (0x023B6,0x023B6); + (0x02053,0x02053); + (0x02055,0x0205E); + (0x02CF9,0x02CFC); + (0x02CFE,0x02CFF); + (0x02D70,0x02D70); + (0x02E00,0x02E01); + (0x02E06,0x02E08); + (0x02E0B,0x02E0B); + (0x02E0E,0x02E16); + (0x02E18,0x02E19); + (0x02E1B,0x02E1B); + (0x02E1E,0x02E1F); + (0x02E2A,0x02E2E); + (0x02E30,0x02E39); + (0x02E3C,0x02E3F); + (0x02E41,0x02E41); + (0x02E43,0x02E44); (0x03001,0x03003); (0x0303D,0x0303D); + (0x030FB,0x030FB); + (0x0A4FE,0x0A4FF); + (0x0A60D,0x0A60F); + (0x0A673,0x0A673); + (0x0A67E,0x0A67E); + (0x0A6F2,0x0A6F7); + (0x0A874,0x0A877); + (0x0A8CE,0x0A8CF); + (0x0A8F8,0x0A8FA); + (0x0A8FC,0x0A8FC); + (0x0A92E,0x0A92F); + (0x0A95F,0x0A95F); + (0x0A9C1,0x0A9CD); + (0x0A9DE,0x0A9DF); + (0x0AA5C,0x0AA5F); + (0x0AADE,0x0AADF); + (0x0AAF0,0x0AAF1); + (0x0ABEB,0x0ABEB); + (0x0FE10,0x0FE16); + (0x0FE19,0x0FE19); (0x0FE30,0x0FE30); (0x0FE45,0x0FE46); (0x0FE49,0x0FE4C); @@ -1992,7 +3383,47 @@ let po = [ (0x0FF1F,0x0FF20); (0x0FF3C,0x0FF3C); (0x0FF61,0x0FF61); - (0x0FF64,0x0FF64) + (0x0FF64,0x0FF65); + (0x10100,0x10102); + (0x1039F,0x1039F); + (0x103D0,0x103D0); + (0x1056F,0x1056F); + (0x10857,0x10857); + (0x1091F,0x1091F); + (0x1093F,0x1093F); + (0x10A50,0x10A58); + (0x10A7F,0x10A7F); + (0x10AF0,0x10AF6); + (0x10B39,0x10B3F); + (0x10B99,0x10B9C); + (0x11047,0x1104D); + (0x110BB,0x110BC); + (0x110BE,0x110C1); + (0x11140,0x11143); + (0x11174,0x11175); + (0x111C5,0x111C9); + (0x111CD,0x111CD); + (0x111DB,0x111DB); + (0x111DD,0x111DF); + (0x11238,0x1123D); + (0x112A9,0x112A9); + (0x1144B,0x1144F); + (0x1145B,0x1145B); + (0x1145D,0x1145D); + (0x114C6,0x114C6); + (0x115C1,0x115D7); + (0x11641,0x11643); + (0x11660,0x1166C); + (0x1173C,0x1173E); + (0x11C41,0x11C45); + (0x11C70,0x11C71); + (0x12470,0x12474); + (0x16A6E,0x16A6F); + (0x16AF5,0x16AF5); + (0x16B37,0x16B3B); + (0x16B44,0x16B44); + (0x1BC9F,0x1BC9F); + (0x1DA87,0x1DA8B) ] (* Symbol, Math *) let sm = [ @@ -2005,10 +3436,12 @@ let sm = [ (0x000D7,0x000D7); (0x000F7,0x000F7); (0x003F6,0x003F6); + (0x00606,0x00608); (0x02044,0x02044); (0x02052,0x02052); (0x0207A,0x0207C); (0x0208A,0x0208C); + (0x02118,0x02118); (0x02140,0x02144); (0x0214B,0x0214B); (0x02190,0x02194); @@ -2021,20 +3454,23 @@ let sm = [ (0x021D2,0x021D2); (0x021D4,0x021D4); (0x021F4,0x022FF); - (0x02308,0x0230B); (0x02320,0x02321); (0x0237C,0x0237C); (0x0239B,0x023B3); + (0x023DC,0x023E1); (0x025B7,0x025B7); (0x025C1,0x025C1); (0x025F8,0x025FF); (0x0266F,0x0266F); - (0x027D0,0x027E5); + (0x027C0,0x027C4); + (0x027C7,0x027E5); (0x027F0,0x027FF); (0x02900,0x02982); (0x02999,0x029D7); (0x029DC,0x029FB); (0x029FE,0x02AFF); + (0x02B30,0x02B44); + (0x02B47,0x02B4C); (0x0FB29,0x0FB29); (0x0FE62,0x0FE62); (0x0FE64,0x0FE66); @@ -2059,15 +3495,20 @@ let sm = [ let sc = [ (0x00024,0x00024); (0x000A2,0x000A5); + (0x0058F,0x0058F); + (0x0060B,0x0060B); (0x009F2,0x009F3); + (0x009FB,0x009FB); + (0x00AF1,0x00AF1); + (0x00BF9,0x00BF9); (0x00E3F,0x00E3F); (0x017DB,0x017DB); - (0x020A0,0x020B1); + (0x020A0,0x020BE); + (0x0A838,0x0A838); (0x0FDFC,0x0FDFC); (0x0FE69,0x0FE69); (0x0FF04,0x0FF04); - (0x0FFE0,0x0FFE1); - (0x0FFE5,0x0FFE6) + (0x0FFE0,0x0FFE1) ] (* Symbol, Modifier *) let sk = [ @@ -2077,11 +3518,12 @@ let sk = [ (0x000AF,0x000AF); (0x000B4,0x000B4); (0x000B8,0x000B8); - (0x002B9,0x002BA); - (0x002C2,0x002CF); + (0x002C2,0x002C5); (0x002D2,0x002DF); - (0x002E5,0x002ED); - (0x00374,0x00375); + (0x002E5,0x002EB); + (0x002ED,0x002ED); + (0x002EF,0x002FF); + (0x00375,0x00375); (0x00384,0x00385); (0x01FBD,0x01FBD); (0x01FBF,0x01FC1); @@ -2090,44 +3532,67 @@ let sk = [ (0x01FED,0x01FEF); (0x01FFD,0x01FFE); (0x0309B,0x0309C); + (0x0A700,0x0A716); + (0x0A720,0x0A721); + (0x0A789,0x0A78A); + (0x0AB5B,0x0AB5B); + (0x0FBB2,0x0FBC1); (0x0FF3E,0x0FF3E); (0x0FF40,0x0FF40); (0x0FFE3,0x0FFE3) ] (* Symbol, Other *) let so = [ - (0x000A6,0x000A7); + (0x000A6,0x000A6); (0x000A9,0x000A9); (0x000AE,0x000AE); (0x000B0,0x000B0); - (0x000B6,0x000B6); (0x00482,0x00482); + (0x0058D,0x0058E); + (0x0060E,0x0060F); + (0x006DE,0x006DE); (0x006E9,0x006E9); (0x006FD,0x006FE); + (0x007F6,0x007F6); (0x009FA,0x009FA); (0x00B70,0x00B70); + (0x00BF3,0x00BF8); + (0x00BFA,0x00BFA); + (0x00C7F,0x00C7F); + (0x00D4F,0x00D4F); + (0x00D79,0x00D79); (0x00F01,0x00F03); - (0x00F13,0x00F17); + (0x00F13,0x00F13); + (0x00F15,0x00F17); (0x00F1A,0x00F1F); (0x00F34,0x00F34); (0x00F36,0x00F36); (0x00F38,0x00F38); (0x00FBE,0x00FC5); (0x00FC7,0x00FCC); - (0x00FCF,0x00FCF); + (0x00FCE,0x00FCF); + (0x00FD5,0x00FD8); + (0x0109E,0x0109F); + (0x01390,0x01399); + (0x01940,0x01940); + (0x019DE,0x019FF); + (0x01B61,0x01B6A); + (0x01B74,0x01B7C); (0x02100,0x02101); (0x02103,0x02106); (0x02108,0x02109); (0x02114,0x02114); - (0x02116,0x02118); + (0x02116,0x02117); (0x0211E,0x02123); (0x02125,0x02125); (0x02127,0x02127); (0x02129,0x02129); (0x0212E,0x0212E); - (0x02132,0x02132); - (0x0213A,0x0213A); + (0x0213A,0x0213B); (0x0214A,0x0214A); + (0x0214C,0x0214D); + (0x0214F,0x0214F); + (0x0218A,0x0218B); (0x02195,0x02199); (0x0219C,0x0219F); (0x021A1,0x021A2); @@ -2142,31 +3607,27 @@ let so = [ (0x02322,0x02328); (0x0232B,0x0237B); (0x0237D,0x0239A); - (0x023B7,0x023CE); + (0x023B4,0x023DB); + (0x023E2,0x023FE); (0x02400,0x02426); (0x02440,0x0244A); (0x0249C,0x024E9); (0x02500,0x025B6); (0x025B8,0x025C0); (0x025C2,0x025F7); - (0x02600,0x02613); - (0x02616,0x02617); - (0x02619,0x0266E); - (0x02670,0x0267D); - (0x02680,0x02689); - (0x02701,0x02704); - (0x02706,0x02709); - (0x0270C,0x02727); - (0x02729,0x0274B); - (0x0274D,0x0274D); - (0x0274F,0x02752); - (0x02756,0x02756); - (0x02758,0x0275E); - (0x02761,0x02767); - (0x02794,0x02794); - (0x02798,0x027AF); - (0x027B1,0x027BE); + (0x02600,0x0266E); + (0x02670,0x02767); + (0x02794,0x027BF); (0x02800,0x028FF); + (0x02B00,0x02B2F); + (0x02B45,0x02B46); + (0x02B4D,0x02B73); + (0x02B76,0x02B95); + (0x02B98,0x02BB9); + (0x02BBD,0x02BC8); + (0x02BCA,0x02BD1); + (0x02BEC,0x02BEF); + (0x02CE5,0x02CEA); (0x02E80,0x02E99); (0x02E9B,0x02EF3); (0x02F00,0x02FD5); @@ -2178,31 +3639,84 @@ let so = [ (0x0303E,0x0303F); (0x03190,0x03191); (0x03196,0x0319F); - (0x03200,0x0321C); - (0x0322A,0x03243); - (0x03260,0x0327B); - (0x0327F,0x0327F); + (0x031C0,0x031E3); + (0x03200,0x0321E); + (0x0322A,0x03247); + (0x03250,0x03250); + (0x03260,0x0327F); (0x0328A,0x032B0); - (0x032C0,0x032CB); - (0x032D0,0x032FE); - (0x03300,0x03376); - (0x0337B,0x033DD); - (0x033E0,0x033FE); + (0x032C0,0x032FE); + (0x03300,0x033FF); + (0x04DC0,0x04DFF); (0x0A490,0x0A4C6); + (0x0A828,0x0A82B); + (0x0A836,0x0A837); + (0x0A839,0x0A839); + (0x0AA77,0x0AA79); + (0x0FDFD,0x0FDFD); (0x0FFE4,0x0FFE4); (0x0FFE8,0x0FFE8); (0x0FFED,0x0FFEE); (0x0FFFC,0x0FFFD); + (0x10137,0x1013F); + (0x10179,0x10189); + (0x1018C,0x1018E); + (0x10190,0x1019B); + (0x101A0,0x101A0); + (0x101D0,0x101FC); + (0x10877,0x10878); + (0x10AC8,0x10AC8); + (0x1173F,0x1173F); + (0x16B3C,0x16B3F); + (0x16B45,0x16B45); + (0x1BC9C,0x1BC9C); (0x1D000,0x1D0F5); (0x1D100,0x1D126); - (0x1D12A,0x1D164); + (0x1D129,0x1D164); (0x1D16A,0x1D16C); (0x1D183,0x1D184); (0x1D18C,0x1D1A9); - (0x1D1AE,0x1D1DD) + (0x1D1AE,0x1D1E8); + (0x1D200,0x1D241); + (0x1D245,0x1D245); + (0x1D300,0x1D356); + (0x1D800,0x1D9FF); + (0x1DA37,0x1DA3A); + (0x1DA6D,0x1DA74); + (0x1DA76,0x1DA83); + (0x1DA85,0x1DA86); + (0x1F000,0x1F02B); + (0x1F030,0x1F093); + (0x1F0A0,0x1F0AE); + (0x1F0B1,0x1F0BF); + (0x1F0C1,0x1F0CF); + (0x1F0D1,0x1F0F5); + (0x1F110,0x1F12E); + (0x1F130,0x1F16B); + (0x1F170,0x1F1AC); + (0x1F1E6,0x1F202); + (0x1F210,0x1F23B); + (0x1F240,0x1F248); + (0x1F250,0x1F251); + (0x1F300,0x1F3FA); + (0x1F400,0x1F6D2); + (0x1F6E0,0x1F6EC); + (0x1F6F0,0x1F6F6); + (0x1F700,0x1F773); + (0x1F780,0x1F7D4); + (0x1F800,0x1F80B); + (0x1F810,0x1F847); + (0x1F850,0x1F859); + (0x1F860,0x1F887); + (0x1F890,0x1F8AD); + (0x1F910,0x1F91E); + (0x1F920,0x1F927); + (0x1F930,0x1F930); + (0x1F933,0x1F93E); + (0x1F940,0x1F94B); + (0x1F950,0x1F95E); + (0x1F980,0x1F991) ] - -(* Conversion to lower case. *) let to_lower = [ (0x00041,0x0005A), `Delta (32); (0x000C0,0x000D6), `Delta (32); @@ -2358,12 +3872,31 @@ let to_lower = [ (0x0022E,0x0022E), `Abs (0x0022F); (0x00230,0x00230), `Abs (0x00231); (0x00232,0x00232), `Abs (0x00233); + (0x0023A,0x0023A), `Abs (0x02C65); + (0x0023B,0x0023B), `Abs (0x0023C); + (0x0023D,0x0023D), `Abs (0x0019A); + (0x0023E,0x0023E), `Abs (0x02C66); + (0x00241,0x00241), `Abs (0x00242); + (0x00243,0x00243), `Abs (0x00180); + (0x00244,0x00244), `Abs (0x00289); + (0x00245,0x00245), `Abs (0x0028C); + (0x00246,0x00246), `Abs (0x00247); + (0x00248,0x00248), `Abs (0x00249); + (0x0024A,0x0024A), `Abs (0x0024B); + (0x0024C,0x0024C), `Abs (0x0024D); + (0x0024E,0x0024E), `Abs (0x0024F); + (0x00370,0x00370), `Abs (0x00371); + (0x00372,0x00372), `Abs (0x00373); + (0x00376,0x00376), `Abs (0x00377); + (0x0037F,0x0037F), `Abs (0x003F3); (0x00386,0x00386), `Abs (0x003AC); (0x00388,0x0038A), `Delta (37); (0x0038C,0x0038C), `Abs (0x003CC); (0x0038E,0x0038F), `Delta (63); (0x00391,0x003A1), `Delta (32); (0x003A3,0x003AB), `Delta (32); + (0x003CF,0x003CF), `Abs (0x003D7); + (0x003D2,0x003D4), `Delta (0); (0x003D8,0x003D8), `Abs (0x003D9); (0x003DA,0x003DA), `Abs (0x003DB); (0x003DC,0x003DC), `Abs (0x003DD); @@ -2377,6 +3910,10 @@ let to_lower = [ (0x003EC,0x003EC), `Abs (0x003ED); (0x003EE,0x003EE), `Abs (0x003EF); (0x003F4,0x003F4), `Abs (0x003B8); + (0x003F7,0x003F7), `Abs (0x003F8); + (0x003F9,0x003F9), `Abs (0x003F2); + (0x003FA,0x003FA), `Abs (0x003FB); + (0x003FD,0x003FF), `Delta (-130); (0x00400,0x0040F), `Delta (80); (0x00410,0x0042F), `Delta (32); (0x00460,0x00460), `Abs (0x00461); @@ -2423,6 +3960,7 @@ let to_lower = [ (0x004BA,0x004BA), `Abs (0x004BB); (0x004BC,0x004BC), `Abs (0x004BD); (0x004BE,0x004BE), `Abs (0x004BF); + (0x004C0,0x004C0), `Abs (0x004CF); (0x004C1,0x004C1), `Abs (0x004C2); (0x004C3,0x004C3), `Abs (0x004C4); (0x004C5,0x004C5), `Abs (0x004C6); @@ -2449,7 +3987,11 @@ let to_lower = [ (0x004F0,0x004F0), `Abs (0x004F1); (0x004F2,0x004F2), `Abs (0x004F3); (0x004F4,0x004F4), `Abs (0x004F5); + (0x004F6,0x004F6), `Abs (0x004F7); (0x004F8,0x004F8), `Abs (0x004F9); + (0x004FA,0x004FA), `Abs (0x004FB); + (0x004FC,0x004FC), `Abs (0x004FD); + (0x004FE,0x004FE), `Abs (0x004FF); (0x00500,0x00500), `Abs (0x00501); (0x00502,0x00502), `Abs (0x00503); (0x00504,0x00504), `Abs (0x00505); @@ -2458,7 +4000,28 @@ let to_lower = [ (0x0050A,0x0050A), `Abs (0x0050B); (0x0050C,0x0050C), `Abs (0x0050D); (0x0050E,0x0050E), `Abs (0x0050F); + (0x00510,0x00510), `Abs (0x00511); + (0x00512,0x00512), `Abs (0x00513); + (0x00514,0x00514), `Abs (0x00515); + (0x00516,0x00516), `Abs (0x00517); + (0x00518,0x00518), `Abs (0x00519); + (0x0051A,0x0051A), `Abs (0x0051B); + (0x0051C,0x0051C), `Abs (0x0051D); + (0x0051E,0x0051E), `Abs (0x0051F); + (0x00520,0x00520), `Abs (0x00521); + (0x00522,0x00522), `Abs (0x00523); + (0x00524,0x00524), `Abs (0x00525); + (0x00526,0x00526), `Abs (0x00527); + (0x00528,0x00528), `Abs (0x00529); + (0x0052A,0x0052A), `Abs (0x0052B); + (0x0052C,0x0052C), `Abs (0x0052D); + (0x0052E,0x0052E), `Abs (0x0052F); (0x00531,0x00556), `Delta (48); + (0x010A0,0x010C5), `Delta (7264); + (0x010C7,0x010C7), `Abs (0x02D27); + (0x010CD,0x010CD), `Abs (0x02D2D); + (0x013A0,0x013EF), `Delta (38864); + (0x013F0,0x013F5), `Delta (8); (0x01E00,0x01E00), `Abs (0x01E01); (0x01E02,0x01E02), `Abs (0x01E03); (0x01E04,0x01E04), `Abs (0x01E05); @@ -2534,6 +4097,7 @@ let to_lower = [ (0x01E90,0x01E90), `Abs (0x01E91); (0x01E92,0x01E92), `Abs (0x01E93); (0x01E94,0x01E94), `Abs (0x01E95); + (0x01E9E,0x01E9E), `Abs (0x000DF); (0x01EA0,0x01EA0), `Abs (0x01EA1); (0x01EA2,0x01EA2), `Abs (0x01EA3); (0x01EA4,0x01EA4), `Abs (0x01EA5); @@ -2579,6 +4143,9 @@ let to_lower = [ (0x01EF4,0x01EF4), `Abs (0x01EF5); (0x01EF6,0x01EF6), `Abs (0x01EF7); (0x01EF8,0x01EF8), `Abs (0x01EF9); + (0x01EFA,0x01EFA), `Abs (0x01EFB); + (0x01EFC,0x01EFC), `Abs (0x01EFD); + (0x01EFE,0x01EFE), `Abs (0x01EFF); (0x01F08,0x01F0F), `Delta (-8); (0x01F18,0x01F1D), `Delta (-8); (0x01F28,0x01F2F), `Delta (-8); @@ -2599,11 +4166,870 @@ let to_lower = [ (0x01FEC,0x01FEC), `Abs (0x01FE5); (0x01FF8,0x01FF9), `Delta (-128); (0x01FFA,0x01FFB), `Delta (-126); + (0x02102,0x02102), `Abs (0x02102); + (0x02107,0x02107), `Abs (0x02107); + (0x0210B,0x0210D), `Delta (0); + (0x02110,0x02112), `Delta (0); + (0x02115,0x02115), `Abs (0x02115); + (0x02119,0x0211D), `Delta (0); + (0x02124,0x02124), `Abs (0x02124); (0x02126,0x02126), `Abs (0x003C9); + (0x02128,0x02128), `Abs (0x02128); (0x0212A,0x0212A), `Abs (0x0006B); (0x0212B,0x0212B), `Abs (0x000E5); + (0x0212C,0x0212D), `Delta (0); + (0x02130,0x02131), `Delta (0); + (0x02132,0x02132), `Abs (0x0214E); + (0x02133,0x02133), `Abs (0x02133); + (0x0213E,0x0213F), `Delta (0); + (0x02145,0x02145), `Abs (0x02145); + (0x02183,0x02183), `Abs (0x02184); + (0x02C00,0x02C2E), `Delta (48); + (0x02C60,0x02C60), `Abs (0x02C61); + (0x02C62,0x02C62), `Abs (0x0026B); + (0x02C63,0x02C63), `Abs (0x01D7D); + (0x02C64,0x02C64), `Abs (0x0027D); + (0x02C67,0x02C67), `Abs (0x02C68); + (0x02C69,0x02C69), `Abs (0x02C6A); + (0x02C6B,0x02C6B), `Abs (0x02C6C); + (0x02C6D,0x02C6D), `Abs (0x00251); + (0x02C6E,0x02C6E), `Abs (0x00271); + (0x02C6F,0x02C6F), `Abs (0x00250); + (0x02C70,0x02C70), `Abs (0x00252); + (0x02C72,0x02C72), `Abs (0x02C73); + (0x02C75,0x02C75), `Abs (0x02C76); + (0x02C7E,0x02C7F), `Delta (-10815); + (0x02C80,0x02C80), `Abs (0x02C81); + (0x02C82,0x02C82), `Abs (0x02C83); + (0x02C84,0x02C84), `Abs (0x02C85); + (0x02C86,0x02C86), `Abs (0x02C87); + (0x02C88,0x02C88), `Abs (0x02C89); + (0x02C8A,0x02C8A), `Abs (0x02C8B); + (0x02C8C,0x02C8C), `Abs (0x02C8D); + (0x02C8E,0x02C8E), `Abs (0x02C8F); + (0x02C90,0x02C90), `Abs (0x02C91); + (0x02C92,0x02C92), `Abs (0x02C93); + (0x02C94,0x02C94), `Abs (0x02C95); + (0x02C96,0x02C96), `Abs (0x02C97); + (0x02C98,0x02C98), `Abs (0x02C99); + (0x02C9A,0x02C9A), `Abs (0x02C9B); + (0x02C9C,0x02C9C), `Abs (0x02C9D); + (0x02C9E,0x02C9E), `Abs (0x02C9F); + (0x02CA0,0x02CA0), `Abs (0x02CA1); + (0x02CA2,0x02CA2), `Abs (0x02CA3); + (0x02CA4,0x02CA4), `Abs (0x02CA5); + (0x02CA6,0x02CA6), `Abs (0x02CA7); + (0x02CA8,0x02CA8), `Abs (0x02CA9); + (0x02CAA,0x02CAA), `Abs (0x02CAB); + (0x02CAC,0x02CAC), `Abs (0x02CAD); + (0x02CAE,0x02CAE), `Abs (0x02CAF); + (0x02CB0,0x02CB0), `Abs (0x02CB1); + (0x02CB2,0x02CB2), `Abs (0x02CB3); + (0x02CB4,0x02CB4), `Abs (0x02CB5); + (0x02CB6,0x02CB6), `Abs (0x02CB7); + (0x02CB8,0x02CB8), `Abs (0x02CB9); + (0x02CBA,0x02CBA), `Abs (0x02CBB); + (0x02CBC,0x02CBC), `Abs (0x02CBD); + (0x02CBE,0x02CBE), `Abs (0x02CBF); + (0x02CC0,0x02CC0), `Abs (0x02CC1); + (0x02CC2,0x02CC2), `Abs (0x02CC3); + (0x02CC4,0x02CC4), `Abs (0x02CC5); + (0x02CC6,0x02CC6), `Abs (0x02CC7); + (0x02CC8,0x02CC8), `Abs (0x02CC9); + (0x02CCA,0x02CCA), `Abs (0x02CCB); + (0x02CCC,0x02CCC), `Abs (0x02CCD); + (0x02CCE,0x02CCE), `Abs (0x02CCF); + (0x02CD0,0x02CD0), `Abs (0x02CD1); + (0x02CD2,0x02CD2), `Abs (0x02CD3); + (0x02CD4,0x02CD4), `Abs (0x02CD5); + (0x02CD6,0x02CD6), `Abs (0x02CD7); + (0x02CD8,0x02CD8), `Abs (0x02CD9); + (0x02CDA,0x02CDA), `Abs (0x02CDB); + (0x02CDC,0x02CDC), `Abs (0x02CDD); + (0x02CDE,0x02CDE), `Abs (0x02CDF); + (0x02CE0,0x02CE0), `Abs (0x02CE1); + (0x02CE2,0x02CE2), `Abs (0x02CE3); + (0x02CEB,0x02CEB), `Abs (0x02CEC); + (0x02CED,0x02CED), `Abs (0x02CEE); + (0x02CF2,0x02CF2), `Abs (0x02CF3); + (0x0A640,0x0A640), `Abs (0x0A641); + (0x0A642,0x0A642), `Abs (0x0A643); + (0x0A644,0x0A644), `Abs (0x0A645); + (0x0A646,0x0A646), `Abs (0x0A647); + (0x0A648,0x0A648), `Abs (0x0A649); + (0x0A64A,0x0A64A), `Abs (0x0A64B); + (0x0A64C,0x0A64C), `Abs (0x0A64D); + (0x0A64E,0x0A64E), `Abs (0x0A64F); + (0x0A650,0x0A650), `Abs (0x0A651); + (0x0A652,0x0A652), `Abs (0x0A653); + (0x0A654,0x0A654), `Abs (0x0A655); + (0x0A656,0x0A656), `Abs (0x0A657); + (0x0A658,0x0A658), `Abs (0x0A659); + (0x0A65A,0x0A65A), `Abs (0x0A65B); + (0x0A65C,0x0A65C), `Abs (0x0A65D); + (0x0A65E,0x0A65E), `Abs (0x0A65F); + (0x0A660,0x0A660), `Abs (0x0A661); + (0x0A662,0x0A662), `Abs (0x0A663); + (0x0A664,0x0A664), `Abs (0x0A665); + (0x0A666,0x0A666), `Abs (0x0A667); + (0x0A668,0x0A668), `Abs (0x0A669); + (0x0A66A,0x0A66A), `Abs (0x0A66B); + (0x0A66C,0x0A66C), `Abs (0x0A66D); + (0x0A680,0x0A680), `Abs (0x0A681); + (0x0A682,0x0A682), `Abs (0x0A683); + (0x0A684,0x0A684), `Abs (0x0A685); + (0x0A686,0x0A686), `Abs (0x0A687); + (0x0A688,0x0A688), `Abs (0x0A689); + (0x0A68A,0x0A68A), `Abs (0x0A68B); + (0x0A68C,0x0A68C), `Abs (0x0A68D); + (0x0A68E,0x0A68E), `Abs (0x0A68F); + (0x0A690,0x0A690), `Abs (0x0A691); + (0x0A692,0x0A692), `Abs (0x0A693); + (0x0A694,0x0A694), `Abs (0x0A695); + (0x0A696,0x0A696), `Abs (0x0A697); + (0x0A698,0x0A698), `Abs (0x0A699); + (0x0A69A,0x0A69A), `Abs (0x0A69B); + (0x0A722,0x0A722), `Abs (0x0A723); + (0x0A724,0x0A724), `Abs (0x0A725); + (0x0A726,0x0A726), `Abs (0x0A727); + (0x0A728,0x0A728), `Abs (0x0A729); + (0x0A72A,0x0A72A), `Abs (0x0A72B); + (0x0A72C,0x0A72C), `Abs (0x0A72D); + (0x0A72E,0x0A72E), `Abs (0x0A72F); + (0x0A732,0x0A732), `Abs (0x0A733); + (0x0A734,0x0A734), `Abs (0x0A735); + (0x0A736,0x0A736), `Abs (0x0A737); + (0x0A738,0x0A738), `Abs (0x0A739); + (0x0A73A,0x0A73A), `Abs (0x0A73B); + (0x0A73C,0x0A73C), `Abs (0x0A73D); + (0x0A73E,0x0A73E), `Abs (0x0A73F); + (0x0A740,0x0A740), `Abs (0x0A741); + (0x0A742,0x0A742), `Abs (0x0A743); + (0x0A744,0x0A744), `Abs (0x0A745); + (0x0A746,0x0A746), `Abs (0x0A747); + (0x0A748,0x0A748), `Abs (0x0A749); + (0x0A74A,0x0A74A), `Abs (0x0A74B); + (0x0A74C,0x0A74C), `Abs (0x0A74D); + (0x0A74E,0x0A74E), `Abs (0x0A74F); + (0x0A750,0x0A750), `Abs (0x0A751); + (0x0A752,0x0A752), `Abs (0x0A753); + (0x0A754,0x0A754), `Abs (0x0A755); + (0x0A756,0x0A756), `Abs (0x0A757); + (0x0A758,0x0A758), `Abs (0x0A759); + (0x0A75A,0x0A75A), `Abs (0x0A75B); + (0x0A75C,0x0A75C), `Abs (0x0A75D); + (0x0A75E,0x0A75E), `Abs (0x0A75F); + (0x0A760,0x0A760), `Abs (0x0A761); + (0x0A762,0x0A762), `Abs (0x0A763); + (0x0A764,0x0A764), `Abs (0x0A765); + (0x0A766,0x0A766), `Abs (0x0A767); + (0x0A768,0x0A768), `Abs (0x0A769); + (0x0A76A,0x0A76A), `Abs (0x0A76B); + (0x0A76C,0x0A76C), `Abs (0x0A76D); + (0x0A76E,0x0A76E), `Abs (0x0A76F); + (0x0A779,0x0A779), `Abs (0x0A77A); + (0x0A77B,0x0A77B), `Abs (0x0A77C); + (0x0A77D,0x0A77D), `Abs (0x01D79); + (0x0A77E,0x0A77E), `Abs (0x0A77F); + (0x0A780,0x0A780), `Abs (0x0A781); + (0x0A782,0x0A782), `Abs (0x0A783); + (0x0A784,0x0A784), `Abs (0x0A785); + (0x0A786,0x0A786), `Abs (0x0A787); + (0x0A78B,0x0A78B), `Abs (0x0A78C); + (0x0A78D,0x0A78D), `Abs (0x00265); + (0x0A790,0x0A790), `Abs (0x0A791); + (0x0A792,0x0A792), `Abs (0x0A793); + (0x0A796,0x0A796), `Abs (0x0A797); + (0x0A798,0x0A798), `Abs (0x0A799); + (0x0A79A,0x0A79A), `Abs (0x0A79B); + (0x0A79C,0x0A79C), `Abs (0x0A79D); + (0x0A79E,0x0A79E), `Abs (0x0A79F); + (0x0A7A0,0x0A7A0), `Abs (0x0A7A1); + (0x0A7A2,0x0A7A2), `Abs (0x0A7A3); + (0x0A7A4,0x0A7A4), `Abs (0x0A7A5); + (0x0A7A6,0x0A7A6), `Abs (0x0A7A7); + (0x0A7A8,0x0A7A8), `Abs (0x0A7A9); + (0x0A7AA,0x0A7AA), `Abs (0x00266); + (0x0A7AB,0x0A7AB), `Abs (0x0025C); + (0x0A7AC,0x0A7AC), `Abs (0x00261); + (0x0A7AD,0x0A7AD), `Abs (0x0026C); + (0x0A7AE,0x0A7AE), `Abs (0x0026A); + (0x0A7B0,0x0A7B0), `Abs (0x0029E); + (0x0A7B1,0x0A7B1), `Abs (0x00287); + (0x0A7B2,0x0A7B2), `Abs (0x0029D); + (0x0A7B3,0x0A7B3), `Abs (0x0AB53); + (0x0A7B4,0x0A7B4), `Abs (0x0A7B5); + (0x0A7B6,0x0A7B6), `Abs (0x0A7B7); (0x0FF21,0x0FF3A), `Delta (32); - (0x10400,0x10425), `Delta (40); + (0x10400,0x10427), `Delta (40); + (0x104B0,0x104D3), `Delta (40); + (0x10C80,0x10CB2), `Delta (64); + (0x118A0,0x118BF), `Delta (32); + (0x1D400,0x1D419), `Delta (0); + (0x1D434,0x1D44D), `Delta (0); + (0x1D468,0x1D481), `Delta (0); + (0x1D49C,0x1D49C), `Abs (0x1D49C); + (0x1D49E,0x1D49F), `Delta (0); + (0x1D4A2,0x1D4A2), `Abs (0x1D4A2); + (0x1D4A5,0x1D4A6), `Delta (0); + (0x1D4A9,0x1D4AC), `Delta (0); + (0x1D4AE,0x1D4B5), `Delta (0); + (0x1D4D0,0x1D4E9), `Delta (0); + (0x1D504,0x1D505), `Delta (0); + (0x1D507,0x1D50A), `Delta (0); + (0x1D50D,0x1D514), `Delta (0); + (0x1D516,0x1D51C), `Delta (0); + (0x1D538,0x1D539), `Delta (0); + (0x1D53B,0x1D53E), `Delta (0); + (0x1D540,0x1D544), `Delta (0); + (0x1D546,0x1D546), `Abs (0x1D546); + (0x1D54A,0x1D550), `Delta (0); + (0x1D56C,0x1D585), `Delta (0); + (0x1D5A0,0x1D5B9), `Delta (0); + (0x1D5D4,0x1D5ED), `Delta (0); + (0x1D608,0x1D621), `Delta (0); + (0x1D63C,0x1D655), `Delta (0); + (0x1D670,0x1D689), `Delta (0); + (0x1D6A8,0x1D6C0), `Delta (0); + (0x1D6E2,0x1D6FA), `Delta (0); + (0x1D71C,0x1D734), `Delta (0); + (0x1D756,0x1D76E), `Delta (0); + (0x1D790,0x1D7A8), `Delta (0); + (0x1D7CA,0x1D7CA), `Abs (0x1D7CA); + (0x1E900,0x1E921), `Delta (34); + (0x00061,0x0007A), `Delta (0); + (0x000B5,0x000B5), `Abs (0x000B5); + (0x000DF,0x000F6), `Delta (0); + (0x000F8,0x000FF), `Delta (0); + (0x00101,0x00101), `Abs (0x00101); + (0x00103,0x00103), `Abs (0x00103); + (0x00105,0x00105), `Abs (0x00105); + (0x00107,0x00107), `Abs (0x00107); + (0x00109,0x00109), `Abs (0x00109); + (0x0010B,0x0010B), `Abs (0x0010B); + (0x0010D,0x0010D), `Abs (0x0010D); + (0x0010F,0x0010F), `Abs (0x0010F); + (0x00111,0x00111), `Abs (0x00111); + (0x00113,0x00113), `Abs (0x00113); + (0x00115,0x00115), `Abs (0x00115); + (0x00117,0x00117), `Abs (0x00117); + (0x00119,0x00119), `Abs (0x00119); + (0x0011B,0x0011B), `Abs (0x0011B); + (0x0011D,0x0011D), `Abs (0x0011D); + (0x0011F,0x0011F), `Abs (0x0011F); + (0x00121,0x00121), `Abs (0x00121); + (0x00123,0x00123), `Abs (0x00123); + (0x00125,0x00125), `Abs (0x00125); + (0x00127,0x00127), `Abs (0x00127); + (0x00129,0x00129), `Abs (0x00129); + (0x0012B,0x0012B), `Abs (0x0012B); + (0x0012D,0x0012D), `Abs (0x0012D); + (0x0012F,0x0012F), `Abs (0x0012F); + (0x00131,0x00131), `Abs (0x00131); + (0x00133,0x00133), `Abs (0x00133); + (0x00135,0x00135), `Abs (0x00135); + (0x00137,0x00138), `Delta (0); + (0x0013A,0x0013A), `Abs (0x0013A); + (0x0013C,0x0013C), `Abs (0x0013C); + (0x0013E,0x0013E), `Abs (0x0013E); + (0x00140,0x00140), `Abs (0x00140); + (0x00142,0x00142), `Abs (0x00142); + (0x00144,0x00144), `Abs (0x00144); + (0x00146,0x00146), `Abs (0x00146); + (0x00148,0x00149), `Delta (0); + (0x0014B,0x0014B), `Abs (0x0014B); + (0x0014D,0x0014D), `Abs (0x0014D); + (0x0014F,0x0014F), `Abs (0x0014F); + (0x00151,0x00151), `Abs (0x00151); + (0x00153,0x00153), `Abs (0x00153); + (0x00155,0x00155), `Abs (0x00155); + (0x00157,0x00157), `Abs (0x00157); + (0x00159,0x00159), `Abs (0x00159); + (0x0015B,0x0015B), `Abs (0x0015B); + (0x0015D,0x0015D), `Abs (0x0015D); + (0x0015F,0x0015F), `Abs (0x0015F); + (0x00161,0x00161), `Abs (0x00161); + (0x00163,0x00163), `Abs (0x00163); + (0x00165,0x00165), `Abs (0x00165); + (0x00167,0x00167), `Abs (0x00167); + (0x00169,0x00169), `Abs (0x00169); + (0x0016B,0x0016B), `Abs (0x0016B); + (0x0016D,0x0016D), `Abs (0x0016D); + (0x0016F,0x0016F), `Abs (0x0016F); + (0x00171,0x00171), `Abs (0x00171); + (0x00173,0x00173), `Abs (0x00173); + (0x00175,0x00175), `Abs (0x00175); + (0x00177,0x00177), `Abs (0x00177); + (0x0017A,0x0017A), `Abs (0x0017A); + (0x0017C,0x0017C), `Abs (0x0017C); + (0x0017E,0x00180), `Delta (0); + (0x00183,0x00183), `Abs (0x00183); + (0x00185,0x00185), `Abs (0x00185); + (0x00188,0x00188), `Abs (0x00188); + (0x0018C,0x0018D), `Delta (0); + (0x00192,0x00192), `Abs (0x00192); + (0x00195,0x00195), `Abs (0x00195); + (0x00199,0x0019B), `Delta (0); + (0x0019E,0x0019E), `Abs (0x0019E); + (0x001A1,0x001A1), `Abs (0x001A1); + (0x001A3,0x001A3), `Abs (0x001A3); + (0x001A5,0x001A5), `Abs (0x001A5); + (0x001A8,0x001A8), `Abs (0x001A8); + (0x001AA,0x001AB), `Delta (0); + (0x001AD,0x001AD), `Abs (0x001AD); + (0x001B0,0x001B0), `Abs (0x001B0); + (0x001B4,0x001B4), `Abs (0x001B4); + (0x001B6,0x001B6), `Abs (0x001B6); + (0x001B9,0x001BA), `Delta (0); + (0x001BD,0x001BF), `Delta (0); + (0x001C6,0x001C6), `Abs (0x001C6); + (0x001C9,0x001C9), `Abs (0x001C9); + (0x001CC,0x001CC), `Abs (0x001CC); + (0x001CE,0x001CE), `Abs (0x001CE); + (0x001D0,0x001D0), `Abs (0x001D0); + (0x001D2,0x001D2), `Abs (0x001D2); + (0x001D4,0x001D4), `Abs (0x001D4); + (0x001D6,0x001D6), `Abs (0x001D6); + (0x001D8,0x001D8), `Abs (0x001D8); + (0x001DA,0x001DA), `Abs (0x001DA); + (0x001DC,0x001DD), `Delta (0); + (0x001DF,0x001DF), `Abs (0x001DF); + (0x001E1,0x001E1), `Abs (0x001E1); + (0x001E3,0x001E3), `Abs (0x001E3); + (0x001E5,0x001E5), `Abs (0x001E5); + (0x001E7,0x001E7), `Abs (0x001E7); + (0x001E9,0x001E9), `Abs (0x001E9); + (0x001EB,0x001EB), `Abs (0x001EB); + (0x001ED,0x001ED), `Abs (0x001ED); + (0x001EF,0x001F0), `Delta (0); + (0x001F3,0x001F3), `Abs (0x001F3); + (0x001F5,0x001F5), `Abs (0x001F5); + (0x001F9,0x001F9), `Abs (0x001F9); + (0x001FB,0x001FB), `Abs (0x001FB); + (0x001FD,0x001FD), `Abs (0x001FD); + (0x001FF,0x001FF), `Abs (0x001FF); + (0x00201,0x00201), `Abs (0x00201); + (0x00203,0x00203), `Abs (0x00203); + (0x00205,0x00205), `Abs (0x00205); + (0x00207,0x00207), `Abs (0x00207); + (0x00209,0x00209), `Abs (0x00209); + (0x0020B,0x0020B), `Abs (0x0020B); + (0x0020D,0x0020D), `Abs (0x0020D); + (0x0020F,0x0020F), `Abs (0x0020F); + (0x00211,0x00211), `Abs (0x00211); + (0x00213,0x00213), `Abs (0x00213); + (0x00215,0x00215), `Abs (0x00215); + (0x00217,0x00217), `Abs (0x00217); + (0x00219,0x00219), `Abs (0x00219); + (0x0021B,0x0021B), `Abs (0x0021B); + (0x0021D,0x0021D), `Abs (0x0021D); + (0x0021F,0x0021F), `Abs (0x0021F); + (0x00221,0x00221), `Abs (0x00221); + (0x00223,0x00223), `Abs (0x00223); + (0x00225,0x00225), `Abs (0x00225); + (0x00227,0x00227), `Abs (0x00227); + (0x00229,0x00229), `Abs (0x00229); + (0x0022B,0x0022B), `Abs (0x0022B); + (0x0022D,0x0022D), `Abs (0x0022D); + (0x0022F,0x0022F), `Abs (0x0022F); + (0x00231,0x00231), `Abs (0x00231); + (0x00233,0x00239), `Delta (0); + (0x0023C,0x0023C), `Abs (0x0023C); + (0x0023F,0x00240), `Delta (0); + (0x00242,0x00242), `Abs (0x00242); + (0x00247,0x00247), `Abs (0x00247); + (0x00249,0x00249), `Abs (0x00249); + (0x0024B,0x0024B), `Abs (0x0024B); + (0x0024D,0x0024D), `Abs (0x0024D); + (0x0024F,0x00293), `Delta (0); + (0x00295,0x002AF), `Delta (0); + (0x00371,0x00371), `Abs (0x00371); + (0x00373,0x00373), `Abs (0x00373); + (0x00377,0x00377), `Abs (0x00377); + (0x0037B,0x0037D), `Delta (0); + (0x00390,0x00390), `Abs (0x00390); + (0x003AC,0x003CE), `Delta (0); + (0x003D0,0x003D1), `Delta (0); + (0x003D5,0x003D7), `Delta (0); + (0x003D9,0x003D9), `Abs (0x003D9); + (0x003DB,0x003DB), `Abs (0x003DB); + (0x003DD,0x003DD), `Abs (0x003DD); + (0x003DF,0x003DF), `Abs (0x003DF); + (0x003E1,0x003E1), `Abs (0x003E1); + (0x003E3,0x003E3), `Abs (0x003E3); + (0x003E5,0x003E5), `Abs (0x003E5); + (0x003E7,0x003E7), `Abs (0x003E7); + (0x003E9,0x003E9), `Abs (0x003E9); + (0x003EB,0x003EB), `Abs (0x003EB); + (0x003ED,0x003ED), `Abs (0x003ED); + (0x003EF,0x003F3), `Delta (0); + (0x003F5,0x003F5), `Abs (0x003F5); + (0x003F8,0x003F8), `Abs (0x003F8); + (0x003FB,0x003FC), `Delta (0); + (0x00430,0x0045F), `Delta (0); + (0x00461,0x00461), `Abs (0x00461); + (0x00463,0x00463), `Abs (0x00463); + (0x00465,0x00465), `Abs (0x00465); + (0x00467,0x00467), `Abs (0x00467); + (0x00469,0x00469), `Abs (0x00469); + (0x0046B,0x0046B), `Abs (0x0046B); + (0x0046D,0x0046D), `Abs (0x0046D); + (0x0046F,0x0046F), `Abs (0x0046F); + (0x00471,0x00471), `Abs (0x00471); + (0x00473,0x00473), `Abs (0x00473); + (0x00475,0x00475), `Abs (0x00475); + (0x00477,0x00477), `Abs (0x00477); + (0x00479,0x00479), `Abs (0x00479); + (0x0047B,0x0047B), `Abs (0x0047B); + (0x0047D,0x0047D), `Abs (0x0047D); + (0x0047F,0x0047F), `Abs (0x0047F); + (0x00481,0x00481), `Abs (0x00481); + (0x0048B,0x0048B), `Abs (0x0048B); + (0x0048D,0x0048D), `Abs (0x0048D); + (0x0048F,0x0048F), `Abs (0x0048F); + (0x00491,0x00491), `Abs (0x00491); + (0x00493,0x00493), `Abs (0x00493); + (0x00495,0x00495), `Abs (0x00495); + (0x00497,0x00497), `Abs (0x00497); + (0x00499,0x00499), `Abs (0x00499); + (0x0049B,0x0049B), `Abs (0x0049B); + (0x0049D,0x0049D), `Abs (0x0049D); + (0x0049F,0x0049F), `Abs (0x0049F); + (0x004A1,0x004A1), `Abs (0x004A1); + (0x004A3,0x004A3), `Abs (0x004A3); + (0x004A5,0x004A5), `Abs (0x004A5); + (0x004A7,0x004A7), `Abs (0x004A7); + (0x004A9,0x004A9), `Abs (0x004A9); + (0x004AB,0x004AB), `Abs (0x004AB); + (0x004AD,0x004AD), `Abs (0x004AD); + (0x004AF,0x004AF), `Abs (0x004AF); + (0x004B1,0x004B1), `Abs (0x004B1); + (0x004B3,0x004B3), `Abs (0x004B3); + (0x004B5,0x004B5), `Abs (0x004B5); + (0x004B7,0x004B7), `Abs (0x004B7); + (0x004B9,0x004B9), `Abs (0x004B9); + (0x004BB,0x004BB), `Abs (0x004BB); + (0x004BD,0x004BD), `Abs (0x004BD); + (0x004BF,0x004BF), `Abs (0x004BF); + (0x004C2,0x004C2), `Abs (0x004C2); + (0x004C4,0x004C4), `Abs (0x004C4); + (0x004C6,0x004C6), `Abs (0x004C6); + (0x004C8,0x004C8), `Abs (0x004C8); + (0x004CA,0x004CA), `Abs (0x004CA); + (0x004CC,0x004CC), `Abs (0x004CC); + (0x004CE,0x004CF), `Delta (0); + (0x004D1,0x004D1), `Abs (0x004D1); + (0x004D3,0x004D3), `Abs (0x004D3); + (0x004D5,0x004D5), `Abs (0x004D5); + (0x004D7,0x004D7), `Abs (0x004D7); + (0x004D9,0x004D9), `Abs (0x004D9); + (0x004DB,0x004DB), `Abs (0x004DB); + (0x004DD,0x004DD), `Abs (0x004DD); + (0x004DF,0x004DF), `Abs (0x004DF); + (0x004E1,0x004E1), `Abs (0x004E1); + (0x004E3,0x004E3), `Abs (0x004E3); + (0x004E5,0x004E5), `Abs (0x004E5); + (0x004E7,0x004E7), `Abs (0x004E7); + (0x004E9,0x004E9), `Abs (0x004E9); + (0x004EB,0x004EB), `Abs (0x004EB); + (0x004ED,0x004ED), `Abs (0x004ED); + (0x004EF,0x004EF), `Abs (0x004EF); + (0x004F1,0x004F1), `Abs (0x004F1); + (0x004F3,0x004F3), `Abs (0x004F3); + (0x004F5,0x004F5), `Abs (0x004F5); + (0x004F7,0x004F7), `Abs (0x004F7); + (0x004F9,0x004F9), `Abs (0x004F9); + (0x004FB,0x004FB), `Abs (0x004FB); + (0x004FD,0x004FD), `Abs (0x004FD); + (0x004FF,0x004FF), `Abs (0x004FF); + (0x00501,0x00501), `Abs (0x00501); + (0x00503,0x00503), `Abs (0x00503); + (0x00505,0x00505), `Abs (0x00505); + (0x00507,0x00507), `Abs (0x00507); + (0x00509,0x00509), `Abs (0x00509); + (0x0050B,0x0050B), `Abs (0x0050B); + (0x0050D,0x0050D), `Abs (0x0050D); + (0x0050F,0x0050F), `Abs (0x0050F); + (0x00511,0x00511), `Abs (0x00511); + (0x00513,0x00513), `Abs (0x00513); + (0x00515,0x00515), `Abs (0x00515); + (0x00517,0x00517), `Abs (0x00517); + (0x00519,0x00519), `Abs (0x00519); + (0x0051B,0x0051B), `Abs (0x0051B); + (0x0051D,0x0051D), `Abs (0x0051D); + (0x0051F,0x0051F), `Abs (0x0051F); + (0x00521,0x00521), `Abs (0x00521); + (0x00523,0x00523), `Abs (0x00523); + (0x00525,0x00525), `Abs (0x00525); + (0x00527,0x00527), `Abs (0x00527); + (0x00529,0x00529), `Abs (0x00529); + (0x0052B,0x0052B), `Abs (0x0052B); + (0x0052D,0x0052D), `Abs (0x0052D); + (0x0052F,0x0052F), `Abs (0x0052F); + (0x00561,0x00587), `Delta (0); + (0x013F8,0x013FD), `Delta (0); + (0x01C80,0x01C88), `Delta (0); + (0x01D00,0x01D2B), `Delta (0); + (0x01D6B,0x01D77), `Delta (0); + (0x01D79,0x01D9A), `Delta (0); + (0x01E01,0x01E01), `Abs (0x01E01); + (0x01E03,0x01E03), `Abs (0x01E03); + (0x01E05,0x01E05), `Abs (0x01E05); + (0x01E07,0x01E07), `Abs (0x01E07); + (0x01E09,0x01E09), `Abs (0x01E09); + (0x01E0B,0x01E0B), `Abs (0x01E0B); + (0x01E0D,0x01E0D), `Abs (0x01E0D); + (0x01E0F,0x01E0F), `Abs (0x01E0F); + (0x01E11,0x01E11), `Abs (0x01E11); + (0x01E13,0x01E13), `Abs (0x01E13); + (0x01E15,0x01E15), `Abs (0x01E15); + (0x01E17,0x01E17), `Abs (0x01E17); + (0x01E19,0x01E19), `Abs (0x01E19); + (0x01E1B,0x01E1B), `Abs (0x01E1B); + (0x01E1D,0x01E1D), `Abs (0x01E1D); + (0x01E1F,0x01E1F), `Abs (0x01E1F); + (0x01E21,0x01E21), `Abs (0x01E21); + (0x01E23,0x01E23), `Abs (0x01E23); + (0x01E25,0x01E25), `Abs (0x01E25); + (0x01E27,0x01E27), `Abs (0x01E27); + (0x01E29,0x01E29), `Abs (0x01E29); + (0x01E2B,0x01E2B), `Abs (0x01E2B); + (0x01E2D,0x01E2D), `Abs (0x01E2D); + (0x01E2F,0x01E2F), `Abs (0x01E2F); + (0x01E31,0x01E31), `Abs (0x01E31); + (0x01E33,0x01E33), `Abs (0x01E33); + (0x01E35,0x01E35), `Abs (0x01E35); + (0x01E37,0x01E37), `Abs (0x01E37); + (0x01E39,0x01E39), `Abs (0x01E39); + (0x01E3B,0x01E3B), `Abs (0x01E3B); + (0x01E3D,0x01E3D), `Abs (0x01E3D); + (0x01E3F,0x01E3F), `Abs (0x01E3F); + (0x01E41,0x01E41), `Abs (0x01E41); + (0x01E43,0x01E43), `Abs (0x01E43); + (0x01E45,0x01E45), `Abs (0x01E45); + (0x01E47,0x01E47), `Abs (0x01E47); + (0x01E49,0x01E49), `Abs (0x01E49); + (0x01E4B,0x01E4B), `Abs (0x01E4B); + (0x01E4D,0x01E4D), `Abs (0x01E4D); + (0x01E4F,0x01E4F), `Abs (0x01E4F); + (0x01E51,0x01E51), `Abs (0x01E51); + (0x01E53,0x01E53), `Abs (0x01E53); + (0x01E55,0x01E55), `Abs (0x01E55); + (0x01E57,0x01E57), `Abs (0x01E57); + (0x01E59,0x01E59), `Abs (0x01E59); + (0x01E5B,0x01E5B), `Abs (0x01E5B); + (0x01E5D,0x01E5D), `Abs (0x01E5D); + (0x01E5F,0x01E5F), `Abs (0x01E5F); + (0x01E61,0x01E61), `Abs (0x01E61); + (0x01E63,0x01E63), `Abs (0x01E63); + (0x01E65,0x01E65), `Abs (0x01E65); + (0x01E67,0x01E67), `Abs (0x01E67); + (0x01E69,0x01E69), `Abs (0x01E69); + (0x01E6B,0x01E6B), `Abs (0x01E6B); + (0x01E6D,0x01E6D), `Abs (0x01E6D); + (0x01E6F,0x01E6F), `Abs (0x01E6F); + (0x01E71,0x01E71), `Abs (0x01E71); + (0x01E73,0x01E73), `Abs (0x01E73); + (0x01E75,0x01E75), `Abs (0x01E75); + (0x01E77,0x01E77), `Abs (0x01E77); + (0x01E79,0x01E79), `Abs (0x01E79); + (0x01E7B,0x01E7B), `Abs (0x01E7B); + (0x01E7D,0x01E7D), `Abs (0x01E7D); + (0x01E7F,0x01E7F), `Abs (0x01E7F); + (0x01E81,0x01E81), `Abs (0x01E81); + (0x01E83,0x01E83), `Abs (0x01E83); + (0x01E85,0x01E85), `Abs (0x01E85); + (0x01E87,0x01E87), `Abs (0x01E87); + (0x01E89,0x01E89), `Abs (0x01E89); + (0x01E8B,0x01E8B), `Abs (0x01E8B); + (0x01E8D,0x01E8D), `Abs (0x01E8D); + (0x01E8F,0x01E8F), `Abs (0x01E8F); + (0x01E91,0x01E91), `Abs (0x01E91); + (0x01E93,0x01E93), `Abs (0x01E93); + (0x01E95,0x01E9D), `Delta (0); + (0x01E9F,0x01E9F), `Abs (0x01E9F); + (0x01EA1,0x01EA1), `Abs (0x01EA1); + (0x01EA3,0x01EA3), `Abs (0x01EA3); + (0x01EA5,0x01EA5), `Abs (0x01EA5); + (0x01EA7,0x01EA7), `Abs (0x01EA7); + (0x01EA9,0x01EA9), `Abs (0x01EA9); + (0x01EAB,0x01EAB), `Abs (0x01EAB); + (0x01EAD,0x01EAD), `Abs (0x01EAD); + (0x01EAF,0x01EAF), `Abs (0x01EAF); + (0x01EB1,0x01EB1), `Abs (0x01EB1); + (0x01EB3,0x01EB3), `Abs (0x01EB3); + (0x01EB5,0x01EB5), `Abs (0x01EB5); + (0x01EB7,0x01EB7), `Abs (0x01EB7); + (0x01EB9,0x01EB9), `Abs (0x01EB9); + (0x01EBB,0x01EBB), `Abs (0x01EBB); + (0x01EBD,0x01EBD), `Abs (0x01EBD); + (0x01EBF,0x01EBF), `Abs (0x01EBF); + (0x01EC1,0x01EC1), `Abs (0x01EC1); + (0x01EC3,0x01EC3), `Abs (0x01EC3); + (0x01EC5,0x01EC5), `Abs (0x01EC5); + (0x01EC7,0x01EC7), `Abs (0x01EC7); + (0x01EC9,0x01EC9), `Abs (0x01EC9); + (0x01ECB,0x01ECB), `Abs (0x01ECB); + (0x01ECD,0x01ECD), `Abs (0x01ECD); + (0x01ECF,0x01ECF), `Abs (0x01ECF); + (0x01ED1,0x01ED1), `Abs (0x01ED1); + (0x01ED3,0x01ED3), `Abs (0x01ED3); + (0x01ED5,0x01ED5), `Abs (0x01ED5); + (0x01ED7,0x01ED7), `Abs (0x01ED7); + (0x01ED9,0x01ED9), `Abs (0x01ED9); + (0x01EDB,0x01EDB), `Abs (0x01EDB); + (0x01EDD,0x01EDD), `Abs (0x01EDD); + (0x01EDF,0x01EDF), `Abs (0x01EDF); + (0x01EE1,0x01EE1), `Abs (0x01EE1); + (0x01EE3,0x01EE3), `Abs (0x01EE3); + (0x01EE5,0x01EE5), `Abs (0x01EE5); + (0x01EE7,0x01EE7), `Abs (0x01EE7); + (0x01EE9,0x01EE9), `Abs (0x01EE9); + (0x01EEB,0x01EEB), `Abs (0x01EEB); + (0x01EED,0x01EED), `Abs (0x01EED); + (0x01EEF,0x01EEF), `Abs (0x01EEF); + (0x01EF1,0x01EF1), `Abs (0x01EF1); + (0x01EF3,0x01EF3), `Abs (0x01EF3); + (0x01EF5,0x01EF5), `Abs (0x01EF5); + (0x01EF7,0x01EF7), `Abs (0x01EF7); + (0x01EF9,0x01EF9), `Abs (0x01EF9); + (0x01EFB,0x01EFB), `Abs (0x01EFB); + (0x01EFD,0x01EFD), `Abs (0x01EFD); + (0x01EFF,0x01F07), `Delta (0); + (0x01F10,0x01F15), `Delta (0); + (0x01F20,0x01F27), `Delta (0); + (0x01F30,0x01F37), `Delta (0); + (0x01F40,0x01F45), `Delta (0); + (0x01F50,0x01F57), `Delta (0); + (0x01F60,0x01F67), `Delta (0); + (0x01F70,0x01F7D), `Delta (0); + (0x01F80,0x01F87), `Delta (0); + (0x01F90,0x01F97), `Delta (0); + (0x01FA0,0x01FA7), `Delta (0); + (0x01FB0,0x01FB4), `Delta (0); + (0x01FB6,0x01FB7), `Delta (0); + (0x01FBE,0x01FBE), `Abs (0x01FBE); + (0x01FC2,0x01FC4), `Delta (0); + (0x01FC6,0x01FC7), `Delta (0); + (0x01FD0,0x01FD3), `Delta (0); + (0x01FD6,0x01FD7), `Delta (0); + (0x01FE0,0x01FE7), `Delta (0); + (0x01FF2,0x01FF4), `Delta (0); + (0x01FF6,0x01FF7), `Delta (0); + (0x0210A,0x0210A), `Abs (0x0210A); + (0x0210E,0x0210F), `Delta (0); + (0x02113,0x02113), `Abs (0x02113); + (0x0212F,0x0212F), `Abs (0x0212F); + (0x02134,0x02134), `Abs (0x02134); + (0x02139,0x02139), `Abs (0x02139); + (0x0213C,0x0213D), `Delta (0); + (0x02146,0x02149), `Delta (0); + (0x0214E,0x0214E), `Abs (0x0214E); + (0x02184,0x02184), `Abs (0x02184); + (0x02C30,0x02C5E), `Delta (0); + (0x02C61,0x02C61), `Abs (0x02C61); + (0x02C65,0x02C66), `Delta (0); + (0x02C68,0x02C68), `Abs (0x02C68); + (0x02C6A,0x02C6A), `Abs (0x02C6A); + (0x02C6C,0x02C6C), `Abs (0x02C6C); + (0x02C71,0x02C71), `Abs (0x02C71); + (0x02C73,0x02C74), `Delta (0); + (0x02C76,0x02C7B), `Delta (0); + (0x02C81,0x02C81), `Abs (0x02C81); + (0x02C83,0x02C83), `Abs (0x02C83); + (0x02C85,0x02C85), `Abs (0x02C85); + (0x02C87,0x02C87), `Abs (0x02C87); + (0x02C89,0x02C89), `Abs (0x02C89); + (0x02C8B,0x02C8B), `Abs (0x02C8B); + (0x02C8D,0x02C8D), `Abs (0x02C8D); + (0x02C8F,0x02C8F), `Abs (0x02C8F); + (0x02C91,0x02C91), `Abs (0x02C91); + (0x02C93,0x02C93), `Abs (0x02C93); + (0x02C95,0x02C95), `Abs (0x02C95); + (0x02C97,0x02C97), `Abs (0x02C97); + (0x02C99,0x02C99), `Abs (0x02C99); + (0x02C9B,0x02C9B), `Abs (0x02C9B); + (0x02C9D,0x02C9D), `Abs (0x02C9D); + (0x02C9F,0x02C9F), `Abs (0x02C9F); + (0x02CA1,0x02CA1), `Abs (0x02CA1); + (0x02CA3,0x02CA3), `Abs (0x02CA3); + (0x02CA5,0x02CA5), `Abs (0x02CA5); + (0x02CA7,0x02CA7), `Abs (0x02CA7); + (0x02CA9,0x02CA9), `Abs (0x02CA9); + (0x02CAB,0x02CAB), `Abs (0x02CAB); + (0x02CAD,0x02CAD), `Abs (0x02CAD); + (0x02CAF,0x02CAF), `Abs (0x02CAF); + (0x02CB1,0x02CB1), `Abs (0x02CB1); + (0x02CB3,0x02CB3), `Abs (0x02CB3); + (0x02CB5,0x02CB5), `Abs (0x02CB5); + (0x02CB7,0x02CB7), `Abs (0x02CB7); + (0x02CB9,0x02CB9), `Abs (0x02CB9); + (0x02CBB,0x02CBB), `Abs (0x02CBB); + (0x02CBD,0x02CBD), `Abs (0x02CBD); + (0x02CBF,0x02CBF), `Abs (0x02CBF); + (0x02CC1,0x02CC1), `Abs (0x02CC1); + (0x02CC3,0x02CC3), `Abs (0x02CC3); + (0x02CC5,0x02CC5), `Abs (0x02CC5); + (0x02CC7,0x02CC7), `Abs (0x02CC7); + (0x02CC9,0x02CC9), `Abs (0x02CC9); + (0x02CCB,0x02CCB), `Abs (0x02CCB); + (0x02CCD,0x02CCD), `Abs (0x02CCD); + (0x02CCF,0x02CCF), `Abs (0x02CCF); + (0x02CD1,0x02CD1), `Abs (0x02CD1); + (0x02CD3,0x02CD3), `Abs (0x02CD3); + (0x02CD5,0x02CD5), `Abs (0x02CD5); + (0x02CD7,0x02CD7), `Abs (0x02CD7); + (0x02CD9,0x02CD9), `Abs (0x02CD9); + (0x02CDB,0x02CDB), `Abs (0x02CDB); + (0x02CDD,0x02CDD), `Abs (0x02CDD); + (0x02CDF,0x02CDF), `Abs (0x02CDF); + (0x02CE1,0x02CE1), `Abs (0x02CE1); + (0x02CE3,0x02CE4), `Delta (0); + (0x02CEC,0x02CEC), `Abs (0x02CEC); + (0x02CEE,0x02CEE), `Abs (0x02CEE); + (0x02CF3,0x02CF3), `Abs (0x02CF3); + (0x02D00,0x02D25), `Delta (0); + (0x02D27,0x02D27), `Abs (0x02D27); + (0x02D2D,0x02D2D), `Abs (0x02D2D); + (0x0A641,0x0A641), `Abs (0x0A641); + (0x0A643,0x0A643), `Abs (0x0A643); + (0x0A645,0x0A645), `Abs (0x0A645); + (0x0A647,0x0A647), `Abs (0x0A647); + (0x0A649,0x0A649), `Abs (0x0A649); + (0x0A64B,0x0A64B), `Abs (0x0A64B); + (0x0A64D,0x0A64D), `Abs (0x0A64D); + (0x0A64F,0x0A64F), `Abs (0x0A64F); + (0x0A651,0x0A651), `Abs (0x0A651); + (0x0A653,0x0A653), `Abs (0x0A653); + (0x0A655,0x0A655), `Abs (0x0A655); + (0x0A657,0x0A657), `Abs (0x0A657); + (0x0A659,0x0A659), `Abs (0x0A659); + (0x0A65B,0x0A65B), `Abs (0x0A65B); + (0x0A65D,0x0A65D), `Abs (0x0A65D); + (0x0A65F,0x0A65F), `Abs (0x0A65F); + (0x0A661,0x0A661), `Abs (0x0A661); + (0x0A663,0x0A663), `Abs (0x0A663); + (0x0A665,0x0A665), `Abs (0x0A665); + (0x0A667,0x0A667), `Abs (0x0A667); + (0x0A669,0x0A669), `Abs (0x0A669); + (0x0A66B,0x0A66B), `Abs (0x0A66B); + (0x0A66D,0x0A66D), `Abs (0x0A66D); + (0x0A681,0x0A681), `Abs (0x0A681); + (0x0A683,0x0A683), `Abs (0x0A683); + (0x0A685,0x0A685), `Abs (0x0A685); + (0x0A687,0x0A687), `Abs (0x0A687); + (0x0A689,0x0A689), `Abs (0x0A689); + (0x0A68B,0x0A68B), `Abs (0x0A68B); + (0x0A68D,0x0A68D), `Abs (0x0A68D); + (0x0A68F,0x0A68F), `Abs (0x0A68F); + (0x0A691,0x0A691), `Abs (0x0A691); + (0x0A693,0x0A693), `Abs (0x0A693); + (0x0A695,0x0A695), `Abs (0x0A695); + (0x0A697,0x0A697), `Abs (0x0A697); + (0x0A699,0x0A699), `Abs (0x0A699); + (0x0A69B,0x0A69B), `Abs (0x0A69B); + (0x0A723,0x0A723), `Abs (0x0A723); + (0x0A725,0x0A725), `Abs (0x0A725); + (0x0A727,0x0A727), `Abs (0x0A727); + (0x0A729,0x0A729), `Abs (0x0A729); + (0x0A72B,0x0A72B), `Abs (0x0A72B); + (0x0A72D,0x0A72D), `Abs (0x0A72D); + (0x0A72F,0x0A731), `Delta (0); + (0x0A733,0x0A733), `Abs (0x0A733); + (0x0A735,0x0A735), `Abs (0x0A735); + (0x0A737,0x0A737), `Abs (0x0A737); + (0x0A739,0x0A739), `Abs (0x0A739); + (0x0A73B,0x0A73B), `Abs (0x0A73B); + (0x0A73D,0x0A73D), `Abs (0x0A73D); + (0x0A73F,0x0A73F), `Abs (0x0A73F); + (0x0A741,0x0A741), `Abs (0x0A741); + (0x0A743,0x0A743), `Abs (0x0A743); + (0x0A745,0x0A745), `Abs (0x0A745); + (0x0A747,0x0A747), `Abs (0x0A747); + (0x0A749,0x0A749), `Abs (0x0A749); + (0x0A74B,0x0A74B), `Abs (0x0A74B); + (0x0A74D,0x0A74D), `Abs (0x0A74D); + (0x0A74F,0x0A74F), `Abs (0x0A74F); + (0x0A751,0x0A751), `Abs (0x0A751); + (0x0A753,0x0A753), `Abs (0x0A753); + (0x0A755,0x0A755), `Abs (0x0A755); + (0x0A757,0x0A757), `Abs (0x0A757); + (0x0A759,0x0A759), `Abs (0x0A759); + (0x0A75B,0x0A75B), `Abs (0x0A75B); + (0x0A75D,0x0A75D), `Abs (0x0A75D); + (0x0A75F,0x0A75F), `Abs (0x0A75F); + (0x0A761,0x0A761), `Abs (0x0A761); + (0x0A763,0x0A763), `Abs (0x0A763); + (0x0A765,0x0A765), `Abs (0x0A765); + (0x0A767,0x0A767), `Abs (0x0A767); + (0x0A769,0x0A769), `Abs (0x0A769); + (0x0A76B,0x0A76B), `Abs (0x0A76B); + (0x0A76D,0x0A76D), `Abs (0x0A76D); + (0x0A76F,0x0A76F), `Abs (0x0A76F); + (0x0A771,0x0A778), `Delta (0); + (0x0A77A,0x0A77A), `Abs (0x0A77A); + (0x0A77C,0x0A77C), `Abs (0x0A77C); + (0x0A77F,0x0A77F), `Abs (0x0A77F); + (0x0A781,0x0A781), `Abs (0x0A781); + (0x0A783,0x0A783), `Abs (0x0A783); + (0x0A785,0x0A785), `Abs (0x0A785); + (0x0A787,0x0A787), `Abs (0x0A787); + (0x0A78C,0x0A78C), `Abs (0x0A78C); + (0x0A78E,0x0A78E), `Abs (0x0A78E); + (0x0A791,0x0A791), `Abs (0x0A791); + (0x0A793,0x0A795), `Delta (0); + (0x0A797,0x0A797), `Abs (0x0A797); + (0x0A799,0x0A799), `Abs (0x0A799); + (0x0A79B,0x0A79B), `Abs (0x0A79B); + (0x0A79D,0x0A79D), `Abs (0x0A79D); + (0x0A79F,0x0A79F), `Abs (0x0A79F); + (0x0A7A1,0x0A7A1), `Abs (0x0A7A1); + (0x0A7A3,0x0A7A3), `Abs (0x0A7A3); + (0x0A7A5,0x0A7A5), `Abs (0x0A7A5); + (0x0A7A7,0x0A7A7), `Abs (0x0A7A7); + (0x0A7A9,0x0A7A9), `Abs (0x0A7A9); + (0x0A7B5,0x0A7B5), `Abs (0x0A7B5); + (0x0A7B7,0x0A7B7), `Abs (0x0A7B7); + (0x0A7FA,0x0A7FA), `Abs (0x0A7FA); + (0x0AB30,0x0AB5A), `Delta (0); + (0x0AB60,0x0AB65), `Delta (0); + (0x0AB70,0x0ABBF), `Delta (0); + (0x0FB00,0x0FB06), `Delta (0); + (0x0FB13,0x0FB17), `Delta (0); + (0x0FF41,0x0FF5A), `Delta (0); + (0x10428,0x1044F), `Delta (0); + (0x104D8,0x104FB), `Delta (0); + (0x10CC0,0x10CF2), `Delta (0); + (0x118C0,0x118DF), `Delta (0); + (0x1D41A,0x1D433), `Delta (0); + (0x1D44E,0x1D454), `Delta (0); + (0x1D456,0x1D467), `Delta (0); + (0x1D482,0x1D49B), `Delta (0); + (0x1D4B6,0x1D4B9), `Delta (0); + (0x1D4BB,0x1D4BB), `Abs (0x1D4BB); + (0x1D4BD,0x1D4C3), `Delta (0); + (0x1D4C5,0x1D4CF), `Delta (0); + (0x1D4EA,0x1D503), `Delta (0); + (0x1D51E,0x1D537), `Delta (0); + (0x1D552,0x1D56B), `Delta (0); + (0x1D586,0x1D59F), `Delta (0); + (0x1D5BA,0x1D5D3), `Delta (0); + (0x1D5EE,0x1D607), `Delta (0); + (0x1D622,0x1D63B), `Delta (0); + (0x1D656,0x1D66F), `Delta (0); + (0x1D68A,0x1D6A5), `Delta (0); + (0x1D6C2,0x1D6DA), `Delta (0); + (0x1D6DC,0x1D6E1), `Delta (0); + (0x1D6FC,0x1D714), `Delta (0); + (0x1D716,0x1D71B), `Delta (0); + (0x1D736,0x1D74E), `Delta (0); + (0x1D750,0x1D755), `Delta (0); + (0x1D770,0x1D788), `Delta (0); + (0x1D78A,0x1D78F), `Delta (0); + (0x1D7AA,0x1D7C2), `Delta (0); + (0x1D7C4,0x1D7C9), `Delta (0); + (0x1D7CB,0x1D7CB), `Abs (0x1D7CB); + (0x1E922,0x1E943), `Delta (0); (0x001C5,0x001C5), `Abs (0x001C6); (0x001C8,0x001C8), `Abs (0x001C9); (0x001CB,0x001CB), `Abs (0x001CC); @@ -2614,6 +5040,2388 @@ let to_lower = [ (0x01FBC,0x01FBC), `Abs (0x01FB3); (0x01FCC,0x01FCC), `Abs (0x01FC3); (0x01FFC,0x01FFC), `Abs (0x01FF3); - (0x02160,0x0216F), `Delta (16) -] - + (0x00300,0x0036F), `Delta (0); + (0x00483,0x00487), `Delta (0); + (0x00591,0x005BD), `Delta (0); + (0x005BF,0x005BF), `Abs (0x005BF); + (0x005C1,0x005C2), `Delta (0); + (0x005C4,0x005C5), `Delta (0); + (0x005C7,0x005C7), `Abs (0x005C7); + (0x00610,0x0061A), `Delta (0); + (0x0064B,0x0065F), `Delta (0); + (0x00670,0x00670), `Abs (0x00670); + (0x006D6,0x006DC), `Delta (0); + (0x006DF,0x006E4), `Delta (0); + (0x006E7,0x006E8), `Delta (0); + (0x006EA,0x006ED), `Delta (0); + (0x00711,0x00711), `Abs (0x00711); + (0x00730,0x0074A), `Delta (0); + (0x007A6,0x007B0), `Delta (0); + (0x007EB,0x007F3), `Delta (0); + (0x00816,0x00819), `Delta (0); + (0x0081B,0x00823), `Delta (0); + (0x00825,0x00827), `Delta (0); + (0x00829,0x0082D), `Delta (0); + (0x00859,0x0085B), `Delta (0); + (0x008D4,0x008E1), `Delta (0); + (0x008E3,0x00902), `Delta (0); + (0x0093A,0x0093A), `Abs (0x0093A); + (0x0093C,0x0093C), `Abs (0x0093C); + (0x00941,0x00948), `Delta (0); + (0x0094D,0x0094D), `Abs (0x0094D); + (0x00951,0x00957), `Delta (0); + (0x00962,0x00963), `Delta (0); + (0x00981,0x00981), `Abs (0x00981); + (0x009BC,0x009BC), `Abs (0x009BC); + (0x009C1,0x009C4), `Delta (0); + (0x009CD,0x009CD), `Abs (0x009CD); + (0x009E2,0x009E3), `Delta (0); + (0x00A01,0x00A02), `Delta (0); + (0x00A3C,0x00A3C), `Abs (0x00A3C); + (0x00A41,0x00A42), `Delta (0); + (0x00A47,0x00A48), `Delta (0); + (0x00A4B,0x00A4D), `Delta (0); + (0x00A51,0x00A51), `Abs (0x00A51); + (0x00A70,0x00A71), `Delta (0); + (0x00A75,0x00A75), `Abs (0x00A75); + (0x00A81,0x00A82), `Delta (0); + (0x00ABC,0x00ABC), `Abs (0x00ABC); + (0x00AC1,0x00AC5), `Delta (0); + (0x00AC7,0x00AC8), `Delta (0); + (0x00ACD,0x00ACD), `Abs (0x00ACD); + (0x00AE2,0x00AE3), `Delta (0); + (0x00B01,0x00B01), `Abs (0x00B01); + (0x00B3C,0x00B3C), `Abs (0x00B3C); + (0x00B3F,0x00B3F), `Abs (0x00B3F); + (0x00B41,0x00B44), `Delta (0); + (0x00B4D,0x00B4D), `Abs (0x00B4D); + (0x00B56,0x00B56), `Abs (0x00B56); + (0x00B62,0x00B63), `Delta (0); + (0x00B82,0x00B82), `Abs (0x00B82); + (0x00BC0,0x00BC0), `Abs (0x00BC0); + (0x00BCD,0x00BCD), `Abs (0x00BCD); + (0x00C00,0x00C00), `Abs (0x00C00); + (0x00C3E,0x00C40), `Delta (0); + (0x00C46,0x00C48), `Delta (0); + (0x00C4A,0x00C4D), `Delta (0); + (0x00C55,0x00C56), `Delta (0); + (0x00C62,0x00C63), `Delta (0); + (0x00C81,0x00C81), `Abs (0x00C81); + (0x00CBC,0x00CBC), `Abs (0x00CBC); + (0x00CBF,0x00CBF), `Abs (0x00CBF); + (0x00CC6,0x00CC6), `Abs (0x00CC6); + (0x00CCC,0x00CCD), `Delta (0); + (0x00CE2,0x00CE3), `Delta (0); + (0x00D01,0x00D01), `Abs (0x00D01); + (0x00D41,0x00D44), `Delta (0); + (0x00D4D,0x00D4D), `Abs (0x00D4D); + (0x00D62,0x00D63), `Delta (0); + (0x00DCA,0x00DCA), `Abs (0x00DCA); + (0x00DD2,0x00DD4), `Delta (0); + (0x00DD6,0x00DD6), `Abs (0x00DD6); + (0x00E31,0x00E31), `Abs (0x00E31); + (0x00E34,0x00E3A), `Delta (0); + (0x00E47,0x00E4E), `Delta (0); + (0x00EB1,0x00EB1), `Abs (0x00EB1); + (0x00EB4,0x00EB9), `Delta (0); + (0x00EBB,0x00EBC), `Delta (0); + (0x00EC8,0x00ECD), `Delta (0); + (0x00F18,0x00F19), `Delta (0); + (0x00F35,0x00F35), `Abs (0x00F35); + (0x00F37,0x00F37), `Abs (0x00F37); + (0x00F39,0x00F39), `Abs (0x00F39); + (0x00F71,0x00F7E), `Delta (0); + (0x00F80,0x00F84), `Delta (0); + (0x00F86,0x00F87), `Delta (0); + (0x00F8D,0x00F97), `Delta (0); + (0x00F99,0x00FBC), `Delta (0); + (0x00FC6,0x00FC6), `Abs (0x00FC6); + (0x0102D,0x01030), `Delta (0); + (0x01032,0x01037), `Delta (0); + (0x01039,0x0103A), `Delta (0); + (0x0103D,0x0103E), `Delta (0); + (0x01058,0x01059), `Delta (0); + (0x0105E,0x01060), `Delta (0); + (0x01071,0x01074), `Delta (0); + (0x01082,0x01082), `Abs (0x01082); + (0x01085,0x01086), `Delta (0); + (0x0108D,0x0108D), `Abs (0x0108D); + (0x0109D,0x0109D), `Abs (0x0109D); + (0x0135D,0x0135F), `Delta (0); + (0x01712,0x01714), `Delta (0); + (0x01732,0x01734), `Delta (0); + (0x01752,0x01753), `Delta (0); + (0x01772,0x01773), `Delta (0); + (0x017B4,0x017B5), `Delta (0); + (0x017B7,0x017BD), `Delta (0); + (0x017C6,0x017C6), `Abs (0x017C6); + (0x017C9,0x017D3), `Delta (0); + (0x017DD,0x017DD), `Abs (0x017DD); + (0x0180B,0x0180D), `Delta (0); + (0x01885,0x01886), `Delta (0); + (0x018A9,0x018A9), `Abs (0x018A9); + (0x01920,0x01922), `Delta (0); + (0x01927,0x01928), `Delta (0); + (0x01932,0x01932), `Abs (0x01932); + (0x01939,0x0193B), `Delta (0); + (0x01A17,0x01A18), `Delta (0); + (0x01A1B,0x01A1B), `Abs (0x01A1B); + (0x01A56,0x01A56), `Abs (0x01A56); + (0x01A58,0x01A5E), `Delta (0); + (0x01A60,0x01A60), `Abs (0x01A60); + (0x01A62,0x01A62), `Abs (0x01A62); + (0x01A65,0x01A6C), `Delta (0); + (0x01A73,0x01A7C), `Delta (0); + (0x01A7F,0x01A7F), `Abs (0x01A7F); + (0x01AB0,0x01ABD), `Delta (0); + (0x01B00,0x01B03), `Delta (0); + (0x01B34,0x01B34), `Abs (0x01B34); + (0x01B36,0x01B3A), `Delta (0); + (0x01B3C,0x01B3C), `Abs (0x01B3C); + (0x01B42,0x01B42), `Abs (0x01B42); + (0x01B6B,0x01B73), `Delta (0); + (0x01B80,0x01B81), `Delta (0); + (0x01BA2,0x01BA5), `Delta (0); + (0x01BA8,0x01BA9), `Delta (0); + (0x01BAB,0x01BAD), `Delta (0); + (0x01BE6,0x01BE6), `Abs (0x01BE6); + (0x01BE8,0x01BE9), `Delta (0); + (0x01BED,0x01BED), `Abs (0x01BED); + (0x01BEF,0x01BF1), `Delta (0); + (0x01C2C,0x01C33), `Delta (0); + (0x01C36,0x01C37), `Delta (0); + (0x01CD0,0x01CD2), `Delta (0); + (0x01CD4,0x01CE0), `Delta (0); + (0x01CE2,0x01CE8), `Delta (0); + (0x01CED,0x01CED), `Abs (0x01CED); + (0x01CF4,0x01CF4), `Abs (0x01CF4); + (0x01CF8,0x01CF9), `Delta (0); + (0x01DC0,0x01DF5), `Delta (0); + (0x01DFB,0x01DFF), `Delta (0); + (0x020D0,0x020DC), `Delta (0); + (0x020E1,0x020E1), `Abs (0x020E1); + (0x020E5,0x020F0), `Delta (0); + (0x02CEF,0x02CF1), `Delta (0); + (0x02D7F,0x02D7F), `Abs (0x02D7F); + (0x02DE0,0x02DFF), `Delta (0); + (0x0302A,0x0302D), `Delta (0); + (0x03099,0x0309A), `Delta (0); + (0x0A66F,0x0A66F), `Abs (0x0A66F); + (0x0A674,0x0A67D), `Delta (0); + (0x0A69E,0x0A69F), `Delta (0); + (0x0A6F0,0x0A6F1), `Delta (0); + (0x0A802,0x0A802), `Abs (0x0A802); + (0x0A806,0x0A806), `Abs (0x0A806); + (0x0A80B,0x0A80B), `Abs (0x0A80B); + (0x0A825,0x0A826), `Delta (0); + (0x0A8C4,0x0A8C5), `Delta (0); + (0x0A8E0,0x0A8F1), `Delta (0); + (0x0A926,0x0A92D), `Delta (0); + (0x0A947,0x0A951), `Delta (0); + (0x0A980,0x0A982), `Delta (0); + (0x0A9B3,0x0A9B3), `Abs (0x0A9B3); + (0x0A9B6,0x0A9B9), `Delta (0); + (0x0A9BC,0x0A9BC), `Abs (0x0A9BC); + (0x0A9E5,0x0A9E5), `Abs (0x0A9E5); + (0x0AA29,0x0AA2E), `Delta (0); + (0x0AA31,0x0AA32), `Delta (0); + (0x0AA35,0x0AA36), `Delta (0); + (0x0AA43,0x0AA43), `Abs (0x0AA43); + (0x0AA4C,0x0AA4C), `Abs (0x0AA4C); + (0x0AA7C,0x0AA7C), `Abs (0x0AA7C); + (0x0AAB0,0x0AAB0), `Abs (0x0AAB0); + (0x0AAB2,0x0AAB4), `Delta (0); + (0x0AAB7,0x0AAB8), `Delta (0); + (0x0AABE,0x0AABF), `Delta (0); + (0x0AAC1,0x0AAC1), `Abs (0x0AAC1); + (0x0AAEC,0x0AAED), `Delta (0); + (0x0AAF6,0x0AAF6), `Abs (0x0AAF6); + (0x0ABE5,0x0ABE5), `Abs (0x0ABE5); + (0x0ABE8,0x0ABE8), `Abs (0x0ABE8); + (0x0ABED,0x0ABED), `Abs (0x0ABED); + (0x0FB1E,0x0FB1E), `Abs (0x0FB1E); + (0x0FE00,0x0FE0F), `Delta (0); + (0x0FE20,0x0FE2F), `Delta (0); + (0x101FD,0x101FD), `Abs (0x101FD); + (0x102E0,0x102E0), `Abs (0x102E0); + (0x10376,0x1037A), `Delta (0); + (0x10A01,0x10A03), `Delta (0); + (0x10A05,0x10A06), `Delta (0); + (0x10A0C,0x10A0F), `Delta (0); + (0x10A38,0x10A3A), `Delta (0); + (0x10A3F,0x10A3F), `Abs (0x10A3F); + (0x10AE5,0x10AE6), `Delta (0); + (0x11001,0x11001), `Abs (0x11001); + (0x11038,0x11046), `Delta (0); + (0x1107F,0x11081), `Delta (0); + (0x110B3,0x110B6), `Delta (0); + (0x110B9,0x110BA), `Delta (0); + (0x11100,0x11102), `Delta (0); + (0x11127,0x1112B), `Delta (0); + (0x1112D,0x11134), `Delta (0); + (0x11173,0x11173), `Abs (0x11173); + (0x11180,0x11181), `Delta (0); + (0x111B6,0x111BE), `Delta (0); + (0x111CA,0x111CC), `Delta (0); + (0x1122F,0x11231), `Delta (0); + (0x11234,0x11234), `Abs (0x11234); + (0x11236,0x11237), `Delta (0); + (0x1123E,0x1123E), `Abs (0x1123E); + (0x112DF,0x112DF), `Abs (0x112DF); + (0x112E3,0x112EA), `Delta (0); + (0x11300,0x11301), `Delta (0); + (0x1133C,0x1133C), `Abs (0x1133C); + (0x11340,0x11340), `Abs (0x11340); + (0x11366,0x1136C), `Delta (0); + (0x11370,0x11374), `Delta (0); + (0x11438,0x1143F), `Delta (0); + (0x11442,0x11444), `Delta (0); + (0x11446,0x11446), `Abs (0x11446); + (0x114B3,0x114B8), `Delta (0); + (0x114BA,0x114BA), `Abs (0x114BA); + (0x114BF,0x114C0), `Delta (0); + (0x114C2,0x114C3), `Delta (0); + (0x115B2,0x115B5), `Delta (0); + (0x115BC,0x115BD), `Delta (0); + (0x115BF,0x115C0), `Delta (0); + (0x115DC,0x115DD), `Delta (0); + (0x11633,0x1163A), `Delta (0); + (0x1163D,0x1163D), `Abs (0x1163D); + (0x1163F,0x11640), `Delta (0); + (0x116AB,0x116AB), `Abs (0x116AB); + (0x116AD,0x116AD), `Abs (0x116AD); + (0x116B0,0x116B5), `Delta (0); + (0x116B7,0x116B7), `Abs (0x116B7); + (0x1171D,0x1171F), `Delta (0); + (0x11722,0x11725), `Delta (0); + (0x11727,0x1172B), `Delta (0); + (0x11C30,0x11C36), `Delta (0); + (0x11C38,0x11C3D), `Delta (0); + (0x11C3F,0x11C3F), `Abs (0x11C3F); + (0x11C92,0x11CA7), `Delta (0); + (0x11CAA,0x11CB0), `Delta (0); + (0x11CB2,0x11CB3), `Delta (0); + (0x11CB5,0x11CB6), `Delta (0); + (0x16AF0,0x16AF4), `Delta (0); + (0x16B30,0x16B36), `Delta (0); + (0x16F8F,0x16F92), `Delta (0); + (0x1BC9D,0x1BC9E), `Delta (0); + (0x1D167,0x1D169), `Delta (0); + (0x1D17B,0x1D182), `Delta (0); + (0x1D185,0x1D18B), `Delta (0); + (0x1D1AA,0x1D1AD), `Delta (0); + (0x1D242,0x1D244), `Delta (0); + (0x1DA00,0x1DA36), `Delta (0); + (0x1DA3B,0x1DA6C), `Delta (0); + (0x1DA75,0x1DA75), `Abs (0x1DA75); + (0x1DA84,0x1DA84), `Abs (0x1DA84); + (0x1DA9B,0x1DA9F), `Delta (0); + (0x1DAA1,0x1DAAF), `Delta (0); + (0x1E000,0x1E006), `Delta (0); + (0x1E008,0x1E018), `Delta (0); + (0x1E01B,0x1E021), `Delta (0); + (0x1E023,0x1E024), `Delta (0); + (0x1E026,0x1E02A), `Delta (0); + (0x1E8D0,0x1E8D6), `Delta (0); + (0x1E944,0x1E94A), `Delta (0); + (0xE0100,0xE01EF), `Delta (0); + (0x00903,0x00903), `Abs (0x00903); + (0x0093B,0x0093B), `Abs (0x0093B); + (0x0093E,0x00940), `Delta (0); + (0x00949,0x0094C), `Delta (0); + (0x0094E,0x0094F), `Delta (0); + (0x00982,0x00983), `Delta (0); + (0x009BE,0x009C0), `Delta (0); + (0x009C7,0x009C8), `Delta (0); + (0x009CB,0x009CC), `Delta (0); + (0x009D7,0x009D7), `Abs (0x009D7); + (0x00A03,0x00A03), `Abs (0x00A03); + (0x00A3E,0x00A40), `Delta (0); + (0x00A83,0x00A83), `Abs (0x00A83); + (0x00ABE,0x00AC0), `Delta (0); + (0x00AC9,0x00AC9), `Abs (0x00AC9); + (0x00ACB,0x00ACC), `Delta (0); + (0x00B02,0x00B03), `Delta (0); + (0x00B3E,0x00B3E), `Abs (0x00B3E); + (0x00B40,0x00B40), `Abs (0x00B40); + (0x00B47,0x00B48), `Delta (0); + (0x00B4B,0x00B4C), `Delta (0); + (0x00B57,0x00B57), `Abs (0x00B57); + (0x00BBE,0x00BBF), `Delta (0); + (0x00BC1,0x00BC2), `Delta (0); + (0x00BC6,0x00BC8), `Delta (0); + (0x00BCA,0x00BCC), `Delta (0); + (0x00BD7,0x00BD7), `Abs (0x00BD7); + (0x00C01,0x00C03), `Delta (0); + (0x00C41,0x00C44), `Delta (0); + (0x00C82,0x00C83), `Delta (0); + (0x00CBE,0x00CBE), `Abs (0x00CBE); + (0x00CC0,0x00CC4), `Delta (0); + (0x00CC7,0x00CC8), `Delta (0); + (0x00CCA,0x00CCB), `Delta (0); + (0x00CD5,0x00CD6), `Delta (0); + (0x00D02,0x00D03), `Delta (0); + (0x00D3E,0x00D40), `Delta (0); + (0x00D46,0x00D48), `Delta (0); + (0x00D4A,0x00D4C), `Delta (0); + (0x00D57,0x00D57), `Abs (0x00D57); + (0x00D82,0x00D83), `Delta (0); + (0x00DCF,0x00DD1), `Delta (0); + (0x00DD8,0x00DDF), `Delta (0); + (0x00DF2,0x00DF3), `Delta (0); + (0x00F3E,0x00F3F), `Delta (0); + (0x00F7F,0x00F7F), `Abs (0x00F7F); + (0x0102B,0x0102C), `Delta (0); + (0x01031,0x01031), `Abs (0x01031); + (0x01038,0x01038), `Abs (0x01038); + (0x0103B,0x0103C), `Delta (0); + (0x01056,0x01057), `Delta (0); + (0x01062,0x01064), `Delta (0); + (0x01067,0x0106D), `Delta (0); + (0x01083,0x01084), `Delta (0); + (0x01087,0x0108C), `Delta (0); + (0x0108F,0x0108F), `Abs (0x0108F); + (0x0109A,0x0109C), `Delta (0); + (0x017B6,0x017B6), `Abs (0x017B6); + (0x017BE,0x017C5), `Delta (0); + (0x017C7,0x017C8), `Delta (0); + (0x01923,0x01926), `Delta (0); + (0x01929,0x0192B), `Delta (0); + (0x01930,0x01931), `Delta (0); + (0x01933,0x01938), `Delta (0); + (0x01A19,0x01A1A), `Delta (0); + (0x01A55,0x01A55), `Abs (0x01A55); + (0x01A57,0x01A57), `Abs (0x01A57); + (0x01A61,0x01A61), `Abs (0x01A61); + (0x01A63,0x01A64), `Delta (0); + (0x01A6D,0x01A72), `Delta (0); + (0x01B04,0x01B04), `Abs (0x01B04); + (0x01B35,0x01B35), `Abs (0x01B35); + (0x01B3B,0x01B3B), `Abs (0x01B3B); + (0x01B3D,0x01B41), `Delta (0); + (0x01B43,0x01B44), `Delta (0); + (0x01B82,0x01B82), `Abs (0x01B82); + (0x01BA1,0x01BA1), `Abs (0x01BA1); + (0x01BA6,0x01BA7), `Delta (0); + (0x01BAA,0x01BAA), `Abs (0x01BAA); + (0x01BE7,0x01BE7), `Abs (0x01BE7); + (0x01BEA,0x01BEC), `Delta (0); + (0x01BEE,0x01BEE), `Abs (0x01BEE); + (0x01BF2,0x01BF3), `Delta (0); + (0x01C24,0x01C2B), `Delta (0); + (0x01C34,0x01C35), `Delta (0); + (0x01CE1,0x01CE1), `Abs (0x01CE1); + (0x01CF2,0x01CF3), `Delta (0); + (0x0302E,0x0302F), `Delta (0); + (0x0A823,0x0A824), `Delta (0); + (0x0A827,0x0A827), `Abs (0x0A827); + (0x0A880,0x0A881), `Delta (0); + (0x0A8B4,0x0A8C3), `Delta (0); + (0x0A952,0x0A953), `Delta (0); + (0x0A983,0x0A983), `Abs (0x0A983); + (0x0A9B4,0x0A9B5), `Delta (0); + (0x0A9BA,0x0A9BB), `Delta (0); + (0x0A9BD,0x0A9C0), `Delta (0); + (0x0AA2F,0x0AA30), `Delta (0); + (0x0AA33,0x0AA34), `Delta (0); + (0x0AA4D,0x0AA4D), `Abs (0x0AA4D); + (0x0AA7B,0x0AA7B), `Abs (0x0AA7B); + (0x0AA7D,0x0AA7D), `Abs (0x0AA7D); + (0x0AAEB,0x0AAEB), `Abs (0x0AAEB); + (0x0AAEE,0x0AAEF), `Delta (0); + (0x0AAF5,0x0AAF5), `Abs (0x0AAF5); + (0x0ABE3,0x0ABE4), `Delta (0); + (0x0ABE6,0x0ABE7), `Delta (0); + (0x0ABE9,0x0ABEA), `Delta (0); + (0x0ABEC,0x0ABEC), `Abs (0x0ABEC); + (0x11000,0x11000), `Abs (0x11000); + (0x11002,0x11002), `Abs (0x11002); + (0x11082,0x11082), `Abs (0x11082); + (0x110B0,0x110B2), `Delta (0); + (0x110B7,0x110B8), `Delta (0); + (0x1112C,0x1112C), `Abs (0x1112C); + (0x11182,0x11182), `Abs (0x11182); + (0x111B3,0x111B5), `Delta (0); + (0x111BF,0x111C0), `Delta (0); + (0x1122C,0x1122E), `Delta (0); + (0x11232,0x11233), `Delta (0); + (0x11235,0x11235), `Abs (0x11235); + (0x112E0,0x112E2), `Delta (0); + (0x11302,0x11303), `Delta (0); + (0x1133E,0x1133F), `Delta (0); + (0x11341,0x11344), `Delta (0); + (0x11347,0x11348), `Delta (0); + (0x1134B,0x1134D), `Delta (0); + (0x11357,0x11357), `Abs (0x11357); + (0x11362,0x11363), `Delta (0); + (0x11435,0x11437), `Delta (0); + (0x11440,0x11441), `Delta (0); + (0x11445,0x11445), `Abs (0x11445); + (0x114B0,0x114B2), `Delta (0); + (0x114B9,0x114B9), `Abs (0x114B9); + (0x114BB,0x114BE), `Delta (0); + (0x114C1,0x114C1), `Abs (0x114C1); + (0x115AF,0x115B1), `Delta (0); + (0x115B8,0x115BB), `Delta (0); + (0x115BE,0x115BE), `Abs (0x115BE); + (0x11630,0x11632), `Delta (0); + (0x1163B,0x1163C), `Delta (0); + (0x1163E,0x1163E), `Abs (0x1163E); + (0x116AC,0x116AC), `Abs (0x116AC); + (0x116AE,0x116AF), `Delta (0); + (0x116B6,0x116B6), `Abs (0x116B6); + (0x11720,0x11721), `Delta (0); + (0x11726,0x11726), `Abs (0x11726); + (0x11C2F,0x11C2F), `Abs (0x11C2F); + (0x11C3E,0x11C3E), `Abs (0x11C3E); + (0x11CA9,0x11CA9), `Abs (0x11CA9); + (0x11CB1,0x11CB1), `Abs (0x11CB1); + (0x11CB4,0x11CB4), `Abs (0x11CB4); + (0x16F51,0x16F7E), `Delta (0); + (0x1D165,0x1D166), `Delta (0); + (0x1D16D,0x1D172), `Delta (0); + (0x00488,0x00489), `Delta (0); + (0x01ABE,0x01ABE), `Abs (0x01ABE); + (0x020DD,0x020E0), `Delta (0); + (0x020E2,0x020E4), `Delta (0); + (0x0A670,0x0A672), `Delta (0); + (0x00030,0x00039), `Delta (0); + (0x00660,0x00669), `Delta (0); + (0x006F0,0x006F9), `Delta (0); + (0x007C0,0x007C9), `Delta (0); + (0x00966,0x0096F), `Delta (0); + (0x009E6,0x009EF), `Delta (0); + (0x00A66,0x00A6F), `Delta (0); + (0x00AE6,0x00AEF), `Delta (0); + (0x00B66,0x00B6F), `Delta (0); + (0x00BE6,0x00BEF), `Delta (0); + (0x00C66,0x00C6F), `Delta (0); + (0x00CE6,0x00CEF), `Delta (0); + (0x00D66,0x00D6F), `Delta (0); + (0x00DE6,0x00DEF), `Delta (0); + (0x00E50,0x00E59), `Delta (0); + (0x00ED0,0x00ED9), `Delta (0); + (0x00F20,0x00F29), `Delta (0); + (0x01040,0x01049), `Delta (0); + (0x01090,0x01099), `Delta (0); + (0x017E0,0x017E9), `Delta (0); + (0x01810,0x01819), `Delta (0); + (0x01946,0x0194F), `Delta (0); + (0x019D0,0x019D9), `Delta (0); + (0x01A80,0x01A89), `Delta (0); + (0x01A90,0x01A99), `Delta (0); + (0x01B50,0x01B59), `Delta (0); + (0x01BB0,0x01BB9), `Delta (0); + (0x01C40,0x01C49), `Delta (0); + (0x01C50,0x01C59), `Delta (0); + (0x0A620,0x0A629), `Delta (0); + (0x0A8D0,0x0A8D9), `Delta (0); + (0x0A900,0x0A909), `Delta (0); + (0x0A9D0,0x0A9D9), `Delta (0); + (0x0A9F0,0x0A9F9), `Delta (0); + (0x0AA50,0x0AA59), `Delta (0); + (0x0ABF0,0x0ABF9), `Delta (0); + (0x0FF10,0x0FF19), `Delta (0); + (0x104A0,0x104A9), `Delta (0); + (0x11066,0x1106F), `Delta (0); + (0x110F0,0x110F9), `Delta (0); + (0x11136,0x1113F), `Delta (0); + (0x111D0,0x111D9), `Delta (0); + (0x112F0,0x112F9), `Delta (0); + (0x11450,0x11459), `Delta (0); + (0x114D0,0x114D9), `Delta (0); + (0x11650,0x11659), `Delta (0); + (0x116C0,0x116C9), `Delta (0); + (0x11730,0x11739), `Delta (0); + (0x118E0,0x118E9), `Delta (0); + (0x11C50,0x11C59), `Delta (0); + (0x16A60,0x16A69), `Delta (0); + (0x16B50,0x16B59), `Delta (0); + (0x1D7CE,0x1D7FF), `Delta (0); + (0x1E950,0x1E959), `Delta (0); + (0x016EE,0x016F0), `Delta (0); + (0x02160,0x0216F), `Delta (16); + (0x02170,0x02182), `Delta (0); + (0x02185,0x02188), `Delta (0); + (0x03007,0x03007), `Abs (0x03007); + (0x03021,0x03029), `Delta (0); + (0x03038,0x0303A), `Delta (0); + (0x0A6E6,0x0A6EF), `Delta (0); + (0x10140,0x10174), `Delta (0); + (0x10341,0x10341), `Abs (0x10341); + (0x1034A,0x1034A), `Abs (0x1034A); + (0x103D1,0x103D5), `Delta (0); + (0x12400,0x1246E), `Delta (0); + (0x000B2,0x000B3), `Delta (0); + (0x000B9,0x000B9), `Abs (0x000B9); + (0x000BC,0x000BE), `Delta (0); + (0x009F4,0x009F9), `Delta (0); + (0x00B72,0x00B77), `Delta (0); + (0x00BF0,0x00BF2), `Delta (0); + (0x00C78,0x00C7E), `Delta (0); + (0x00D58,0x00D5E), `Delta (0); + (0x00D70,0x00D78), `Delta (0); + (0x00F2A,0x00F33), `Delta (0); + (0x01369,0x0137C), `Delta (0); + (0x017F0,0x017F9), `Delta (0); + (0x019DA,0x019DA), `Abs (0x019DA); + (0x02070,0x02070), `Abs (0x02070); + (0x02074,0x02079), `Delta (0); + (0x02080,0x02089), `Delta (0); + (0x02150,0x0215F), `Delta (0); + (0x02189,0x02189), `Abs (0x02189); + (0x02460,0x0249B), `Delta (0); + (0x024EA,0x024FF), `Delta (0); + (0x02776,0x02793), `Delta (0); + (0x02CFD,0x02CFD), `Abs (0x02CFD); + (0x03192,0x03195), `Delta (0); + (0x03220,0x03229), `Delta (0); + (0x03248,0x0324F), `Delta (0); + (0x03251,0x0325F), `Delta (0); + (0x03280,0x03289), `Delta (0); + (0x032B1,0x032BF), `Delta (0); + (0x0A830,0x0A835), `Delta (0); + (0x10107,0x10133), `Delta (0); + (0x10175,0x10178), `Delta (0); + (0x1018A,0x1018B), `Delta (0); + (0x102E1,0x102FB), `Delta (0); + (0x10320,0x10323), `Delta (0); + (0x10858,0x1085F), `Delta (0); + (0x10879,0x1087F), `Delta (0); + (0x108A7,0x108AF), `Delta (0); + (0x108FB,0x108FF), `Delta (0); + (0x10916,0x1091B), `Delta (0); + (0x109BC,0x109BD), `Delta (0); + (0x109C0,0x109CF), `Delta (0); + (0x109D2,0x109FF), `Delta (0); + (0x10A40,0x10A47), `Delta (0); + (0x10A7D,0x10A7E), `Delta (0); + (0x10A9D,0x10A9F), `Delta (0); + (0x10AEB,0x10AEF), `Delta (0); + (0x10B58,0x10B5F), `Delta (0); + (0x10B78,0x10B7F), `Delta (0); + (0x10BA9,0x10BAF), `Delta (0); + (0x10CFA,0x10CFF), `Delta (0); + (0x10E60,0x10E7E), `Delta (0); + (0x11052,0x11065), `Delta (0); + (0x111E1,0x111F4), `Delta (0); + (0x1173A,0x1173B), `Delta (0); + (0x118EA,0x118F2), `Delta (0); + (0x11C5A,0x11C6C), `Delta (0); + (0x16B5B,0x16B61), `Delta (0); + (0x1D360,0x1D371), `Delta (0); + (0x1E8C7,0x1E8CF), `Delta (0); + (0x1F100,0x1F10C), `Delta (0); + (0x00020,0x00020), `Abs (0x00020); + (0x000A0,0x000A0), `Abs (0x000A0); + (0x01680,0x01680), `Abs (0x01680); + (0x02000,0x0200A), `Delta (0); + (0x0202F,0x0202F), `Abs (0x0202F); + (0x0205F,0x0205F), `Abs (0x0205F); + (0x03000,0x03000), `Abs (0x03000); + (0x02028,0x02029), `Delta (0); + (0x00001,0x0001F), `Delta (0); + (0x0007F,0x0009F), `Delta (0); + (0x000AD,0x000AD), `Abs (0x000AD); + (0x00600,0x00605), `Delta (0); + (0x0061C,0x0061C), `Abs (0x0061C); + (0x006DD,0x006DD), `Abs (0x006DD); + (0x0070F,0x0070F), `Abs (0x0070F); + (0x008E2,0x008E2), `Abs (0x008E2); + (0x0180E,0x0180E), `Abs (0x0180E); + (0x0200B,0x0200F), `Delta (0); + (0x0202A,0x0202E), `Delta (0); + (0x02060,0x02064), `Delta (0); + (0x02066,0x0206F), `Delta (0); + (0x0FEFF,0x0FEFF), `Abs (0x0FEFF); + (0x0FFF9,0x0FFFB), `Delta (0); + (0x110BD,0x110BD), `Abs (0x110BD); + (0x1BCA0,0x1BCA3), `Delta (0); + (0x1D173,0x1D17A), `Delta (0); + (0xE0001,0xE0001), `Abs (0xE0001); + (0xE0020,0xE007F), `Delta (0); + (0x0D800,0x0F8FF), `Delta (0); + (0xF0000,0xFFFFD), `Delta (0); + (0x100000,0x10FFFD), `Delta (0); + (0x00378,0x00379), `Delta (0); + (0x00380,0x00383), `Delta (0); + (0x0038B,0x0038B), `Abs (0x0038B); + (0x0038D,0x0038D), `Abs (0x0038D); + (0x003A2,0x003A2), `Abs (0x003A2); + (0x00530,0x00530), `Abs (0x00530); + (0x00557,0x00558), `Delta (0); + (0x00560,0x00560), `Abs (0x00560); + (0x00588,0x00588), `Abs (0x00588); + (0x0058B,0x0058C), `Delta (0); + (0x00590,0x00590), `Abs (0x00590); + (0x005C8,0x005CF), `Delta (0); + (0x005EB,0x005EF), `Delta (0); + (0x005F5,0x005FF), `Delta (0); + (0x0061D,0x0061D), `Abs (0x0061D); + (0x0070E,0x0070E), `Abs (0x0070E); + (0x0074B,0x0074C), `Delta (0); + (0x007B2,0x007BF), `Delta (0); + (0x007FB,0x007FF), `Delta (0); + (0x0082E,0x0082F), `Delta (0); + (0x0083F,0x0083F), `Abs (0x0083F); + (0x0085C,0x0085D), `Delta (0); + (0x0085F,0x0089F), `Delta (0); + (0x008B5,0x008B5), `Abs (0x008B5); + (0x008BE,0x008D3), `Delta (0); + (0x00984,0x00984), `Abs (0x00984); + (0x0098D,0x0098E), `Delta (0); + (0x00991,0x00992), `Delta (0); + (0x009A9,0x009A9), `Abs (0x009A9); + (0x009B1,0x009B1), `Abs (0x009B1); + (0x009B3,0x009B5), `Delta (0); + (0x009BA,0x009BB), `Delta (0); + (0x009C5,0x009C6), `Delta (0); + (0x009C9,0x009CA), `Delta (0); + (0x009CF,0x009D6), `Delta (0); + (0x009D8,0x009DB), `Delta (0); + (0x009DE,0x009DE), `Abs (0x009DE); + (0x009E4,0x009E5), `Delta (0); + (0x009FC,0x00A00), `Delta (0); + (0x00A04,0x00A04), `Abs (0x00A04); + (0x00A0B,0x00A0E), `Delta (0); + (0x00A11,0x00A12), `Delta (0); + (0x00A29,0x00A29), `Abs (0x00A29); + (0x00A31,0x00A31), `Abs (0x00A31); + (0x00A34,0x00A34), `Abs (0x00A34); + (0x00A37,0x00A37), `Abs (0x00A37); + (0x00A3A,0x00A3B), `Delta (0); + (0x00A3D,0x00A3D), `Abs (0x00A3D); + (0x00A43,0x00A46), `Delta (0); + (0x00A49,0x00A4A), `Delta (0); + (0x00A4E,0x00A50), `Delta (0); + (0x00A52,0x00A58), `Delta (0); + (0x00A5D,0x00A5D), `Abs (0x00A5D); + (0x00A5F,0x00A65), `Delta (0); + (0x00A76,0x00A80), `Delta (0); + (0x00A84,0x00A84), `Abs (0x00A84); + (0x00A8E,0x00A8E), `Abs (0x00A8E); + (0x00A92,0x00A92), `Abs (0x00A92); + (0x00AA9,0x00AA9), `Abs (0x00AA9); + (0x00AB1,0x00AB1), `Abs (0x00AB1); + (0x00AB4,0x00AB4), `Abs (0x00AB4); + (0x00ABA,0x00ABB), `Delta (0); + (0x00AC6,0x00AC6), `Abs (0x00AC6); + (0x00ACA,0x00ACA), `Abs (0x00ACA); + (0x00ACE,0x00ACF), `Delta (0); + (0x00AD1,0x00ADF), `Delta (0); + (0x00AE4,0x00AE5), `Delta (0); + (0x00AF2,0x00AF8), `Delta (0); + (0x00AFA,0x00B00), `Delta (0); + (0x00B04,0x00B04), `Abs (0x00B04); + (0x00B0D,0x00B0E), `Delta (0); + (0x00B11,0x00B12), `Delta (0); + (0x00B29,0x00B29), `Abs (0x00B29); + (0x00B31,0x00B31), `Abs (0x00B31); + (0x00B34,0x00B34), `Abs (0x00B34); + (0x00B3A,0x00B3B), `Delta (0); + (0x00B45,0x00B46), `Delta (0); + (0x00B49,0x00B4A), `Delta (0); + (0x00B4E,0x00B55), `Delta (0); + (0x00B58,0x00B5B), `Delta (0); + (0x00B5E,0x00B5E), `Abs (0x00B5E); + (0x00B64,0x00B65), `Delta (0); + (0x00B78,0x00B81), `Delta (0); + (0x00B84,0x00B84), `Abs (0x00B84); + (0x00B8B,0x00B8D), `Delta (0); + (0x00B91,0x00B91), `Abs (0x00B91); + (0x00B96,0x00B98), `Delta (0); + (0x00B9B,0x00B9B), `Abs (0x00B9B); + (0x00B9D,0x00B9D), `Abs (0x00B9D); + (0x00BA0,0x00BA2), `Delta (0); + (0x00BA5,0x00BA7), `Delta (0); + (0x00BAB,0x00BAD), `Delta (0); + (0x00BBA,0x00BBD), `Delta (0); + (0x00BC3,0x00BC5), `Delta (0); + (0x00BC9,0x00BC9), `Abs (0x00BC9); + (0x00BCE,0x00BCF), `Delta (0); + (0x00BD1,0x00BD6), `Delta (0); + (0x00BD8,0x00BE5), `Delta (0); + (0x00BFB,0x00BFF), `Delta (0); + (0x00C04,0x00C04), `Abs (0x00C04); + (0x00C0D,0x00C0D), `Abs (0x00C0D); + (0x00C11,0x00C11), `Abs (0x00C11); + (0x00C29,0x00C29), `Abs (0x00C29); + (0x00C3A,0x00C3C), `Delta (0); + (0x00C45,0x00C45), `Abs (0x00C45); + (0x00C49,0x00C49), `Abs (0x00C49); + (0x00C4E,0x00C54), `Delta (0); + (0x00C57,0x00C57), `Abs (0x00C57); + (0x00C5B,0x00C5F), `Delta (0); + (0x00C64,0x00C65), `Delta (0); + (0x00C70,0x00C77), `Delta (0); + (0x00C84,0x00C84), `Abs (0x00C84); + (0x00C8D,0x00C8D), `Abs (0x00C8D); + (0x00C91,0x00C91), `Abs (0x00C91); + (0x00CA9,0x00CA9), `Abs (0x00CA9); + (0x00CB4,0x00CB4), `Abs (0x00CB4); + (0x00CBA,0x00CBB), `Delta (0); + (0x00CC5,0x00CC5), `Abs (0x00CC5); + (0x00CC9,0x00CC9), `Abs (0x00CC9); + (0x00CCE,0x00CD4), `Delta (0); + (0x00CD7,0x00CDD), `Delta (0); + (0x00CDF,0x00CDF), `Abs (0x00CDF); + (0x00CE4,0x00CE5), `Delta (0); + (0x00CF0,0x00CF0), `Abs (0x00CF0); + (0x00CF3,0x00D00), `Delta (0); + (0x00D04,0x00D04), `Abs (0x00D04); + (0x00D0D,0x00D0D), `Abs (0x00D0D); + (0x00D11,0x00D11), `Abs (0x00D11); + (0x00D3B,0x00D3C), `Delta (0); + (0x00D45,0x00D45), `Abs (0x00D45); + (0x00D49,0x00D49), `Abs (0x00D49); + (0x00D50,0x00D53), `Delta (0); + (0x00D64,0x00D65), `Delta (0); + (0x00D80,0x00D81), `Delta (0); + (0x00D84,0x00D84), `Abs (0x00D84); + (0x00D97,0x00D99), `Delta (0); + (0x00DB2,0x00DB2), `Abs (0x00DB2); + (0x00DBC,0x00DBC), `Abs (0x00DBC); + (0x00DBE,0x00DBF), `Delta (0); + (0x00DC7,0x00DC9), `Delta (0); + (0x00DCB,0x00DCE), `Delta (0); + (0x00DD5,0x00DD5), `Abs (0x00DD5); + (0x00DD7,0x00DD7), `Abs (0x00DD7); + (0x00DE0,0x00DE5), `Delta (0); + (0x00DF0,0x00DF1), `Delta (0); + (0x00DF5,0x00E00), `Delta (0); + (0x00E3B,0x00E3E), `Delta (0); + (0x00E5C,0x00E80), `Delta (0); + (0x00E83,0x00E83), `Abs (0x00E83); + (0x00E85,0x00E86), `Delta (0); + (0x00E89,0x00E89), `Abs (0x00E89); + (0x00E8B,0x00E8C), `Delta (0); + (0x00E8E,0x00E93), `Delta (0); + (0x00E98,0x00E98), `Abs (0x00E98); + (0x00EA0,0x00EA0), `Abs (0x00EA0); + (0x00EA4,0x00EA4), `Abs (0x00EA4); + (0x00EA6,0x00EA6), `Abs (0x00EA6); + (0x00EA8,0x00EA9), `Delta (0); + (0x00EAC,0x00EAC), `Abs (0x00EAC); + (0x00EBA,0x00EBA), `Abs (0x00EBA); + (0x00EBE,0x00EBF), `Delta (0); + (0x00EC5,0x00EC5), `Abs (0x00EC5); + (0x00EC7,0x00EC7), `Abs (0x00EC7); + (0x00ECE,0x00ECF), `Delta (0); + (0x00EDA,0x00EDB), `Delta (0); + (0x00EE0,0x00EFF), `Delta (0); + (0x00F48,0x00F48), `Abs (0x00F48); + (0x00F6D,0x00F70), `Delta (0); + (0x00F98,0x00F98), `Abs (0x00F98); + (0x00FBD,0x00FBD), `Abs (0x00FBD); + (0x00FCD,0x00FCD), `Abs (0x00FCD); + (0x00FDB,0x00FFF), `Delta (0); + (0x010C6,0x010C6), `Abs (0x010C6); + (0x010C8,0x010CC), `Delta (0); + (0x010CE,0x010CF), `Delta (0); + (0x01249,0x01249), `Abs (0x01249); + (0x0124E,0x0124F), `Delta (0); + (0x01257,0x01257), `Abs (0x01257); + (0x01259,0x01259), `Abs (0x01259); + (0x0125E,0x0125F), `Delta (0); + (0x01289,0x01289), `Abs (0x01289); + (0x0128E,0x0128F), `Delta (0); + (0x012B1,0x012B1), `Abs (0x012B1); + (0x012B6,0x012B7), `Delta (0); + (0x012BF,0x012BF), `Abs (0x012BF); + (0x012C1,0x012C1), `Abs (0x012C1); + (0x012C6,0x012C7), `Delta (0); + (0x012D7,0x012D7), `Abs (0x012D7); + (0x01311,0x01311), `Abs (0x01311); + (0x01316,0x01317), `Delta (0); + (0x0135B,0x0135C), `Delta (0); + (0x0137D,0x0137F), `Delta (0); + (0x0139A,0x0139F), `Delta (0); + (0x013F6,0x013F7), `Delta (0); + (0x013FE,0x013FF), `Delta (0); + (0x0169D,0x0169F), `Delta (0); + (0x016F9,0x016FF), `Delta (0); + (0x0170D,0x0170D), `Abs (0x0170D); + (0x01715,0x0171F), `Delta (0); + (0x01737,0x0173F), `Delta (0); + (0x01754,0x0175F), `Delta (0); + (0x0176D,0x0176D), `Abs (0x0176D); + (0x01771,0x01771), `Abs (0x01771); + (0x01774,0x0177F), `Delta (0); + (0x017DE,0x017DF), `Delta (0); + (0x017EA,0x017EF), `Delta (0); + (0x017FA,0x017FF), `Delta (0); + (0x0180F,0x0180F), `Abs (0x0180F); + (0x0181A,0x0181F), `Delta (0); + (0x01878,0x0187F), `Delta (0); + (0x018AB,0x018AF), `Delta (0); + (0x018F6,0x018FF), `Delta (0); + (0x0191F,0x0191F), `Abs (0x0191F); + (0x0192C,0x0192F), `Delta (0); + (0x0193C,0x0193F), `Delta (0); + (0x01941,0x01943), `Delta (0); + (0x0196E,0x0196F), `Delta (0); + (0x01975,0x0197F), `Delta (0); + (0x019AC,0x019AF), `Delta (0); + (0x019CA,0x019CF), `Delta (0); + (0x019DB,0x019DD), `Delta (0); + (0x01A1C,0x01A1D), `Delta (0); + (0x01A5F,0x01A5F), `Abs (0x01A5F); + (0x01A7D,0x01A7E), `Delta (0); + (0x01A8A,0x01A8F), `Delta (0); + (0x01A9A,0x01A9F), `Delta (0); + (0x01AAE,0x01AAF), `Delta (0); + (0x01ABF,0x01AFF), `Delta (0); + (0x01B4C,0x01B4F), `Delta (0); + (0x01B7D,0x01B7F), `Delta (0); + (0x01BF4,0x01BFB), `Delta (0); + (0x01C38,0x01C3A), `Delta (0); + (0x01C4A,0x01C4C), `Delta (0); + (0x01C89,0x01CBF), `Delta (0); + (0x01CC8,0x01CCF), `Delta (0); + (0x01CF7,0x01CF7), `Abs (0x01CF7); + (0x01CFA,0x01CFF), `Delta (0); + (0x01DF6,0x01DFA), `Delta (0); + (0x01F16,0x01F17), `Delta (0); + (0x01F1E,0x01F1F), `Delta (0); + (0x01F46,0x01F47), `Delta (0); + (0x01F4E,0x01F4F), `Delta (0); + (0x01F58,0x01F58), `Abs (0x01F58); + (0x01F5A,0x01F5A), `Abs (0x01F5A); + (0x01F5C,0x01F5C), `Abs (0x01F5C); + (0x01F5E,0x01F5E), `Abs (0x01F5E); + (0x01F7E,0x01F7F), `Delta (0); + (0x01FB5,0x01FB5), `Abs (0x01FB5); + (0x01FC5,0x01FC5), `Abs (0x01FC5); + (0x01FD4,0x01FD5), `Delta (0); + (0x01FDC,0x01FDC), `Abs (0x01FDC); + (0x01FF0,0x01FF1), `Delta (0); + (0x01FF5,0x01FF5), `Abs (0x01FF5); + (0x01FFF,0x01FFF), `Abs (0x01FFF); + (0x02065,0x02065), `Abs (0x02065); + (0x02072,0x02073), `Delta (0); + (0x0208F,0x0208F), `Abs (0x0208F); + (0x0209D,0x0209F), `Delta (0); + (0x020BF,0x020CF), `Delta (0); + (0x020F1,0x020FF), `Delta (0); + (0x0218C,0x0218F), `Delta (0); + (0x023FF,0x023FF), `Abs (0x023FF); + (0x02427,0x0243F), `Delta (0); + (0x0244B,0x0245F), `Delta (0); + (0x02B74,0x02B75), `Delta (0); + (0x02B96,0x02B97), `Delta (0); + (0x02BBA,0x02BBC), `Delta (0); + (0x02BC9,0x02BC9), `Abs (0x02BC9); + (0x02BD2,0x02BEB), `Delta (0); + (0x02BF0,0x02BFF), `Delta (0); + (0x02C2F,0x02C2F), `Abs (0x02C2F); + (0x02C5F,0x02C5F), `Abs (0x02C5F); + (0x02CF4,0x02CF8), `Delta (0); + (0x02D26,0x02D26), `Abs (0x02D26); + (0x02D28,0x02D2C), `Delta (0); + (0x02D2E,0x02D2F), `Delta (0); + (0x02D68,0x02D6E), `Delta (0); + (0x02D71,0x02D7E), `Delta (0); + (0x02D97,0x02D9F), `Delta (0); + (0x02DA7,0x02DA7), `Abs (0x02DA7); + (0x02DAF,0x02DAF), `Abs (0x02DAF); + (0x02DB7,0x02DB7), `Abs (0x02DB7); + (0x02DBF,0x02DBF), `Abs (0x02DBF); + (0x02DC7,0x02DC7), `Abs (0x02DC7); + (0x02DCF,0x02DCF), `Abs (0x02DCF); + (0x02DD7,0x02DD7), `Abs (0x02DD7); + (0x02DDF,0x02DDF), `Abs (0x02DDF); + (0x02E45,0x02E7F), `Delta (0); + (0x02E9A,0x02E9A), `Abs (0x02E9A); + (0x02EF4,0x02EFF), `Delta (0); + (0x02FD6,0x02FEF), `Delta (0); + (0x02FFC,0x02FFF), `Delta (0); + (0x03040,0x03040), `Abs (0x03040); + (0x03097,0x03098), `Delta (0); + (0x03100,0x03104), `Delta (0); + (0x0312E,0x03130), `Delta (0); + (0x0318F,0x0318F), `Abs (0x0318F); + (0x031BB,0x031BF), `Delta (0); + (0x031E4,0x031EF), `Delta (0); + (0x0321F,0x0321F), `Abs (0x0321F); + (0x032FF,0x032FF), `Abs (0x032FF); + (0x04DB6,0x04DBF), `Delta (0); + (0x09FD6,0x09FFF), `Delta (0); + (0x0A48D,0x0A48F), `Delta (0); + (0x0A4C7,0x0A4CF), `Delta (0); + (0x0A62C,0x0A63F), `Delta (0); + (0x0A6F8,0x0A6FF), `Delta (0); + (0x0A7AF,0x0A7AF), `Abs (0x0A7AF); + (0x0A7B8,0x0A7F6), `Delta (0); + (0x0A82C,0x0A82F), `Delta (0); + (0x0A83A,0x0A83F), `Delta (0); + (0x0A878,0x0A87F), `Delta (0); + (0x0A8C6,0x0A8CD), `Delta (0); + (0x0A8DA,0x0A8DF), `Delta (0); + (0x0A8FE,0x0A8FF), `Delta (0); + (0x0A954,0x0A95E), `Delta (0); + (0x0A97D,0x0A97F), `Delta (0); + (0x0A9CE,0x0A9CE), `Abs (0x0A9CE); + (0x0A9DA,0x0A9DD), `Delta (0); + (0x0A9FF,0x0A9FF), `Abs (0x0A9FF); + (0x0AA37,0x0AA3F), `Delta (0); + (0x0AA4E,0x0AA4F), `Delta (0); + (0x0AA5A,0x0AA5B), `Delta (0); + (0x0AAC3,0x0AADA), `Delta (0); + (0x0AAF7,0x0AB00), `Delta (0); + (0x0AB07,0x0AB08), `Delta (0); + (0x0AB0F,0x0AB10), `Delta (0); + (0x0AB17,0x0AB1F), `Delta (0); + (0x0AB27,0x0AB27), `Abs (0x0AB27); + (0x0AB2F,0x0AB2F), `Abs (0x0AB2F); + (0x0AB66,0x0AB6F), `Delta (0); + (0x0ABEE,0x0ABEF), `Delta (0); + (0x0ABFA,0x0ABFF), `Delta (0); + (0x0D7A4,0x0D7AF), `Delta (0); + (0x0D7C7,0x0D7CA), `Delta (0); + (0x0D7FC,0x0D7FF), `Delta (0); + (0x0FA6E,0x0FA6F), `Delta (0); + (0x0FADA,0x0FAFF), `Delta (0); + (0x0FB07,0x0FB12), `Delta (0); + (0x0FB18,0x0FB1C), `Delta (0); + (0x0FB37,0x0FB37), `Abs (0x0FB37); + (0x0FB3D,0x0FB3D), `Abs (0x0FB3D); + (0x0FB3F,0x0FB3F), `Abs (0x0FB3F); + (0x0FB42,0x0FB42), `Abs (0x0FB42); + (0x0FB45,0x0FB45), `Abs (0x0FB45); + (0x0FBC2,0x0FBD2), `Delta (0); + (0x0FD40,0x0FD4F), `Delta (0); + (0x0FD90,0x0FD91), `Delta (0); + (0x0FDC8,0x0FDEF), `Delta (0); + (0x0FDFE,0x0FDFF), `Delta (0); + (0x0FE1A,0x0FE1F), `Delta (0); + (0x0FE53,0x0FE53), `Abs (0x0FE53); + (0x0FE67,0x0FE67), `Abs (0x0FE67); + (0x0FE6C,0x0FE6F), `Delta (0); + (0x0FE75,0x0FE75), `Abs (0x0FE75); + (0x0FEFD,0x0FEFE), `Delta (0); + (0x0FF00,0x0FF00), `Abs (0x0FF00); + (0x0FFBF,0x0FFC1), `Delta (0); + (0x0FFC8,0x0FFC9), `Delta (0); + (0x0FFD0,0x0FFD1), `Delta (0); + (0x0FFD8,0x0FFD9), `Delta (0); + (0x0FFDD,0x0FFDF), `Delta (0); + (0x0FFE7,0x0FFE7), `Abs (0x0FFE7); + (0x0FFEF,0x0FFF8), `Delta (0); + (0x0FFFE,0x0FFFF), `Delta (0); + (0x1000C,0x1000C), `Abs (0x1000C); + (0x10027,0x10027), `Abs (0x10027); + (0x1003B,0x1003B), `Abs (0x1003B); + (0x1003E,0x1003E), `Abs (0x1003E); + (0x1004E,0x1004F), `Delta (0); + (0x1005E,0x1007F), `Delta (0); + (0x100FB,0x100FF), `Delta (0); + (0x10103,0x10106), `Delta (0); + (0x10134,0x10136), `Delta (0); + (0x1018F,0x1018F), `Abs (0x1018F); + (0x1019C,0x1019F), `Delta (0); + (0x101A1,0x101CF), `Delta (0); + (0x101FE,0x1027F), `Delta (0); + (0x1029D,0x1029F), `Delta (0); + (0x102D1,0x102DF), `Delta (0); + (0x102FC,0x102FF), `Delta (0); + (0x10324,0x1032F), `Delta (0); + (0x1034B,0x1034F), `Delta (0); + (0x1037B,0x1037F), `Delta (0); + (0x1039E,0x1039E), `Abs (0x1039E); + (0x103C4,0x103C7), `Delta (0); + (0x103D6,0x103FF), `Delta (0); + (0x1049E,0x1049F), `Delta (0); + (0x104AA,0x104AF), `Delta (0); + (0x104D4,0x104D7), `Delta (0); + (0x104FC,0x104FF), `Delta (0); + (0x10528,0x1052F), `Delta (0); + (0x10564,0x1056E), `Delta (0); + (0x10570,0x105FF), `Delta (0); + (0x10737,0x1073F), `Delta (0); + (0x10756,0x1075F), `Delta (0); + (0x10768,0x107FF), `Delta (0); + (0x10806,0x10807), `Delta (0); + (0x10809,0x10809), `Abs (0x10809); + (0x10836,0x10836), `Abs (0x10836); + (0x10839,0x1083B), `Delta (0); + (0x1083D,0x1083E), `Delta (0); + (0x10856,0x10856), `Abs (0x10856); + (0x1089F,0x108A6), `Delta (0); + (0x108B0,0x108DF), `Delta (0); + (0x108F3,0x108F3), `Abs (0x108F3); + (0x108F6,0x108FA), `Delta (0); + (0x1091C,0x1091E), `Delta (0); + (0x1093A,0x1093E), `Delta (0); + (0x10940,0x1097F), `Delta (0); + (0x109B8,0x109BB), `Delta (0); + (0x109D0,0x109D1), `Delta (0); + (0x10A04,0x10A04), `Abs (0x10A04); + (0x10A07,0x10A0B), `Delta (0); + (0x10A14,0x10A14), `Abs (0x10A14); + (0x10A18,0x10A18), `Abs (0x10A18); + (0x10A34,0x10A37), `Delta (0); + (0x10A3B,0x10A3E), `Delta (0); + (0x10A48,0x10A4F), `Delta (0); + (0x10A59,0x10A5F), `Delta (0); + (0x10AA0,0x10ABF), `Delta (0); + (0x10AE7,0x10AEA), `Delta (0); + (0x10AF7,0x10AFF), `Delta (0); + (0x10B36,0x10B38), `Delta (0); + (0x10B56,0x10B57), `Delta (0); + (0x10B73,0x10B77), `Delta (0); + (0x10B92,0x10B98), `Delta (0); + (0x10B9D,0x10BA8), `Delta (0); + (0x10BB0,0x10BFF), `Delta (0); + (0x10C49,0x10C7F), `Delta (0); + (0x10CB3,0x10CBF), `Delta (0); + (0x10CF3,0x10CF9), `Delta (0); + (0x10D00,0x10E5F), `Delta (0); + (0x10E7F,0x10FFF), `Delta (0); + (0x1104E,0x11051), `Delta (0); + (0x11070,0x1107E), `Delta (0); + (0x110C2,0x110CF), `Delta (0); + (0x110E9,0x110EF), `Delta (0); + (0x110FA,0x110FF), `Delta (0); + (0x11135,0x11135), `Abs (0x11135); + (0x11144,0x1114F), `Delta (0); + (0x11177,0x1117F), `Delta (0); + (0x111CE,0x111CF), `Delta (0); + (0x111E0,0x111E0), `Abs (0x111E0); + (0x111F5,0x111FF), `Delta (0); + (0x11212,0x11212), `Abs (0x11212); + (0x1123F,0x1127F), `Delta (0); + (0x11287,0x11287), `Abs (0x11287); + (0x11289,0x11289), `Abs (0x11289); + (0x1128E,0x1128E), `Abs (0x1128E); + (0x1129E,0x1129E), `Abs (0x1129E); + (0x112AA,0x112AF), `Delta (0); + (0x112EB,0x112EF), `Delta (0); + (0x112FA,0x112FF), `Delta (0); + (0x11304,0x11304), `Abs (0x11304); + (0x1130D,0x1130E), `Delta (0); + (0x11311,0x11312), `Delta (0); + (0x11329,0x11329), `Abs (0x11329); + (0x11331,0x11331), `Abs (0x11331); + (0x11334,0x11334), `Abs (0x11334); + (0x1133A,0x1133B), `Delta (0); + (0x11345,0x11346), `Delta (0); + (0x11349,0x1134A), `Delta (0); + (0x1134E,0x1134F), `Delta (0); + (0x11351,0x11356), `Delta (0); + (0x11358,0x1135C), `Delta (0); + (0x11364,0x11365), `Delta (0); + (0x1136D,0x1136F), `Delta (0); + (0x11375,0x113FF), `Delta (0); + (0x1145A,0x1145A), `Abs (0x1145A); + (0x1145C,0x1145C), `Abs (0x1145C); + (0x1145E,0x1147F), `Delta (0); + (0x114C8,0x114CF), `Delta (0); + (0x114DA,0x1157F), `Delta (0); + (0x115B6,0x115B7), `Delta (0); + (0x115DE,0x115FF), `Delta (0); + (0x11645,0x1164F), `Delta (0); + (0x1165A,0x1165F), `Delta (0); + (0x1166D,0x1167F), `Delta (0); + (0x116B8,0x116BF), `Delta (0); + (0x116CA,0x116FF), `Delta (0); + (0x1171A,0x1171C), `Delta (0); + (0x1172C,0x1172F), `Delta (0); + (0x11740,0x1189F), `Delta (0); + (0x118F3,0x118FE), `Delta (0); + (0x11900,0x11ABF), `Delta (0); + (0x11AF9,0x11BFF), `Delta (0); + (0x11C09,0x11C09), `Abs (0x11C09); + (0x11C37,0x11C37), `Abs (0x11C37); + (0x11C46,0x11C4F), `Delta (0); + (0x11C6D,0x11C6F), `Delta (0); + (0x11C90,0x11C91), `Delta (0); + (0x11CA8,0x11CA8), `Abs (0x11CA8); + (0x11CB7,0x11FFF), `Delta (0); + (0x1239A,0x123FF), `Delta (0); + (0x1246F,0x1246F), `Abs (0x1246F); + (0x12475,0x1247F), `Delta (0); + (0x12544,0x12FFF), `Delta (0); + (0x1342F,0x143FF), `Delta (0); + (0x14647,0x167FF), `Delta (0); + (0x16A39,0x16A3F), `Delta (0); + (0x16A5F,0x16A5F), `Abs (0x16A5F); + (0x16A6A,0x16A6D), `Delta (0); + (0x16A70,0x16ACF), `Delta (0); + (0x16AEE,0x16AEF), `Delta (0); + (0x16AF6,0x16AFF), `Delta (0); + (0x16B46,0x16B4F), `Delta (0); + (0x16B5A,0x16B5A), `Abs (0x16B5A); + (0x16B62,0x16B62), `Abs (0x16B62); + (0x16B78,0x16B7C), `Delta (0); + (0x16B90,0x16EFF), `Delta (0); + (0x16F45,0x16F4F), `Delta (0); + (0x16F7F,0x16F8E), `Delta (0); + (0x16FA0,0x16FDF), `Delta (0); + (0x16FE1,0x16FFF), `Delta (0); + (0x187ED,0x187FF), `Delta (0); + (0x18AF3,0x1AFFF), `Delta (0); + (0x1B002,0x1BBFF), `Delta (0); + (0x1BC6B,0x1BC6F), `Delta (0); + (0x1BC7D,0x1BC7F), `Delta (0); + (0x1BC89,0x1BC8F), `Delta (0); + (0x1BC9A,0x1BC9B), `Delta (0); + (0x1BCA4,0x1CFFF), `Delta (0); + (0x1D0F6,0x1D0FF), `Delta (0); + (0x1D127,0x1D128), `Delta (0); + (0x1D1E9,0x1D1FF), `Delta (0); + (0x1D246,0x1D2FF), `Delta (0); + (0x1D357,0x1D35F), `Delta (0); + (0x1D372,0x1D3FF), `Delta (0); + (0x1D455,0x1D455), `Abs (0x1D455); + (0x1D49D,0x1D49D), `Abs (0x1D49D); + (0x1D4A0,0x1D4A1), `Delta (0); + (0x1D4A3,0x1D4A4), `Delta (0); + (0x1D4A7,0x1D4A8), `Delta (0); + (0x1D4AD,0x1D4AD), `Abs (0x1D4AD); + (0x1D4BA,0x1D4BA), `Abs (0x1D4BA); + (0x1D4BC,0x1D4BC), `Abs (0x1D4BC); + (0x1D4C4,0x1D4C4), `Abs (0x1D4C4); + (0x1D506,0x1D506), `Abs (0x1D506); + (0x1D50B,0x1D50C), `Delta (0); + (0x1D515,0x1D515), `Abs (0x1D515); + (0x1D51D,0x1D51D), `Abs (0x1D51D); + (0x1D53A,0x1D53A), `Abs (0x1D53A); + (0x1D53F,0x1D53F), `Abs (0x1D53F); + (0x1D545,0x1D545), `Abs (0x1D545); + (0x1D547,0x1D549), `Delta (0); + (0x1D551,0x1D551), `Abs (0x1D551); + (0x1D6A6,0x1D6A7), `Delta (0); + (0x1D7CC,0x1D7CD), `Delta (0); + (0x1DA8C,0x1DA9A), `Delta (0); + (0x1DAA0,0x1DAA0), `Abs (0x1DAA0); + (0x1DAB0,0x1DFFF), `Delta (0); + (0x1E007,0x1E007), `Abs (0x1E007); + (0x1E019,0x1E01A), `Delta (0); + (0x1E022,0x1E022), `Abs (0x1E022); + (0x1E025,0x1E025), `Abs (0x1E025); + (0x1E02B,0x1E7FF), `Delta (0); + (0x1E8C5,0x1E8C6), `Delta (0); + (0x1E8D7,0x1E8FF), `Delta (0); + (0x1E94B,0x1E94F), `Delta (0); + (0x1E95A,0x1E95D), `Delta (0); + (0x1E960,0x1EDFF), `Delta (0); + (0x1EE04,0x1EE04), `Abs (0x1EE04); + (0x1EE20,0x1EE20), `Abs (0x1EE20); + (0x1EE23,0x1EE23), `Abs (0x1EE23); + (0x1EE25,0x1EE26), `Delta (0); + (0x1EE28,0x1EE28), `Abs (0x1EE28); + (0x1EE33,0x1EE33), `Abs (0x1EE33); + (0x1EE38,0x1EE38), `Abs (0x1EE38); + (0x1EE3A,0x1EE3A), `Abs (0x1EE3A); + (0x1EE3C,0x1EE41), `Delta (0); + (0x1EE43,0x1EE46), `Delta (0); + (0x1EE48,0x1EE48), `Abs (0x1EE48); + (0x1EE4A,0x1EE4A), `Abs (0x1EE4A); + (0x1EE4C,0x1EE4C), `Abs (0x1EE4C); + (0x1EE50,0x1EE50), `Abs (0x1EE50); + (0x1EE53,0x1EE53), `Abs (0x1EE53); + (0x1EE55,0x1EE56), `Delta (0); + (0x1EE58,0x1EE58), `Abs (0x1EE58); + (0x1EE5A,0x1EE5A), `Abs (0x1EE5A); + (0x1EE5C,0x1EE5C), `Abs (0x1EE5C); + (0x1EE5E,0x1EE5E), `Abs (0x1EE5E); + (0x1EE60,0x1EE60), `Abs (0x1EE60); + (0x1EE63,0x1EE63), `Abs (0x1EE63); + (0x1EE65,0x1EE66), `Delta (0); + (0x1EE6B,0x1EE6B), `Abs (0x1EE6B); + (0x1EE73,0x1EE73), `Abs (0x1EE73); + (0x1EE78,0x1EE78), `Abs (0x1EE78); + (0x1EE7D,0x1EE7D), `Abs (0x1EE7D); + (0x1EE7F,0x1EE7F), `Abs (0x1EE7F); + (0x1EE8A,0x1EE8A), `Abs (0x1EE8A); + (0x1EE9C,0x1EEA0), `Delta (0); + (0x1EEA4,0x1EEA4), `Abs (0x1EEA4); + (0x1EEAA,0x1EEAA), `Abs (0x1EEAA); + (0x1EEBC,0x1EEEF), `Delta (0); + (0x1EEF2,0x1EFFF), `Delta (0); + (0x1F02C,0x1F02F), `Delta (0); + (0x1F094,0x1F09F), `Delta (0); + (0x1F0AF,0x1F0B0), `Delta (0); + (0x1F0C0,0x1F0C0), `Abs (0x1F0C0); + (0x1F0D0,0x1F0D0), `Abs (0x1F0D0); + (0x1F0F6,0x1F0FF), `Delta (0); + (0x1F10D,0x1F10F), `Delta (0); + (0x1F12F,0x1F12F), `Abs (0x1F12F); + (0x1F16C,0x1F16F), `Delta (0); + (0x1F1AD,0x1F1E5), `Delta (0); + (0x1F203,0x1F20F), `Delta (0); + (0x1F23C,0x1F23F), `Delta (0); + (0x1F249,0x1F24F), `Delta (0); + (0x1F252,0x1F2FF), `Delta (0); + (0x1F6D3,0x1F6DF), `Delta (0); + (0x1F6ED,0x1F6EF), `Delta (0); + (0x1F6F7,0x1F6FF), `Delta (0); + (0x1F774,0x1F77F), `Delta (0); + (0x1F7D5,0x1F7FF), `Delta (0); + (0x1F80C,0x1F80F), `Delta (0); + (0x1F848,0x1F84F), `Delta (0); + (0x1F85A,0x1F85F), `Delta (0); + (0x1F888,0x1F88F), `Delta (0); + (0x1F8AE,0x1F90F), `Delta (0); + (0x1F91F,0x1F91F), `Abs (0x1F91F); + (0x1F928,0x1F92F), `Delta (0); + (0x1F931,0x1F932), `Delta (0); + (0x1F93F,0x1F93F), `Abs (0x1F93F); + (0x1F94C,0x1F94F), `Delta (0); + (0x1F95F,0x1F97F), `Delta (0); + (0x1F992,0x1F9BF), `Delta (0); + (0x1F9C1,0x1FFFF), `Delta (0); + (0x2A6D7,0x2A6FF), `Delta (0); + (0x2B735,0x2B73F), `Delta (0); + (0x2B81E,0x2B81F), `Delta (0); + (0x2CEA2,0x2F7FF), `Delta (0); + (0x2FA1E,0xE0000), `Delta (0); + (0xE0002,0xE001F), `Delta (0); + (0xE0080,0xE00FF), `Delta (0); + (0xE01F0,0xEFFFF), `Delta (0); + (0xFFFFE,0xFFFFF), `Delta (0); + (0x10FFFE,0x10FFFF), `Delta (0); + (0x002B0,0x002C1), `Delta (0); + (0x002C6,0x002D1), `Delta (0); + (0x002E0,0x002E4), `Delta (0); + (0x002EC,0x002EC), `Abs (0x002EC); + (0x002EE,0x002EE), `Abs (0x002EE); + (0x00374,0x00374), `Abs (0x00374); + (0x0037A,0x0037A), `Abs (0x0037A); + (0x00559,0x00559), `Abs (0x00559); + (0x00640,0x00640), `Abs (0x00640); + (0x006E5,0x006E6), `Delta (0); + (0x007F4,0x007F5), `Delta (0); + (0x007FA,0x007FA), `Abs (0x007FA); + (0x0081A,0x0081A), `Abs (0x0081A); + (0x00824,0x00824), `Abs (0x00824); + (0x00828,0x00828), `Abs (0x00828); + (0x00971,0x00971), `Abs (0x00971); + (0x00E46,0x00E46), `Abs (0x00E46); + (0x00EC6,0x00EC6), `Abs (0x00EC6); + (0x010FC,0x010FC), `Abs (0x010FC); + (0x017D7,0x017D7), `Abs (0x017D7); + (0x01843,0x01843), `Abs (0x01843); + (0x01AA7,0x01AA7), `Abs (0x01AA7); + (0x01C78,0x01C7D), `Delta (0); + (0x01D2C,0x01D6A), `Delta (0); + (0x01D78,0x01D78), `Abs (0x01D78); + (0x01D9B,0x01DBF), `Delta (0); + (0x02071,0x02071), `Abs (0x02071); + (0x0207F,0x0207F), `Abs (0x0207F); + (0x02090,0x0209C), `Delta (0); + (0x02C7C,0x02C7D), `Delta (0); + (0x02D6F,0x02D6F), `Abs (0x02D6F); + (0x02E2F,0x02E2F), `Abs (0x02E2F); + (0x03005,0x03005), `Abs (0x03005); + (0x03031,0x03035), `Delta (0); + (0x0303B,0x0303B), `Abs (0x0303B); + (0x0309D,0x0309E), `Delta (0); + (0x030FC,0x030FE), `Delta (0); + (0x0A015,0x0A015), `Abs (0x0A015); + (0x0A4F8,0x0A4FD), `Delta (0); + (0x0A60C,0x0A60C), `Abs (0x0A60C); + (0x0A67F,0x0A67F), `Abs (0x0A67F); + (0x0A69C,0x0A69D), `Delta (0); + (0x0A717,0x0A71F), `Delta (0); + (0x0A770,0x0A770), `Abs (0x0A770); + (0x0A788,0x0A788), `Abs (0x0A788); + (0x0A7F8,0x0A7F9), `Delta (0); + (0x0A9CF,0x0A9CF), `Abs (0x0A9CF); + (0x0A9E6,0x0A9E6), `Abs (0x0A9E6); + (0x0AA70,0x0AA70), `Abs (0x0AA70); + (0x0AADD,0x0AADD), `Abs (0x0AADD); + (0x0AAF3,0x0AAF4), `Delta (0); + (0x0AB5C,0x0AB5F), `Delta (0); + (0x0FF70,0x0FF70), `Abs (0x0FF70); + (0x0FF9E,0x0FF9F), `Delta (0); + (0x16B40,0x16B43), `Delta (0); + (0x16F93,0x16F9F), `Delta (0); + (0x16FE0,0x16FE0), `Abs (0x16FE0); + (0x000AA,0x000AA), `Abs (0x000AA); + (0x000BA,0x000BA), `Abs (0x000BA); + (0x001BB,0x001BB), `Abs (0x001BB); + (0x001C0,0x001C3), `Delta (0); + (0x00294,0x00294), `Abs (0x00294); + (0x005D0,0x005EA), `Delta (0); + (0x005F0,0x005F2), `Delta (0); + (0x00620,0x0063F), `Delta (0); + (0x00641,0x0064A), `Delta (0); + (0x0066E,0x0066F), `Delta (0); + (0x00671,0x006D3), `Delta (0); + (0x006D5,0x006D5), `Abs (0x006D5); + (0x006EE,0x006EF), `Delta (0); + (0x006FA,0x006FC), `Delta (0); + (0x006FF,0x006FF), `Abs (0x006FF); + (0x00710,0x00710), `Abs (0x00710); + (0x00712,0x0072F), `Delta (0); + (0x0074D,0x007A5), `Delta (0); + (0x007B1,0x007B1), `Abs (0x007B1); + (0x007CA,0x007EA), `Delta (0); + (0x00800,0x00815), `Delta (0); + (0x00840,0x00858), `Delta (0); + (0x008A0,0x008B4), `Delta (0); + (0x008B6,0x008BD), `Delta (0); + (0x00904,0x00939), `Delta (0); + (0x0093D,0x0093D), `Abs (0x0093D); + (0x00950,0x00950), `Abs (0x00950); + (0x00958,0x00961), `Delta (0); + (0x00972,0x00980), `Delta (0); + (0x00985,0x0098C), `Delta (0); + (0x0098F,0x00990), `Delta (0); + (0x00993,0x009A8), `Delta (0); + (0x009AA,0x009B0), `Delta (0); + (0x009B2,0x009B2), `Abs (0x009B2); + (0x009B6,0x009B9), `Delta (0); + (0x009BD,0x009BD), `Abs (0x009BD); + (0x009CE,0x009CE), `Abs (0x009CE); + (0x009DC,0x009DD), `Delta (0); + (0x009DF,0x009E1), `Delta (0); + (0x009F0,0x009F1), `Delta (0); + (0x00A05,0x00A0A), `Delta (0); + (0x00A0F,0x00A10), `Delta (0); + (0x00A13,0x00A28), `Delta (0); + (0x00A2A,0x00A30), `Delta (0); + (0x00A32,0x00A33), `Delta (0); + (0x00A35,0x00A36), `Delta (0); + (0x00A38,0x00A39), `Delta (0); + (0x00A59,0x00A5C), `Delta (0); + (0x00A5E,0x00A5E), `Abs (0x00A5E); + (0x00A72,0x00A74), `Delta (0); + (0x00A85,0x00A8D), `Delta (0); + (0x00A8F,0x00A91), `Delta (0); + (0x00A93,0x00AA8), `Delta (0); + (0x00AAA,0x00AB0), `Delta (0); + (0x00AB2,0x00AB3), `Delta (0); + (0x00AB5,0x00AB9), `Delta (0); + (0x00ABD,0x00ABD), `Abs (0x00ABD); + (0x00AD0,0x00AD0), `Abs (0x00AD0); + (0x00AE0,0x00AE1), `Delta (0); + (0x00AF9,0x00AF9), `Abs (0x00AF9); + (0x00B05,0x00B0C), `Delta (0); + (0x00B0F,0x00B10), `Delta (0); + (0x00B13,0x00B28), `Delta (0); + (0x00B2A,0x00B30), `Delta (0); + (0x00B32,0x00B33), `Delta (0); + (0x00B35,0x00B39), `Delta (0); + (0x00B3D,0x00B3D), `Abs (0x00B3D); + (0x00B5C,0x00B5D), `Delta (0); + (0x00B5F,0x00B61), `Delta (0); + (0x00B71,0x00B71), `Abs (0x00B71); + (0x00B83,0x00B83), `Abs (0x00B83); + (0x00B85,0x00B8A), `Delta (0); + (0x00B8E,0x00B90), `Delta (0); + (0x00B92,0x00B95), `Delta (0); + (0x00B99,0x00B9A), `Delta (0); + (0x00B9C,0x00B9C), `Abs (0x00B9C); + (0x00B9E,0x00B9F), `Delta (0); + (0x00BA3,0x00BA4), `Delta (0); + (0x00BA8,0x00BAA), `Delta (0); + (0x00BAE,0x00BB9), `Delta (0); + (0x00BD0,0x00BD0), `Abs (0x00BD0); + (0x00C05,0x00C0C), `Delta (0); + (0x00C0E,0x00C10), `Delta (0); + (0x00C12,0x00C28), `Delta (0); + (0x00C2A,0x00C39), `Delta (0); + (0x00C3D,0x00C3D), `Abs (0x00C3D); + (0x00C58,0x00C5A), `Delta (0); + (0x00C60,0x00C61), `Delta (0); + (0x00C80,0x00C80), `Abs (0x00C80); + (0x00C85,0x00C8C), `Delta (0); + (0x00C8E,0x00C90), `Delta (0); + (0x00C92,0x00CA8), `Delta (0); + (0x00CAA,0x00CB3), `Delta (0); + (0x00CB5,0x00CB9), `Delta (0); + (0x00CBD,0x00CBD), `Abs (0x00CBD); + (0x00CDE,0x00CDE), `Abs (0x00CDE); + (0x00CE0,0x00CE1), `Delta (0); + (0x00CF1,0x00CF2), `Delta (0); + (0x00D05,0x00D0C), `Delta (0); + (0x00D0E,0x00D10), `Delta (0); + (0x00D12,0x00D3A), `Delta (0); + (0x00D3D,0x00D3D), `Abs (0x00D3D); + (0x00D4E,0x00D4E), `Abs (0x00D4E); + (0x00D54,0x00D56), `Delta (0); + (0x00D5F,0x00D61), `Delta (0); + (0x00D7A,0x00D7F), `Delta (0); + (0x00D85,0x00D96), `Delta (0); + (0x00D9A,0x00DB1), `Delta (0); + (0x00DB3,0x00DBB), `Delta (0); + (0x00DBD,0x00DBD), `Abs (0x00DBD); + (0x00DC0,0x00DC6), `Delta (0); + (0x00E01,0x00E30), `Delta (0); + (0x00E32,0x00E33), `Delta (0); + (0x00E40,0x00E45), `Delta (0); + (0x00E81,0x00E82), `Delta (0); + (0x00E84,0x00E84), `Abs (0x00E84); + (0x00E87,0x00E88), `Delta (0); + (0x00E8A,0x00E8A), `Abs (0x00E8A); + (0x00E8D,0x00E8D), `Abs (0x00E8D); + (0x00E94,0x00E97), `Delta (0); + (0x00E99,0x00E9F), `Delta (0); + (0x00EA1,0x00EA3), `Delta (0); + (0x00EA5,0x00EA5), `Abs (0x00EA5); + (0x00EA7,0x00EA7), `Abs (0x00EA7); + (0x00EAA,0x00EAB), `Delta (0); + (0x00EAD,0x00EB0), `Delta (0); + (0x00EB2,0x00EB3), `Delta (0); + (0x00EBD,0x00EBD), `Abs (0x00EBD); + (0x00EC0,0x00EC4), `Delta (0); + (0x00EDC,0x00EDF), `Delta (0); + (0x00F00,0x00F00), `Abs (0x00F00); + (0x00F40,0x00F47), `Delta (0); + (0x00F49,0x00F6C), `Delta (0); + (0x00F88,0x00F8C), `Delta (0); + (0x01000,0x0102A), `Delta (0); + (0x0103F,0x0103F), `Abs (0x0103F); + (0x01050,0x01055), `Delta (0); + (0x0105A,0x0105D), `Delta (0); + (0x01061,0x01061), `Abs (0x01061); + (0x01065,0x01066), `Delta (0); + (0x0106E,0x01070), `Delta (0); + (0x01075,0x01081), `Delta (0); + (0x0108E,0x0108E), `Abs (0x0108E); + (0x010D0,0x010FA), `Delta (0); + (0x010FD,0x01248), `Delta (0); + (0x0124A,0x0124D), `Delta (0); + (0x01250,0x01256), `Delta (0); + (0x01258,0x01258), `Abs (0x01258); + (0x0125A,0x0125D), `Delta (0); + (0x01260,0x01288), `Delta (0); + (0x0128A,0x0128D), `Delta (0); + (0x01290,0x012B0), `Delta (0); + (0x012B2,0x012B5), `Delta (0); + (0x012B8,0x012BE), `Delta (0); + (0x012C0,0x012C0), `Abs (0x012C0); + (0x012C2,0x012C5), `Delta (0); + (0x012C8,0x012D6), `Delta (0); + (0x012D8,0x01310), `Delta (0); + (0x01312,0x01315), `Delta (0); + (0x01318,0x0135A), `Delta (0); + (0x01380,0x0138F), `Delta (0); + (0x01401,0x0166C), `Delta (0); + (0x0166F,0x0167F), `Delta (0); + (0x01681,0x0169A), `Delta (0); + (0x016A0,0x016EA), `Delta (0); + (0x016F1,0x016F8), `Delta (0); + (0x01700,0x0170C), `Delta (0); + (0x0170E,0x01711), `Delta (0); + (0x01720,0x01731), `Delta (0); + (0x01740,0x01751), `Delta (0); + (0x01760,0x0176C), `Delta (0); + (0x0176E,0x01770), `Delta (0); + (0x01780,0x017B3), `Delta (0); + (0x017DC,0x017DC), `Abs (0x017DC); + (0x01820,0x01842), `Delta (0); + (0x01844,0x01877), `Delta (0); + (0x01880,0x01884), `Delta (0); + (0x01887,0x018A8), `Delta (0); + (0x018AA,0x018AA), `Abs (0x018AA); + (0x018B0,0x018F5), `Delta (0); + (0x01900,0x0191E), `Delta (0); + (0x01950,0x0196D), `Delta (0); + (0x01970,0x01974), `Delta (0); + (0x01980,0x019AB), `Delta (0); + (0x019B0,0x019C9), `Delta (0); + (0x01A00,0x01A16), `Delta (0); + (0x01A20,0x01A54), `Delta (0); + (0x01B05,0x01B33), `Delta (0); + (0x01B45,0x01B4B), `Delta (0); + (0x01B83,0x01BA0), `Delta (0); + (0x01BAE,0x01BAF), `Delta (0); + (0x01BBA,0x01BE5), `Delta (0); + (0x01C00,0x01C23), `Delta (0); + (0x01C4D,0x01C4F), `Delta (0); + (0x01C5A,0x01C77), `Delta (0); + (0x01CE9,0x01CEC), `Delta (0); + (0x01CEE,0x01CF1), `Delta (0); + (0x01CF5,0x01CF6), `Delta (0); + (0x02135,0x02138), `Delta (0); + (0x02D30,0x02D67), `Delta (0); + (0x02D80,0x02D96), `Delta (0); + (0x02DA0,0x02DA6), `Delta (0); + (0x02DA8,0x02DAE), `Delta (0); + (0x02DB0,0x02DB6), `Delta (0); + (0x02DB8,0x02DBE), `Delta (0); + (0x02DC0,0x02DC6), `Delta (0); + (0x02DC8,0x02DCE), `Delta (0); + (0x02DD0,0x02DD6), `Delta (0); + (0x02DD8,0x02DDE), `Delta (0); + (0x03006,0x03006), `Abs (0x03006); + (0x0303C,0x0303C), `Abs (0x0303C); + (0x03041,0x03096), `Delta (0); + (0x0309F,0x0309F), `Abs (0x0309F); + (0x030A1,0x030FA), `Delta (0); + (0x030FF,0x030FF), `Abs (0x030FF); + (0x03105,0x0312D), `Delta (0); + (0x03131,0x0318E), `Delta (0); + (0x031A0,0x031BA), `Delta (0); + (0x031F0,0x031FF), `Delta (0); + (0x03400,0x04DB5), `Delta (0); + (0x04E00,0x09FD5), `Delta (0); + (0x0A000,0x0A014), `Delta (0); + (0x0A016,0x0A48C), `Delta (0); + (0x0A4D0,0x0A4F7), `Delta (0); + (0x0A500,0x0A60B), `Delta (0); + (0x0A610,0x0A61F), `Delta (0); + (0x0A62A,0x0A62B), `Delta (0); + (0x0A66E,0x0A66E), `Abs (0x0A66E); + (0x0A6A0,0x0A6E5), `Delta (0); + (0x0A78F,0x0A78F), `Abs (0x0A78F); + (0x0A7F7,0x0A7F7), `Abs (0x0A7F7); + (0x0A7FB,0x0A801), `Delta (0); + (0x0A803,0x0A805), `Delta (0); + (0x0A807,0x0A80A), `Delta (0); + (0x0A80C,0x0A822), `Delta (0); + (0x0A840,0x0A873), `Delta (0); + (0x0A882,0x0A8B3), `Delta (0); + (0x0A8F2,0x0A8F7), `Delta (0); + (0x0A8FB,0x0A8FB), `Abs (0x0A8FB); + (0x0A8FD,0x0A8FD), `Abs (0x0A8FD); + (0x0A90A,0x0A925), `Delta (0); + (0x0A930,0x0A946), `Delta (0); + (0x0A960,0x0A97C), `Delta (0); + (0x0A984,0x0A9B2), `Delta (0); + (0x0A9E0,0x0A9E4), `Delta (0); + (0x0A9E7,0x0A9EF), `Delta (0); + (0x0A9FA,0x0A9FE), `Delta (0); + (0x0AA00,0x0AA28), `Delta (0); + (0x0AA40,0x0AA42), `Delta (0); + (0x0AA44,0x0AA4B), `Delta (0); + (0x0AA60,0x0AA6F), `Delta (0); + (0x0AA71,0x0AA76), `Delta (0); + (0x0AA7A,0x0AA7A), `Abs (0x0AA7A); + (0x0AA7E,0x0AAAF), `Delta (0); + (0x0AAB1,0x0AAB1), `Abs (0x0AAB1); + (0x0AAB5,0x0AAB6), `Delta (0); + (0x0AAB9,0x0AABD), `Delta (0); + (0x0AAC0,0x0AAC0), `Abs (0x0AAC0); + (0x0AAC2,0x0AAC2), `Abs (0x0AAC2); + (0x0AADB,0x0AADC), `Delta (0); + (0x0AAE0,0x0AAEA), `Delta (0); + (0x0AAF2,0x0AAF2), `Abs (0x0AAF2); + (0x0AB01,0x0AB06), `Delta (0); + (0x0AB09,0x0AB0E), `Delta (0); + (0x0AB11,0x0AB16), `Delta (0); + (0x0AB20,0x0AB26), `Delta (0); + (0x0AB28,0x0AB2E), `Delta (0); + (0x0ABC0,0x0ABE2), `Delta (0); + (0x0AC00,0x0D7A3), `Delta (0); + (0x0D7B0,0x0D7C6), `Delta (0); + (0x0D7CB,0x0D7FB), `Delta (0); + (0x0F900,0x0FA6D), `Delta (0); + (0x0FA70,0x0FAD9), `Delta (0); + (0x0FB1D,0x0FB1D), `Abs (0x0FB1D); + (0x0FB1F,0x0FB28), `Delta (0); + (0x0FB2A,0x0FB36), `Delta (0); + (0x0FB38,0x0FB3C), `Delta (0); + (0x0FB3E,0x0FB3E), `Abs (0x0FB3E); + (0x0FB40,0x0FB41), `Delta (0); + (0x0FB43,0x0FB44), `Delta (0); + (0x0FB46,0x0FBB1), `Delta (0); + (0x0FBD3,0x0FD3D), `Delta (0); + (0x0FD50,0x0FD8F), `Delta (0); + (0x0FD92,0x0FDC7), `Delta (0); + (0x0FDF0,0x0FDFB), `Delta (0); + (0x0FE70,0x0FE74), `Delta (0); + (0x0FE76,0x0FEFC), `Delta (0); + (0x0FF66,0x0FF6F), `Delta (0); + (0x0FF71,0x0FF9D), `Delta (0); + (0x0FFA0,0x0FFBE), `Delta (0); + (0x0FFC2,0x0FFC7), `Delta (0); + (0x0FFCA,0x0FFCF), `Delta (0); + (0x0FFD2,0x0FFD7), `Delta (0); + (0x0FFDA,0x0FFDC), `Delta (0); + (0x10000,0x1000B), `Delta (0); + (0x1000D,0x10026), `Delta (0); + (0x10028,0x1003A), `Delta (0); + (0x1003C,0x1003D), `Delta (0); + (0x1003F,0x1004D), `Delta (0); + (0x10050,0x1005D), `Delta (0); + (0x10080,0x100FA), `Delta (0); + (0x10280,0x1029C), `Delta (0); + (0x102A0,0x102D0), `Delta (0); + (0x10300,0x1031F), `Delta (0); + (0x10330,0x10340), `Delta (0); + (0x10342,0x10349), `Delta (0); + (0x10350,0x10375), `Delta (0); + (0x10380,0x1039D), `Delta (0); + (0x103A0,0x103C3), `Delta (0); + (0x103C8,0x103CF), `Delta (0); + (0x10450,0x1049D), `Delta (0); + (0x10500,0x10527), `Delta (0); + (0x10530,0x10563), `Delta (0); + (0x10600,0x10736), `Delta (0); + (0x10740,0x10755), `Delta (0); + (0x10760,0x10767), `Delta (0); + (0x10800,0x10805), `Delta (0); + (0x10808,0x10808), `Abs (0x10808); + (0x1080A,0x10835), `Delta (0); + (0x10837,0x10838), `Delta (0); + (0x1083C,0x1083C), `Abs (0x1083C); + (0x1083F,0x10855), `Delta (0); + (0x10860,0x10876), `Delta (0); + (0x10880,0x1089E), `Delta (0); + (0x108E0,0x108F2), `Delta (0); + (0x108F4,0x108F5), `Delta (0); + (0x10900,0x10915), `Delta (0); + (0x10920,0x10939), `Delta (0); + (0x10980,0x109B7), `Delta (0); + (0x109BE,0x109BF), `Delta (0); + (0x10A00,0x10A00), `Abs (0x10A00); + (0x10A10,0x10A13), `Delta (0); + (0x10A15,0x10A17), `Delta (0); + (0x10A19,0x10A33), `Delta (0); + (0x10A60,0x10A7C), `Delta (0); + (0x10A80,0x10A9C), `Delta (0); + (0x10AC0,0x10AC7), `Delta (0); + (0x10AC9,0x10AE4), `Delta (0); + (0x10B00,0x10B35), `Delta (0); + (0x10B40,0x10B55), `Delta (0); + (0x10B60,0x10B72), `Delta (0); + (0x10B80,0x10B91), `Delta (0); + (0x10C00,0x10C48), `Delta (0); + (0x11003,0x11037), `Delta (0); + (0x11083,0x110AF), `Delta (0); + (0x110D0,0x110E8), `Delta (0); + (0x11103,0x11126), `Delta (0); + (0x11150,0x11172), `Delta (0); + (0x11176,0x11176), `Abs (0x11176); + (0x11183,0x111B2), `Delta (0); + (0x111C1,0x111C4), `Delta (0); + (0x111DA,0x111DA), `Abs (0x111DA); + (0x111DC,0x111DC), `Abs (0x111DC); + (0x11200,0x11211), `Delta (0); + (0x11213,0x1122B), `Delta (0); + (0x11280,0x11286), `Delta (0); + (0x11288,0x11288), `Abs (0x11288); + (0x1128A,0x1128D), `Delta (0); + (0x1128F,0x1129D), `Delta (0); + (0x1129F,0x112A8), `Delta (0); + (0x112B0,0x112DE), `Delta (0); + (0x11305,0x1130C), `Delta (0); + (0x1130F,0x11310), `Delta (0); + (0x11313,0x11328), `Delta (0); + (0x1132A,0x11330), `Delta (0); + (0x11332,0x11333), `Delta (0); + (0x11335,0x11339), `Delta (0); + (0x1133D,0x1133D), `Abs (0x1133D); + (0x11350,0x11350), `Abs (0x11350); + (0x1135D,0x11361), `Delta (0); + (0x11400,0x11434), `Delta (0); + (0x11447,0x1144A), `Delta (0); + (0x11480,0x114AF), `Delta (0); + (0x114C4,0x114C5), `Delta (0); + (0x114C7,0x114C7), `Abs (0x114C7); + (0x11580,0x115AE), `Delta (0); + (0x115D8,0x115DB), `Delta (0); + (0x11600,0x1162F), `Delta (0); + (0x11644,0x11644), `Abs (0x11644); + (0x11680,0x116AA), `Delta (0); + (0x11700,0x11719), `Delta (0); + (0x118FF,0x118FF), `Abs (0x118FF); + (0x11AC0,0x11AF8), `Delta (0); + (0x11C00,0x11C08), `Delta (0); + (0x11C0A,0x11C2E), `Delta (0); + (0x11C40,0x11C40), `Abs (0x11C40); + (0x11C72,0x11C8F), `Delta (0); + (0x12000,0x12399), `Delta (0); + (0x12480,0x12543), `Delta (0); + (0x13000,0x1342E), `Delta (0); + (0x14400,0x14646), `Delta (0); + (0x16800,0x16A38), `Delta (0); + (0x16A40,0x16A5E), `Delta (0); + (0x16AD0,0x16AED), `Delta (0); + (0x16B00,0x16B2F), `Delta (0); + (0x16B63,0x16B77), `Delta (0); + (0x16B7D,0x16B8F), `Delta (0); + (0x16F00,0x16F44), `Delta (0); + (0x16F50,0x16F50), `Abs (0x16F50); + (0x17000,0x187EC), `Delta (0); + (0x18800,0x18AF2), `Delta (0); + (0x1B000,0x1B001), `Delta (0); + (0x1BC00,0x1BC6A), `Delta (0); + (0x1BC70,0x1BC7C), `Delta (0); + (0x1BC80,0x1BC88), `Delta (0); + (0x1BC90,0x1BC99), `Delta (0); + (0x1E800,0x1E8C4), `Delta (0); + (0x1EE00,0x1EE03), `Delta (0); + (0x1EE05,0x1EE1F), `Delta (0); + (0x1EE21,0x1EE22), `Delta (0); + (0x1EE24,0x1EE24), `Abs (0x1EE24); + (0x1EE27,0x1EE27), `Abs (0x1EE27); + (0x1EE29,0x1EE32), `Delta (0); + (0x1EE34,0x1EE37), `Delta (0); + (0x1EE39,0x1EE39), `Abs (0x1EE39); + (0x1EE3B,0x1EE3B), `Abs (0x1EE3B); + (0x1EE42,0x1EE42), `Abs (0x1EE42); + (0x1EE47,0x1EE47), `Abs (0x1EE47); + (0x1EE49,0x1EE49), `Abs (0x1EE49); + (0x1EE4B,0x1EE4B), `Abs (0x1EE4B); + (0x1EE4D,0x1EE4F), `Delta (0); + (0x1EE51,0x1EE52), `Delta (0); + (0x1EE54,0x1EE54), `Abs (0x1EE54); + (0x1EE57,0x1EE57), `Abs (0x1EE57); + (0x1EE59,0x1EE59), `Abs (0x1EE59); + (0x1EE5B,0x1EE5B), `Abs (0x1EE5B); + (0x1EE5D,0x1EE5D), `Abs (0x1EE5D); + (0x1EE5F,0x1EE5F), `Abs (0x1EE5F); + (0x1EE61,0x1EE62), `Delta (0); + (0x1EE64,0x1EE64), `Abs (0x1EE64); + (0x1EE67,0x1EE6A), `Delta (0); + (0x1EE6C,0x1EE72), `Delta (0); + (0x1EE74,0x1EE77), `Delta (0); + (0x1EE79,0x1EE7C), `Delta (0); + (0x1EE7E,0x1EE7E), `Abs (0x1EE7E); + (0x1EE80,0x1EE89), `Delta (0); + (0x1EE8B,0x1EE9B), `Delta (0); + (0x1EEA1,0x1EEA3), `Delta (0); + (0x1EEA5,0x1EEA9), `Delta (0); + (0x1EEAB,0x1EEBB), `Delta (0); + (0x20000,0x2A6D6), `Delta (0); + (0x2A700,0x2B734), `Delta (0); + (0x2B740,0x2B81D), `Delta (0); + (0x2B820,0x2CEA1), `Delta (0); + (0x2F800,0x2FA1D), `Delta (0); + (0x0005F,0x0005F), `Abs (0x0005F); + (0x0203F,0x02040), `Delta (0); + (0x02054,0x02054), `Abs (0x02054); + (0x0FE33,0x0FE34), `Delta (0); + (0x0FE4D,0x0FE4F), `Delta (0); + (0x0FF3F,0x0FF3F), `Abs (0x0FF3F); + (0x0002D,0x0002D), `Abs (0x0002D); + (0x0058A,0x0058A), `Abs (0x0058A); + (0x005BE,0x005BE), `Abs (0x005BE); + (0x01400,0x01400), `Abs (0x01400); + (0x01806,0x01806), `Abs (0x01806); + (0x02010,0x02015), `Delta (0); + (0x02E17,0x02E17), `Abs (0x02E17); + (0x02E1A,0x02E1A), `Abs (0x02E1A); + (0x02E3A,0x02E3B), `Delta (0); + (0x02E40,0x02E40), `Abs (0x02E40); + (0x0301C,0x0301C), `Abs (0x0301C); + (0x03030,0x03030), `Abs (0x03030); + (0x030A0,0x030A0), `Abs (0x030A0); + (0x0FE31,0x0FE32), `Delta (0); + (0x0FE58,0x0FE58), `Abs (0x0FE58); + (0x0FE63,0x0FE63), `Abs (0x0FE63); + (0x0FF0D,0x0FF0D), `Abs (0x0FF0D); + (0x00028,0x00028), `Abs (0x00028); + (0x0005B,0x0005B), `Abs (0x0005B); + (0x0007B,0x0007B), `Abs (0x0007B); + (0x00F3A,0x00F3A), `Abs (0x00F3A); + (0x00F3C,0x00F3C), `Abs (0x00F3C); + (0x0169B,0x0169B), `Abs (0x0169B); + (0x0201A,0x0201A), `Abs (0x0201A); + (0x0201E,0x0201E), `Abs (0x0201E); + (0x02045,0x02045), `Abs (0x02045); + (0x0207D,0x0207D), `Abs (0x0207D); + (0x0208D,0x0208D), `Abs (0x0208D); + (0x02308,0x02308), `Abs (0x02308); + (0x0230A,0x0230A), `Abs (0x0230A); + (0x02329,0x02329), `Abs (0x02329); + (0x02768,0x02768), `Abs (0x02768); + (0x0276A,0x0276A), `Abs (0x0276A); + (0x0276C,0x0276C), `Abs (0x0276C); + (0x0276E,0x0276E), `Abs (0x0276E); + (0x02770,0x02770), `Abs (0x02770); + (0x02772,0x02772), `Abs (0x02772); + (0x02774,0x02774), `Abs (0x02774); + (0x027C5,0x027C5), `Abs (0x027C5); + (0x027E6,0x027E6), `Abs (0x027E6); + (0x027E8,0x027E8), `Abs (0x027E8); + (0x027EA,0x027EA), `Abs (0x027EA); + (0x027EC,0x027EC), `Abs (0x027EC); + (0x027EE,0x027EE), `Abs (0x027EE); + (0x02983,0x02983), `Abs (0x02983); + (0x02985,0x02985), `Abs (0x02985); + (0x02987,0x02987), `Abs (0x02987); + (0x02989,0x02989), `Abs (0x02989); + (0x0298B,0x0298B), `Abs (0x0298B); + (0x0298D,0x0298D), `Abs (0x0298D); + (0x0298F,0x0298F), `Abs (0x0298F); + (0x02991,0x02991), `Abs (0x02991); + (0x02993,0x02993), `Abs (0x02993); + (0x02995,0x02995), `Abs (0x02995); + (0x02997,0x02997), `Abs (0x02997); + (0x029D8,0x029D8), `Abs (0x029D8); + (0x029DA,0x029DA), `Abs (0x029DA); + (0x029FC,0x029FC), `Abs (0x029FC); + (0x02E22,0x02E22), `Abs (0x02E22); + (0x02E24,0x02E24), `Abs (0x02E24); + (0x02E26,0x02E26), `Abs (0x02E26); + (0x02E28,0x02E28), `Abs (0x02E28); + (0x02E42,0x02E42), `Abs (0x02E42); + (0x03008,0x03008), `Abs (0x03008); + (0x0300A,0x0300A), `Abs (0x0300A); + (0x0300C,0x0300C), `Abs (0x0300C); + (0x0300E,0x0300E), `Abs (0x0300E); + (0x03010,0x03010), `Abs (0x03010); + (0x03014,0x03014), `Abs (0x03014); + (0x03016,0x03016), `Abs (0x03016); + (0x03018,0x03018), `Abs (0x03018); + (0x0301A,0x0301A), `Abs (0x0301A); + (0x0301D,0x0301D), `Abs (0x0301D); + (0x0FD3F,0x0FD3F), `Abs (0x0FD3F); + (0x0FE17,0x0FE17), `Abs (0x0FE17); + (0x0FE35,0x0FE35), `Abs (0x0FE35); + (0x0FE37,0x0FE37), `Abs (0x0FE37); + (0x0FE39,0x0FE39), `Abs (0x0FE39); + (0x0FE3B,0x0FE3B), `Abs (0x0FE3B); + (0x0FE3D,0x0FE3D), `Abs (0x0FE3D); + (0x0FE3F,0x0FE3F), `Abs (0x0FE3F); + (0x0FE41,0x0FE41), `Abs (0x0FE41); + (0x0FE43,0x0FE43), `Abs (0x0FE43); + (0x0FE47,0x0FE47), `Abs (0x0FE47); + (0x0FE59,0x0FE59), `Abs (0x0FE59); + (0x0FE5B,0x0FE5B), `Abs (0x0FE5B); + (0x0FE5D,0x0FE5D), `Abs (0x0FE5D); + (0x0FF08,0x0FF08), `Abs (0x0FF08); + (0x0FF3B,0x0FF3B), `Abs (0x0FF3B); + (0x0FF5B,0x0FF5B), `Abs (0x0FF5B); + (0x0FF5F,0x0FF5F), `Abs (0x0FF5F); + (0x0FF62,0x0FF62), `Abs (0x0FF62); + (0x00029,0x00029), `Abs (0x00029); + (0x0005D,0x0005D), `Abs (0x0005D); + (0x0007D,0x0007D), `Abs (0x0007D); + (0x00F3B,0x00F3B), `Abs (0x00F3B); + (0x00F3D,0x00F3D), `Abs (0x00F3D); + (0x0169C,0x0169C), `Abs (0x0169C); + (0x02046,0x02046), `Abs (0x02046); + (0x0207E,0x0207E), `Abs (0x0207E); + (0x0208E,0x0208E), `Abs (0x0208E); + (0x02309,0x02309), `Abs (0x02309); + (0x0230B,0x0230B), `Abs (0x0230B); + (0x0232A,0x0232A), `Abs (0x0232A); + (0x02769,0x02769), `Abs (0x02769); + (0x0276B,0x0276B), `Abs (0x0276B); + (0x0276D,0x0276D), `Abs (0x0276D); + (0x0276F,0x0276F), `Abs (0x0276F); + (0x02771,0x02771), `Abs (0x02771); + (0x02773,0x02773), `Abs (0x02773); + (0x02775,0x02775), `Abs (0x02775); + (0x027C6,0x027C6), `Abs (0x027C6); + (0x027E7,0x027E7), `Abs (0x027E7); + (0x027E9,0x027E9), `Abs (0x027E9); + (0x027EB,0x027EB), `Abs (0x027EB); + (0x027ED,0x027ED), `Abs (0x027ED); + (0x027EF,0x027EF), `Abs (0x027EF); + (0x02984,0x02984), `Abs (0x02984); + (0x02986,0x02986), `Abs (0x02986); + (0x02988,0x02988), `Abs (0x02988); + (0x0298A,0x0298A), `Abs (0x0298A); + (0x0298C,0x0298C), `Abs (0x0298C); + (0x0298E,0x0298E), `Abs (0x0298E); + (0x02990,0x02990), `Abs (0x02990); + (0x02992,0x02992), `Abs (0x02992); + (0x02994,0x02994), `Abs (0x02994); + (0x02996,0x02996), `Abs (0x02996); + (0x02998,0x02998), `Abs (0x02998); + (0x029D9,0x029D9), `Abs (0x029D9); + (0x029DB,0x029DB), `Abs (0x029DB); + (0x029FD,0x029FD), `Abs (0x029FD); + (0x02E23,0x02E23), `Abs (0x02E23); + (0x02E25,0x02E25), `Abs (0x02E25); + (0x02E27,0x02E27), `Abs (0x02E27); + (0x02E29,0x02E29), `Abs (0x02E29); + (0x03009,0x03009), `Abs (0x03009); + (0x0300B,0x0300B), `Abs (0x0300B); + (0x0300D,0x0300D), `Abs (0x0300D); + (0x0300F,0x0300F), `Abs (0x0300F); + (0x03011,0x03011), `Abs (0x03011); + (0x03015,0x03015), `Abs (0x03015); + (0x03017,0x03017), `Abs (0x03017); + (0x03019,0x03019), `Abs (0x03019); + (0x0301B,0x0301B), `Abs (0x0301B); + (0x0301E,0x0301F), `Delta (0); + (0x0FD3E,0x0FD3E), `Abs (0x0FD3E); + (0x0FE18,0x0FE18), `Abs (0x0FE18); + (0x0FE36,0x0FE36), `Abs (0x0FE36); + (0x0FE38,0x0FE38), `Abs (0x0FE38); + (0x0FE3A,0x0FE3A), `Abs (0x0FE3A); + (0x0FE3C,0x0FE3C), `Abs (0x0FE3C); + (0x0FE3E,0x0FE3E), `Abs (0x0FE3E); + (0x0FE40,0x0FE40), `Abs (0x0FE40); + (0x0FE42,0x0FE42), `Abs (0x0FE42); + (0x0FE44,0x0FE44), `Abs (0x0FE44); + (0x0FE48,0x0FE48), `Abs (0x0FE48); + (0x0FE5A,0x0FE5A), `Abs (0x0FE5A); + (0x0FE5C,0x0FE5C), `Abs (0x0FE5C); + (0x0FE5E,0x0FE5E), `Abs (0x0FE5E); + (0x0FF09,0x0FF09), `Abs (0x0FF09); + (0x0FF3D,0x0FF3D), `Abs (0x0FF3D); + (0x0FF5D,0x0FF5D), `Abs (0x0FF5D); + (0x0FF60,0x0FF60), `Abs (0x0FF60); + (0x0FF63,0x0FF63), `Abs (0x0FF63); + (0x000AB,0x000AB), `Abs (0x000AB); + (0x02018,0x02018), `Abs (0x02018); + (0x0201B,0x0201C), `Delta (0); + (0x0201F,0x0201F), `Abs (0x0201F); + (0x02039,0x02039), `Abs (0x02039); + (0x02E02,0x02E02), `Abs (0x02E02); + (0x02E04,0x02E04), `Abs (0x02E04); + (0x02E09,0x02E09), `Abs (0x02E09); + (0x02E0C,0x02E0C), `Abs (0x02E0C); + (0x02E1C,0x02E1C), `Abs (0x02E1C); + (0x02E20,0x02E20), `Abs (0x02E20); + (0x000BB,0x000BB), `Abs (0x000BB); + (0x02019,0x02019), `Abs (0x02019); + (0x0201D,0x0201D), `Abs (0x0201D); + (0x0203A,0x0203A), `Abs (0x0203A); + (0x02E03,0x02E03), `Abs (0x02E03); + (0x02E05,0x02E05), `Abs (0x02E05); + (0x02E0A,0x02E0A), `Abs (0x02E0A); + (0x02E0D,0x02E0D), `Abs (0x02E0D); + (0x02E1D,0x02E1D), `Abs (0x02E1D); + (0x02E21,0x02E21), `Abs (0x02E21); + (0x00021,0x00023), `Delta (0); + (0x00025,0x00027), `Delta (0); + (0x0002A,0x0002A), `Abs (0x0002A); + (0x0002C,0x0002C), `Abs (0x0002C); + (0x0002E,0x0002F), `Delta (0); + (0x0003A,0x0003B), `Delta (0); + (0x0003F,0x00040), `Delta (0); + (0x0005C,0x0005C), `Abs (0x0005C); + (0x000A1,0x000A1), `Abs (0x000A1); + (0x000A7,0x000A7), `Abs (0x000A7); + (0x000B6,0x000B7), `Delta (0); + (0x000BF,0x000BF), `Abs (0x000BF); + (0x0037E,0x0037E), `Abs (0x0037E); + (0x00387,0x00387), `Abs (0x00387); + (0x0055A,0x0055F), `Delta (0); + (0x00589,0x00589), `Abs (0x00589); + (0x005C0,0x005C0), `Abs (0x005C0); + (0x005C3,0x005C3), `Abs (0x005C3); + (0x005C6,0x005C6), `Abs (0x005C6); + (0x005F3,0x005F4), `Delta (0); + (0x00609,0x0060A), `Delta (0); + (0x0060C,0x0060D), `Delta (0); + (0x0061B,0x0061B), `Abs (0x0061B); + (0x0061E,0x0061F), `Delta (0); + (0x0066A,0x0066D), `Delta (0); + (0x006D4,0x006D4), `Abs (0x006D4); + (0x00700,0x0070D), `Delta (0); + (0x007F7,0x007F9), `Delta (0); + (0x00830,0x0083E), `Delta (0); + (0x0085E,0x0085E), `Abs (0x0085E); + (0x00964,0x00965), `Delta (0); + (0x00970,0x00970), `Abs (0x00970); + (0x00AF0,0x00AF0), `Abs (0x00AF0); + (0x00DF4,0x00DF4), `Abs (0x00DF4); + (0x00E4F,0x00E4F), `Abs (0x00E4F); + (0x00E5A,0x00E5B), `Delta (0); + (0x00F04,0x00F12), `Delta (0); + (0x00F14,0x00F14), `Abs (0x00F14); + (0x00F85,0x00F85), `Abs (0x00F85); + (0x00FD0,0x00FD4), `Delta (0); + (0x00FD9,0x00FDA), `Delta (0); + (0x0104A,0x0104F), `Delta (0); + (0x010FB,0x010FB), `Abs (0x010FB); + (0x01360,0x01368), `Delta (0); + (0x0166D,0x0166E), `Delta (0); + (0x016EB,0x016ED), `Delta (0); + (0x01735,0x01736), `Delta (0); + (0x017D4,0x017D6), `Delta (0); + (0x017D8,0x017DA), `Delta (0); + (0x01800,0x01805), `Delta (0); + (0x01807,0x0180A), `Delta (0); + (0x01944,0x01945), `Delta (0); + (0x01A1E,0x01A1F), `Delta (0); + (0x01AA0,0x01AA6), `Delta (0); + (0x01AA8,0x01AAD), `Delta (0); + (0x01B5A,0x01B60), `Delta (0); + (0x01BFC,0x01BFF), `Delta (0); + (0x01C3B,0x01C3F), `Delta (0); + (0x01C7E,0x01C7F), `Delta (0); + (0x01CC0,0x01CC7), `Delta (0); + (0x01CD3,0x01CD3), `Abs (0x01CD3); + (0x02016,0x02017), `Delta (0); + (0x02020,0x02027), `Delta (0); + (0x02030,0x02038), `Delta (0); + (0x0203B,0x0203E), `Delta (0); + (0x02041,0x02043), `Delta (0); + (0x02047,0x02051), `Delta (0); + (0x02053,0x02053), `Abs (0x02053); + (0x02055,0x0205E), `Delta (0); + (0x02CF9,0x02CFC), `Delta (0); + (0x02CFE,0x02CFF), `Delta (0); + (0x02D70,0x02D70), `Abs (0x02D70); + (0x02E00,0x02E01), `Delta (0); + (0x02E06,0x02E08), `Delta (0); + (0x02E0B,0x02E0B), `Abs (0x02E0B); + (0x02E0E,0x02E16), `Delta (0); + (0x02E18,0x02E19), `Delta (0); + (0x02E1B,0x02E1B), `Abs (0x02E1B); + (0x02E1E,0x02E1F), `Delta (0); + (0x02E2A,0x02E2E), `Delta (0); + (0x02E30,0x02E39), `Delta (0); + (0x02E3C,0x02E3F), `Delta (0); + (0x02E41,0x02E41), `Abs (0x02E41); + (0x02E43,0x02E44), `Delta (0); + (0x03001,0x03003), `Delta (0); + (0x0303D,0x0303D), `Abs (0x0303D); + (0x030FB,0x030FB), `Abs (0x030FB); + (0x0A4FE,0x0A4FF), `Delta (0); + (0x0A60D,0x0A60F), `Delta (0); + (0x0A673,0x0A673), `Abs (0x0A673); + (0x0A67E,0x0A67E), `Abs (0x0A67E); + (0x0A6F2,0x0A6F7), `Delta (0); + (0x0A874,0x0A877), `Delta (0); + (0x0A8CE,0x0A8CF), `Delta (0); + (0x0A8F8,0x0A8FA), `Delta (0); + (0x0A8FC,0x0A8FC), `Abs (0x0A8FC); + (0x0A92E,0x0A92F), `Delta (0); + (0x0A95F,0x0A95F), `Abs (0x0A95F); + (0x0A9C1,0x0A9CD), `Delta (0); + (0x0A9DE,0x0A9DF), `Delta (0); + (0x0AA5C,0x0AA5F), `Delta (0); + (0x0AADE,0x0AADF), `Delta (0); + (0x0AAF0,0x0AAF1), `Delta (0); + (0x0ABEB,0x0ABEB), `Abs (0x0ABEB); + (0x0FE10,0x0FE16), `Delta (0); + (0x0FE19,0x0FE19), `Abs (0x0FE19); + (0x0FE30,0x0FE30), `Abs (0x0FE30); + (0x0FE45,0x0FE46), `Delta (0); + (0x0FE49,0x0FE4C), `Delta (0); + (0x0FE50,0x0FE52), `Delta (0); + (0x0FE54,0x0FE57), `Delta (0); + (0x0FE5F,0x0FE61), `Delta (0); + (0x0FE68,0x0FE68), `Abs (0x0FE68); + (0x0FE6A,0x0FE6B), `Delta (0); + (0x0FF01,0x0FF03), `Delta (0); + (0x0FF05,0x0FF07), `Delta (0); + (0x0FF0A,0x0FF0A), `Abs (0x0FF0A); + (0x0FF0C,0x0FF0C), `Abs (0x0FF0C); + (0x0FF0E,0x0FF0F), `Delta (0); + (0x0FF1A,0x0FF1B), `Delta (0); + (0x0FF1F,0x0FF20), `Delta (0); + (0x0FF3C,0x0FF3C), `Abs (0x0FF3C); + (0x0FF61,0x0FF61), `Abs (0x0FF61); + (0x0FF64,0x0FF65), `Delta (0); + (0x10100,0x10102), `Delta (0); + (0x1039F,0x1039F), `Abs (0x1039F); + (0x103D0,0x103D0), `Abs (0x103D0); + (0x1056F,0x1056F), `Abs (0x1056F); + (0x10857,0x10857), `Abs (0x10857); + (0x1091F,0x1091F), `Abs (0x1091F); + (0x1093F,0x1093F), `Abs (0x1093F); + (0x10A50,0x10A58), `Delta (0); + (0x10A7F,0x10A7F), `Abs (0x10A7F); + (0x10AF0,0x10AF6), `Delta (0); + (0x10B39,0x10B3F), `Delta (0); + (0x10B99,0x10B9C), `Delta (0); + (0x11047,0x1104D), `Delta (0); + (0x110BB,0x110BC), `Delta (0); + (0x110BE,0x110C1), `Delta (0); + (0x11140,0x11143), `Delta (0); + (0x11174,0x11175), `Delta (0); + (0x111C5,0x111C9), `Delta (0); + (0x111CD,0x111CD), `Abs (0x111CD); + (0x111DB,0x111DB), `Abs (0x111DB); + (0x111DD,0x111DF), `Delta (0); + (0x11238,0x1123D), `Delta (0); + (0x112A9,0x112A9), `Abs (0x112A9); + (0x1144B,0x1144F), `Delta (0); + (0x1145B,0x1145B), `Abs (0x1145B); + (0x1145D,0x1145D), `Abs (0x1145D); + (0x114C6,0x114C6), `Abs (0x114C6); + (0x115C1,0x115D7), `Delta (0); + (0x11641,0x11643), `Delta (0); + (0x11660,0x1166C), `Delta (0); + (0x1173C,0x1173E), `Delta (0); + (0x11C41,0x11C45), `Delta (0); + (0x11C70,0x11C71), `Delta (0); + (0x12470,0x12474), `Delta (0); + (0x16A6E,0x16A6F), `Delta (0); + (0x16AF5,0x16AF5), `Abs (0x16AF5); + (0x16B37,0x16B3B), `Delta (0); + (0x16B44,0x16B44), `Abs (0x16B44); + (0x1BC9F,0x1BC9F), `Abs (0x1BC9F); + (0x1DA87,0x1DA8B), `Delta (0); + (0x1E95E,0x1E95F), `Delta (0); + (0x0002B,0x0002B), `Abs (0x0002B); + (0x0003C,0x0003E), `Delta (0); + (0x0007C,0x0007C), `Abs (0x0007C); + (0x0007E,0x0007E), `Abs (0x0007E); + (0x000AC,0x000AC), `Abs (0x000AC); + (0x000B1,0x000B1), `Abs (0x000B1); + (0x000D7,0x000D7), `Abs (0x000D7); + (0x000F7,0x000F7), `Abs (0x000F7); + (0x003F6,0x003F6), `Abs (0x003F6); + (0x00606,0x00608), `Delta (0); + (0x02044,0x02044), `Abs (0x02044); + (0x02052,0x02052), `Abs (0x02052); + (0x0207A,0x0207C), `Delta (0); + (0x0208A,0x0208C), `Delta (0); + (0x02118,0x02118), `Abs (0x02118); + (0x02140,0x02144), `Delta (0); + (0x0214B,0x0214B), `Abs (0x0214B); + (0x02190,0x02194), `Delta (0); + (0x0219A,0x0219B), `Delta (0); + (0x021A0,0x021A0), `Abs (0x021A0); + (0x021A3,0x021A3), `Abs (0x021A3); + (0x021A6,0x021A6), `Abs (0x021A6); + (0x021AE,0x021AE), `Abs (0x021AE); + (0x021CE,0x021CF), `Delta (0); + (0x021D2,0x021D2), `Abs (0x021D2); + (0x021D4,0x021D4), `Abs (0x021D4); + (0x021F4,0x022FF), `Delta (0); + (0x02320,0x02321), `Delta (0); + (0x0237C,0x0237C), `Abs (0x0237C); + (0x0239B,0x023B3), `Delta (0); + (0x023DC,0x023E1), `Delta (0); + (0x025B7,0x025B7), `Abs (0x025B7); + (0x025C1,0x025C1), `Abs (0x025C1); + (0x025F8,0x025FF), `Delta (0); + (0x0266F,0x0266F), `Abs (0x0266F); + (0x027C0,0x027C4), `Delta (0); + (0x027C7,0x027E5), `Delta (0); + (0x027F0,0x027FF), `Delta (0); + (0x02900,0x02982), `Delta (0); + (0x02999,0x029D7), `Delta (0); + (0x029DC,0x029FB), `Delta (0); + (0x029FE,0x02AFF), `Delta (0); + (0x02B30,0x02B44), `Delta (0); + (0x02B47,0x02B4C), `Delta (0); + (0x0FB29,0x0FB29), `Abs (0x0FB29); + (0x0FE62,0x0FE62), `Abs (0x0FE62); + (0x0FE64,0x0FE66), `Delta (0); + (0x0FF0B,0x0FF0B), `Abs (0x0FF0B); + (0x0FF1C,0x0FF1E), `Delta (0); + (0x0FF5C,0x0FF5C), `Abs (0x0FF5C); + (0x0FF5E,0x0FF5E), `Abs (0x0FF5E); + (0x0FFE2,0x0FFE2), `Abs (0x0FFE2); + (0x0FFE9,0x0FFEC), `Delta (0); + (0x1D6C1,0x1D6C1), `Abs (0x1D6C1); + (0x1D6DB,0x1D6DB), `Abs (0x1D6DB); + (0x1D6FB,0x1D6FB), `Abs (0x1D6FB); + (0x1D715,0x1D715), `Abs (0x1D715); + (0x1D735,0x1D735), `Abs (0x1D735); + (0x1D74F,0x1D74F), `Abs (0x1D74F); + (0x1D76F,0x1D76F), `Abs (0x1D76F); + (0x1D789,0x1D789), `Abs (0x1D789); + (0x1D7A9,0x1D7A9), `Abs (0x1D7A9); + (0x1D7C3,0x1D7C3), `Abs (0x1D7C3); + (0x1EEF0,0x1EEF1), `Delta (0); + (0x00024,0x00024), `Abs (0x00024); + (0x000A2,0x000A5), `Delta (0); + (0x0058F,0x0058F), `Abs (0x0058F); + (0x0060B,0x0060B), `Abs (0x0060B); + (0x009F2,0x009F3), `Delta (0); + (0x009FB,0x009FB), `Abs (0x009FB); + (0x00AF1,0x00AF1), `Abs (0x00AF1); + (0x00BF9,0x00BF9), `Abs (0x00BF9); + (0x00E3F,0x00E3F), `Abs (0x00E3F); + (0x017DB,0x017DB), `Abs (0x017DB); + (0x020A0,0x020BE), `Delta (0); + (0x0A838,0x0A838), `Abs (0x0A838); + (0x0FDFC,0x0FDFC), `Abs (0x0FDFC); + (0x0FE69,0x0FE69), `Abs (0x0FE69); + (0x0FF04,0x0FF04), `Abs (0x0FF04); + (0x0FFE0,0x0FFE1), `Delta (0); + (0x0FFE5,0x0FFE6), `Delta (0); + (0x0005E,0x0005E), `Abs (0x0005E); + (0x00060,0x00060), `Abs (0x00060); + (0x000A8,0x000A8), `Abs (0x000A8); + (0x000AF,0x000AF), `Abs (0x000AF); + (0x000B4,0x000B4), `Abs (0x000B4); + (0x000B8,0x000B8), `Abs (0x000B8); + (0x002C2,0x002C5), `Delta (0); + (0x002D2,0x002DF), `Delta (0); + (0x002E5,0x002EB), `Delta (0); + (0x002ED,0x002ED), `Abs (0x002ED); + (0x002EF,0x002FF), `Delta (0); + (0x00375,0x00375), `Abs (0x00375); + (0x00384,0x00385), `Delta (0); + (0x01FBD,0x01FBD), `Abs (0x01FBD); + (0x01FBF,0x01FC1), `Delta (0); + (0x01FCD,0x01FCF), `Delta (0); + (0x01FDD,0x01FDF), `Delta (0); + (0x01FED,0x01FEF), `Delta (0); + (0x01FFD,0x01FFE), `Delta (0); + (0x0309B,0x0309C), `Delta (0); + (0x0A700,0x0A716), `Delta (0); + (0x0A720,0x0A721), `Delta (0); + (0x0A789,0x0A78A), `Delta (0); + (0x0AB5B,0x0AB5B), `Abs (0x0AB5B); + (0x0FBB2,0x0FBC1), `Delta (0); + (0x0FF3E,0x0FF3E), `Abs (0x0FF3E); + (0x0FF40,0x0FF40), `Abs (0x0FF40); + (0x0FFE3,0x0FFE3), `Abs (0x0FFE3); + (0x1F3FB,0x1F3FF), `Delta (0); + (0x000A6,0x000A6), `Abs (0x000A6); + (0x000A9,0x000A9), `Abs (0x000A9); + (0x000AE,0x000AE), `Abs (0x000AE); + (0x000B0,0x000B0), `Abs (0x000B0); + (0x00482,0x00482), `Abs (0x00482); + (0x0058D,0x0058E), `Delta (0); + (0x0060E,0x0060F), `Delta (0); + (0x006DE,0x006DE), `Abs (0x006DE); + (0x006E9,0x006E9), `Abs (0x006E9); + (0x006FD,0x006FE), `Delta (0); + (0x007F6,0x007F6), `Abs (0x007F6); + (0x009FA,0x009FA), `Abs (0x009FA); + (0x00B70,0x00B70), `Abs (0x00B70); + (0x00BF3,0x00BF8), `Delta (0); + (0x00BFA,0x00BFA), `Abs (0x00BFA); + (0x00C7F,0x00C7F), `Abs (0x00C7F); + (0x00D4F,0x00D4F), `Abs (0x00D4F); + (0x00D79,0x00D79), `Abs (0x00D79); + (0x00F01,0x00F03), `Delta (0); + (0x00F13,0x00F13), `Abs (0x00F13); + (0x00F15,0x00F17), `Delta (0); + (0x00F1A,0x00F1F), `Delta (0); + (0x00F34,0x00F34), `Abs (0x00F34); + (0x00F36,0x00F36), `Abs (0x00F36); + (0x00F38,0x00F38), `Abs (0x00F38); + (0x00FBE,0x00FC5), `Delta (0); + (0x00FC7,0x00FCC), `Delta (0); + (0x00FCE,0x00FCF), `Delta (0); + (0x00FD5,0x00FD8), `Delta (0); + (0x0109E,0x0109F), `Delta (0); + (0x01390,0x01399), `Delta (0); + (0x01940,0x01940), `Abs (0x01940); + (0x019DE,0x019FF), `Delta (0); + (0x01B61,0x01B6A), `Delta (0); + (0x01B74,0x01B7C), `Delta (0); + (0x02100,0x02101), `Delta (0); + (0x02103,0x02106), `Delta (0); + (0x02108,0x02109), `Delta (0); + (0x02114,0x02114), `Abs (0x02114); + (0x02116,0x02117), `Delta (0); + (0x0211E,0x02123), `Delta (0); + (0x02125,0x02125), `Abs (0x02125); + (0x02127,0x02127), `Abs (0x02127); + (0x02129,0x02129), `Abs (0x02129); + (0x0212E,0x0212E), `Abs (0x0212E); + (0x0213A,0x0213B), `Delta (0); + (0x0214A,0x0214A), `Abs (0x0214A); + (0x0214C,0x0214D), `Delta (0); + (0x0214F,0x0214F), `Abs (0x0214F); + (0x0218A,0x0218B), `Delta (0); + (0x02195,0x02199), `Delta (0); + (0x0219C,0x0219F), `Delta (0); + (0x021A1,0x021A2), `Delta (0); + (0x021A4,0x021A5), `Delta (0); + (0x021A7,0x021AD), `Delta (0); + (0x021AF,0x021CD), `Delta (0); + (0x021D0,0x021D1), `Delta (0); + (0x021D3,0x021D3), `Abs (0x021D3); + (0x021D5,0x021F3), `Delta (0); + (0x02300,0x02307), `Delta (0); + (0x0230C,0x0231F), `Delta (0); + (0x02322,0x02328), `Delta (0); + (0x0232B,0x0237B), `Delta (0); + (0x0237D,0x0239A), `Delta (0); + (0x023B4,0x023DB), `Delta (0); + (0x023E2,0x023FE), `Delta (0); + (0x02400,0x02426), `Delta (0); + (0x02440,0x0244A), `Delta (0); + (0x0249C,0x024B5), `Delta (0); + (0x024B6,0x024CF), `Delta (26); + (0x024D0,0x024E9), `Delta (0); + (0x02500,0x025B6), `Delta (0); + (0x025B8,0x025C0), `Delta (0); + (0x025C2,0x025F7), `Delta (0); + (0x02600,0x0266E), `Delta (0); + (0x02670,0x02767), `Delta (0); + (0x02794,0x027BF), `Delta (0); + (0x02800,0x028FF), `Delta (0); + (0x02B00,0x02B2F), `Delta (0); + (0x02B45,0x02B46), `Delta (0); + (0x02B4D,0x02B73), `Delta (0); + (0x02B76,0x02B95), `Delta (0); + (0x02B98,0x02BB9), `Delta (0); + (0x02BBD,0x02BC8), `Delta (0); + (0x02BCA,0x02BD1), `Delta (0); + (0x02BEC,0x02BEF), `Delta (0); + (0x02CE5,0x02CEA), `Delta (0); + (0x02E80,0x02E99), `Delta (0); + (0x02E9B,0x02EF3), `Delta (0); + (0x02F00,0x02FD5), `Delta (0); + (0x02FF0,0x02FFB), `Delta (0); + (0x03004,0x03004), `Abs (0x03004); + (0x03012,0x03013), `Delta (0); + (0x03020,0x03020), `Abs (0x03020); + (0x03036,0x03037), `Delta (0); + (0x0303E,0x0303F), `Delta (0); + (0x03190,0x03191), `Delta (0); + (0x03196,0x0319F), `Delta (0); + (0x031C0,0x031E3), `Delta (0); + (0x03200,0x0321E), `Delta (0); + (0x0322A,0x03247), `Delta (0); + (0x03250,0x03250), `Abs (0x03250); + (0x03260,0x0327F), `Delta (0); + (0x0328A,0x032B0), `Delta (0); + (0x032C0,0x032FE), `Delta (0); + (0x03300,0x033FF), `Delta (0); + (0x04DC0,0x04DFF), `Delta (0); + (0x0A490,0x0A4C6), `Delta (0); + (0x0A828,0x0A82B), `Delta (0); + (0x0A836,0x0A837), `Delta (0); + (0x0A839,0x0A839), `Abs (0x0A839); + (0x0AA77,0x0AA79), `Delta (0); + (0x0FDFD,0x0FDFD), `Abs (0x0FDFD); + (0x0FFE4,0x0FFE4), `Abs (0x0FFE4); + (0x0FFE8,0x0FFE8), `Abs (0x0FFE8); + (0x0FFED,0x0FFEE), `Delta (0); + (0x0FFFC,0x0FFFD), `Delta (0); + (0x10137,0x1013F), `Delta (0); + (0x10179,0x10189), `Delta (0); + (0x1018C,0x1018E), `Delta (0); + (0x10190,0x1019B), `Delta (0); + (0x101A0,0x101A0), `Abs (0x101A0); + (0x101D0,0x101FC), `Delta (0); + (0x10877,0x10878), `Delta (0); + (0x10AC8,0x10AC8), `Abs (0x10AC8); + (0x1173F,0x1173F), `Abs (0x1173F); + (0x16B3C,0x16B3F), `Delta (0); + (0x16B45,0x16B45), `Abs (0x16B45); + (0x1BC9C,0x1BC9C), `Abs (0x1BC9C); + (0x1D000,0x1D0F5), `Delta (0); + (0x1D100,0x1D126), `Delta (0); + (0x1D129,0x1D164), `Delta (0); + (0x1D16A,0x1D16C), `Delta (0); + (0x1D183,0x1D184), `Delta (0); + (0x1D18C,0x1D1A9), `Delta (0); + (0x1D1AE,0x1D1E8), `Delta (0); + (0x1D200,0x1D241), `Delta (0); + (0x1D245,0x1D245), `Abs (0x1D245); + (0x1D300,0x1D356), `Delta (0); + (0x1D800,0x1D9FF), `Delta (0); + (0x1DA37,0x1DA3A), `Delta (0); + (0x1DA6D,0x1DA74), `Delta (0); + (0x1DA76,0x1DA83), `Delta (0); + (0x1DA85,0x1DA86), `Delta (0); + (0x1F000,0x1F02B), `Delta (0); + (0x1F030,0x1F093), `Delta (0); + (0x1F0A0,0x1F0AE), `Delta (0); + (0x1F0B1,0x1F0BF), `Delta (0); + (0x1F0C1,0x1F0CF), `Delta (0); + (0x1F0D1,0x1F0F5), `Delta (0); + (0x1F110,0x1F12E), `Delta (0); + (0x1F130,0x1F16B), `Delta (0); + (0x1F170,0x1F1AC), `Delta (0); + (0x1F1E6,0x1F202), `Delta (0); + (0x1F210,0x1F23B), `Delta (0); + (0x1F240,0x1F248), `Delta (0); + (0x1F250,0x1F251), `Delta (0); + (0x1F300,0x1F3FA), `Delta (0); + (0x1F400,0x1F6D2), `Delta (0); + (0x1F6E0,0x1F6EC), `Delta (0); + (0x1F6F0,0x1F6F6), `Delta (0); + (0x1F700,0x1F773), `Delta (0); + (0x1F780,0x1F7D4), `Delta (0); + (0x1F800,0x1F80B), `Delta (0); + (0x1F810,0x1F847), `Delta (0); + (0x1F850,0x1F859), `Delta (0); + (0x1F860,0x1F887), `Delta (0); + (0x1F890,0x1F8AD), `Delta (0); + (0x1F910,0x1F91E), `Delta (0); + (0x1F920,0x1F927), `Delta (0); + (0x1F930,0x1F930), `Abs (0x1F930); + (0x1F933,0x1F93E), `Delta (0); + (0x1F940,0x1F94B), `Delta (0); + (0x1F950,0x1F95E), `Delta (0); + (0x1F980,0x1F991), `Delta (0) +];; diff --git a/lib/util.ml b/lib/util.ml index 009dfbe1c..0d2425f27 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -87,13 +87,17 @@ let matrix_transpose mat = let identity x = x -(** Function composition: the mathematical [∘] operator. +(** Left-to-right function composition: + + [f1 %> f2] is [fun x -> f2 (f1 x)]. - So [g % f] is a synonym for [fun x -> g (f x)]. + [f1 %> f2 %> f3] is [fun x -> f3 (f2 (f1 x))]. - Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))]. - *) -let (%) f g x = f (g x) + [f1 %> f2 %> f3 %> f4] is [fun x -> f4 (f3 (f2 (f1 x)))] + + etc. +*) +let (%>) f g x = g (f x) let const x _ = x @@ -157,11 +161,11 @@ let iraise = Exninfo.iraise let open_utf8_file_in fname = let is_bom s = - Int.equal (Char.code s.[0]) 0xEF && - Int.equal (Char.code s.[1]) 0xBB && - Int.equal (Char.code s.[2]) 0xBF + Int.equal (Char.code (Bytes.get s 0)) 0xEF && + Int.equal (Char.code (Bytes.get s 1)) 0xBB && + Int.equal (Char.code (Bytes.get s 2)) 0xBF in let in_chan = open_in fname in - let s = " " in + let s = Bytes.make 3 ' ' in if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0; in_chan diff --git a/lib/util.mli b/lib/util.mli index 6bed7e355..cf8041a0d 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -84,13 +84,17 @@ val matrix_transpose : 'a list list -> 'a list list val identity : 'a -> 'a -(** Function composition: the mathematical [∘] operator. +(** Left-to-right function composition: + + [f1 %> f2] is [fun x -> f2 (f1 x)]. - So [g % f] is a synonym for [fun x -> g (f x)]. + [f1 %> f2 %> f3] is [fun x -> f3 (f2 (f1 x))]. - Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))]. + [f1 %> f2 %> f3 %> f4] is [fun x -> f4 (f3 (f2 (f1 x)))] + + etc. *) -val (%) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b +val ( %> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c val const : 'a -> 'b -> 'a val iterate : ('a -> 'a) -> int -> 'a -> 'a diff --git a/library/declare.ml b/library/declare.ml index c9992fff3..31c9c24bc 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -455,7 +455,7 @@ let declare_universe_context poly ctx = type universe_decl = polymorphic * (Id.t * Univ.universe_level) list let cache_universes (p, l) = - let glob = Universes.global_universe_names () in + let glob = Global.global_universe_names () in let glob', ctx = List.fold_left (fun ((idl,lid),ctx) (id, lev) -> ((Idmap.add id (p, lev) idl, @@ -464,7 +464,7 @@ let cache_universes (p, l) = (glob, Univ.ContextSet.empty) l in cache_universe_context (p, ctx); - Universes.set_global_universe_names glob' + Global.set_global_universe_names glob' let input_universes : universe_decl -> Libobject.obj = declare_object @@ -478,8 +478,8 @@ let do_universe poly l = let in_section = Lib.sections_are_opened () in let () = if poly && not in_section then - user_err_loc (Loc.ghost, "Constraint", - str"Cannot declare polymorphic universes outside sections") + user_err ~hdr:"Constraint" + (str"Cannot declare polymorphic universes outside sections") in let l = List.map (fun (l, id) -> @@ -515,27 +515,27 @@ let do_constraint poly l = | GProp -> Loc.dummy_loc, (false, Univ.Level.prop) | GSet -> Loc.dummy_loc, (false, Univ.Level.set) | GType None -> - user_err_loc (Loc.dummy_loc, "Constraint", - str "Cannot declare constraints on anonymous universes") + user_err ~hdr:"Constraint" + (str "Cannot declare constraints on anonymous universes") | GType (Some (loc, id)) -> let id = Id.of_string id in - let names, _ = Universes.global_universe_names () in + let names, _ = Global.global_universe_names () in try loc, Idmap.find id names with Not_found -> - user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) + user_err ~loc ~hdr:"Constraint" (str "Undeclared universe " ++ pr_id id) in let in_section = Lib.sections_are_opened () in let () = if poly && not in_section then - user_err_loc (Loc.ghost, "Constraint", - str"Cannot declare polymorphic constraints outside sections") + user_err ~hdr:"Constraint" + (str"Cannot declare polymorphic constraints outside sections") in let check_poly loc p loc' p' = if poly then () else if p || p' then let loc = if p then loc else loc' in - user_err_loc (loc, "Constraint", - str "Cannot declare a global constraint on " ++ + user_err ~loc ~hdr:"Constraint" + (str "Cannot declare a global constraint on " ++ str "a polymorphic universe, use " ++ str "Polymorphic Constraint instead") in diff --git a/library/declaremods.ml b/library/declaremods.ml index b2806a1ac..3a263b1e1 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -166,13 +166,13 @@ let consistency_checks exists dir dirinfo = let globref = try Nametab.locate_dir (qualid_of_dirpath dir) with Not_found -> - errorlabstrm "consistency_checks" + user_err ~hdr:"consistency_checks" (pr_dirpath dir ++ str " should already exist!") in assert (eq_global_dir_reference globref dirinfo) else if Nametab.exists_dir dir then - errorlabstrm "consistency_checks" + user_err ~hdr:"consistency_checks" (pr_dirpath dir ++ str " already exists") let compute_visibility exists i = diff --git a/library/decls.ml b/library/decls.ml index 6e21880f1..2952c258a 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -14,6 +14,8 @@ open Names open Decl_kinds open Libnames +module NamedDecl = Context.Named.Declaration + (** Datas associated to section variables and local definitions *) type variable_data = @@ -46,20 +48,18 @@ let constant_kind kn = Cmap.find kn !csttab (** Miscellaneous functions. *) -open Context.Named.Declaration - let initialize_named_context_for_proof () = let sign = Global.named_context () in List.fold_right (fun d signv -> - let id = get_id d in - let d = if variable_opacity id then LocalAssum (id, get_type d) else d in + let id = NamedDecl.get_id d in + let d = if variable_opacity id then NamedDecl.LocalAssum (id, NamedDecl.get_type d) else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val let last_section_hyps dir = Context.Named.fold_outside (fun d sec_ids -> - let id = get_id d in + let id = NamedDecl.get_id d in try if DirPath.equal dir (variable_path id) then id::sec_ids else sec_ids with Not_found -> sec_ids) (Environ.named_context (Global.env())) diff --git a/library/global.ml b/library/global.ml index e748434d2..5fa710b36 100644 --- a/library/global.ml +++ b/library/global.ml @@ -8,6 +8,7 @@ open Names open Environ +open Decl_kinds (** We introduce here the global environment of the system, and we declare it as a synchronized table. *) @@ -229,6 +230,17 @@ let universes_of_global env r = let universes_of_global gr = universes_of_global (env ()) gr +(** Global universe names *) +type universe_names = + (polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t + +let global_universes = + Summary.ref ~name:"Global universe names" + ((Idmap.empty, Univ.LMap.empty) : universe_names) + +let global_universe_names () = !global_universes +let set_global_universe_names s = global_universes := s + let is_polymorphic r = let env = env() in match r with diff --git a/library/global.mli b/library/global.mli index 247ca20b4..a4a38ce84 100644 --- a/library/global.mli +++ b/library/global.mli @@ -96,6 +96,13 @@ val constraints_of_constant_body : val universes_of_constant_body : Declarations.constant_body -> Univ.universe_context +(** Global universe name <-> level mapping *) +type universe_names = + (Decl_kinds.polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t + +val global_universe_names : unit -> universe_names +val set_global_universe_names : universe_names -> unit + (** {6 Compiled libraries } *) val start_library : DirPath.t -> module_path diff --git a/library/goptions.ml b/library/goptions.ml index 9dc0f4058..1c08b9539 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -36,7 +36,7 @@ type option_state = { let nickname table = String.concat " " table let error_undeclared_key key = - errorlabstrm "Goptions" (str (nickname key) ++ str ": no table or option of this type") + user_err ~hdr:"Goptions" (str (nickname key) ++ str ": no table or option of this type") (****************************************************************************) (* 1- Tables *) @@ -382,9 +382,9 @@ let msg_option_value (name,v) = | BoolValue false -> str "off" | IntValue (Some n) -> int n | IntValue None -> str "undefined" - | StringValue s -> str "\"" ++ str s ++ str "\"" + | StringValue s -> quote (str s) | StringOptValue None -> str"undefined" - | StringOptValue (Some s) -> str "\"" ++ str s ++ str "\"" + | StringOptValue (Some s) -> quote (str s) (* | IdentValue r -> pr_global_env Id.Set.empty r *) let print_option_value key = diff --git a/library/impargs.ml b/library/impargs.ml index 828d652c8..836568b89 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -22,6 +22,9 @@ open Constrexpr open Termops open Namegen open Decl_kinds +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (*s Flags governing the computation of implicit arguments *) @@ -164,7 +167,6 @@ let update pos rig (na,st) = (* modified is_rigid_reference with a truncated env *) let is_flexible_reference env bound depth f = - let open Context.Named.Declaration in match kind_of_term f with | Rel n when n >= bound+depth -> (* inductive type *) false | Rel n when n >= depth -> (* previous argument *) true @@ -173,7 +175,7 @@ let is_flexible_reference env bound depth f = let cb = Environ.lookup_constant kn env in (match cb.const_body with Def _ -> true | _ -> false) | Var id -> - Environ.lookup_named id env |> is_local_def + env |> Environ.lookup_named id |> is_local_def | Ind _ | Construct _ -> false | _ -> true @@ -338,14 +340,14 @@ let check_correct_manual_implicits autoimps l = List.iter (function | ExplByName id,(b,fi,forced) -> if not forced then - errorlabstrm "" + user_err (str "Wrong or non-dependent implicit argument name: " ++ pr_id id ++ str ".") | ExplByPos (i,_id),_t -> if i<1 || i>List.length autoimps then - errorlabstrm "" + user_err (str "Bad implicit argument number: " ++ int i ++ str ".") else - errorlabstrm "" + user_err (str "Cannot set implicit argument number " ++ int i ++ str ": it has no name.")) l @@ -449,8 +451,7 @@ let compute_all_mib_implicits flags manual kn = let compute_var_implicits flags manual id = let env = Global.env () in - let open Context.Named.Declaration in - compute_semi_auto_implicits env flags manual (get_type (lookup_named id env)) + compute_semi_auto_implicits env flags manual (NamedDecl.get_type (lookup_named id env)) (* Implicits of a global reference. *) @@ -517,15 +518,11 @@ let subst_implicits (subst,(req,l)) = (ImplLocal,List.smartmap (subst_implicits_decl subst) l) let impls_of_context ctx = - let map (id, impl, _, _) = match impl with - | Implicit -> Some (id, Manual, (true, true)) + let map (decl, impl) = match impl with + | Implicit -> Some (NamedDecl.get_id decl, Manual, (true, true)) | _ -> None in - let is_set (_, _, b, _) = match b with - | None -> true - | Some _ -> false - in - List.rev_map map (List.filter is_set ctx) + List.rev_map map (List.filter (fst %> is_local_assum) ctx) let adjust_side_condition p = function | LessArgsThan n -> LessArgsThan (n+p) @@ -666,7 +663,7 @@ let check_inclusion l = let check_rigidity isrigid = if not isrigid then - errorlabstrm "" (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") + user_err (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") let projection_implicits env p impls = let pb = Environ.lookup_projection p env in diff --git a/library/lib.ml b/library/lib.ml index f680ecee3..ddd2ed6af 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -13,6 +13,9 @@ open Libnames open Globnames open Nameops open Libobject +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration type is_type = bool (* Module Type or just Module *) type export = bool option (* None for a Module Type *) @@ -75,7 +78,7 @@ let classify_segment seg = | (_,ClosedModule _) :: stk -> clean acc stk | (_,OpenedSection _) :: _ -> error "there are still opened sections" | (_,OpenedModule (ty,_,_,_)) :: _ -> - errorlabstrm "Lib.classify_segment" + user_err ~hdr:"Lib.classify_segment" (str "there are still opened " ++ str (module_kind ty) ++ str "s") | (_,FrozenState _) :: stk -> clean acc stk in @@ -94,21 +97,30 @@ let segment_of_objects prefix = let initial_prefix = default_library,(Names.initial_path,Names.DirPath.empty) -let lib_stk = ref ([] : library_segment) +type lib_state = { + comp_name : Names.DirPath.t option; + lib_stk : library_segment; + path_prefix : Names.DirPath.t * (Names.module_path * Names.DirPath.t); +} + +let initial_lib_state = { + comp_name = None; + lib_stk = []; + path_prefix = initial_prefix; +} -let comp_name = ref None +let lib_state = ref initial_lib_state let library_dp () = - match !comp_name with Some m -> m | None -> default_library + match !lib_state.comp_name with Some m -> m | None -> default_library (* [path_prefix] is a pair of absolute dirpath and a pair of current module path and relative section path *) -let path_prefix = ref initial_prefix -let cwd () = fst !path_prefix -let current_prefix () = snd !path_prefix -let current_mp () = fst (snd !path_prefix) -let current_sections () = snd (snd !path_prefix) +let cwd () = fst !lib_state.path_prefix +let current_prefix () = snd !lib_state.path_prefix +let current_mp () = fst (snd !lib_state.path_prefix) +let current_sections () = snd (snd !lib_state.path_prefix) let sections_depth () = List.length (Names.DirPath.repr (current_sections ())) let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ())) @@ -129,7 +141,7 @@ let make_kn id = let mp,dir = current_prefix () in Names.make_kn mp dir (Names.Label.of_id id) -let make_oname id = Libnames.make_oname !path_prefix id +let make_oname id = Libnames.make_oname !lib_state.path_prefix id let recalc_path_prefix () = let rec recalc = function @@ -139,18 +151,18 @@ let recalc_path_prefix () = | _::l -> recalc l | [] -> initial_prefix in - path_prefix := recalc !lib_stk + lib_state := { !lib_state with path_prefix = recalc !lib_state.lib_stk } let pop_path_prefix () = - let dir,(mp,sec) = !path_prefix in - path_prefix := pop_dirpath dir, (mp, pop_dirpath sec) + let dir,(mp,sec) = !lib_state.path_prefix in + lib_state := { !lib_state with path_prefix = pop_dirpath dir, (mp, pop_dirpath sec)} let find_entry_p p = let rec find = function | [] -> raise Not_found | ent::l -> if p ent then ent else find l in - find !lib_stk + find !lib_state.lib_stk let split_lib_gen test = let rec collect after equal = function @@ -171,7 +183,7 @@ let split_lib_gen test = | _ -> findeq (hd::after) before) | [] -> None in - match findeq [] !lib_stk with + match findeq [] !lib_state.lib_stk with | None -> error "no such entry" | Some r -> r @@ -196,10 +208,10 @@ let split_lib_at_opening sp = (* Adding operations. *) let add_entry sp node = - lib_stk := (sp,node) :: !lib_stk + lib_state := { !lib_state with lib_stk = (sp,node) :: !lib_state.lib_stk } let pull_to_head oname = - lib_stk := (oname,List.assoc oname !lib_stk) :: List.remove_assoc oname !lib_stk + lib_state := { !lib_state with lib_stk = (oname,List.assoc oname !lib_state.lib_stk) :: List.remove_assoc oname !lib_state.lib_stk } let anonymous_id = let n = ref 0 in @@ -272,9 +284,9 @@ let start_mod is_type export id mp fs = else Nametab.exists_module dir in if exists then - errorlabstrm "open_module" (pr_id id ++ str " already exists"); + user_err ~hdr:"open_module" (pr_id id ++ str " already exists"); add_entry (make_oname id) (OpenedModule (is_type,export,prefix,fs)); - path_prefix := prefix; + lib_state := { !lib_state with path_prefix = prefix} ; prefix let start_module = start_mod false @@ -282,7 +294,7 @@ let start_modtype = start_mod true None let error_still_opened string oname = let id = basename (fst oname) in - errorlabstrm "" + user_err (str "The " ++ str string ++ str " " ++ pr_id id ++ str " is still opened.") let end_mod is_type = @@ -296,16 +308,16 @@ let end_mod is_type = with Not_found -> error "No opened modules." in let (after,mark,before) = split_lib_at_opening oname in - lib_stk := before; + lib_state := { !lib_state with lib_stk = before }; add_entry oname (ClosedModule (List.rev (mark::after))); - let prefix = !path_prefix in + let prefix = !lib_state.path_prefix in recalc_path_prefix (); (oname, prefix, fs, after) let end_module () = end_mod false let end_modtype () = end_mod true -let contents () = !lib_stk +let contents () = !lib_state.lib_stk let contents_after sp = let (after,_,_) = split_lib sp in after @@ -313,21 +325,21 @@ let contents_after sp = let (after,_,_) = split_lib sp in after (* TODO: use check_for_module ? *) let start_compilation s mp = - if !comp_name != None then + if !lib_state.comp_name != None then error "compilation unit is already started"; if not (Names.DirPath.is_empty (current_sections ())) then error "some sections are already opened"; let prefix = s, (mp, Names.DirPath.empty) in let () = add_anonymous_entry (CompilingLibrary prefix) in - comp_name := Some s; - path_prefix := prefix + lib_state := { !lib_state with comp_name = Some s; + path_prefix = prefix } let end_compilation_checks dir = let _ = try match snd (find_entry_p is_opening_node) with | OpenedSection _ -> error "There are some open sections." | OpenedModule (ty,_,_,_) -> - errorlabstrm "Lib.end_compilation_checks" + user_err ~hdr:"Lib.end_compilation_checks" (str "There are some open " ++ str (module_kind ty) ++ str "s.") | _ -> assert false with Not_found -> () @@ -341,7 +353,7 @@ let end_compilation_checks dir = with Not_found -> anomaly (Pp.str "No module declared") in let _ = - match !comp_name with + match !lib_state.comp_name with | None -> anomaly (Pp.str "There should be a module name...") | Some m -> if not (Names.DirPath.equal m dir) then anomaly @@ -352,8 +364,8 @@ let end_compilation_checks dir = let end_compilation oname = let (after,mark,before) = split_lib_at_opening oname in - comp_name := None; - !path_prefix,after + lib_state := { !lib_state with comp_name = None }; + !lib_state.path_prefix,after (* Returns true if we are inside an opened module or module type *) @@ -379,7 +391,7 @@ let find_opening_node id = let oname,entry = find_entry_p is_opening_node in let id' = basename (fst oname) in if not (Names.Id.equal id id') then - errorlabstrm "Lib.find_opening_node" + user_err ~hdr:"Lib.find_opening_node" (str "Last block to end has name " ++ pr_id id' ++ str "."); entry with Not_found -> error "There is nothing to end." @@ -393,7 +405,7 @@ let find_opening_node id = - the list of substitution to do at section closing *) -type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types +type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind type variable_context = variable_info list type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t @@ -433,12 +445,10 @@ let add_section_context ctx = sectab := (Context ctx :: vars,repl,abs)::sl let extract_hyps (secs,ohyps) = - let open Context.Named.Declaration in let rec aux = function - | (Variable (id,impl,poly,ctx)::idl, decl::hyps) when Names.Id.equal id (get_id decl) -> - let (id',b,t) = to_tuple decl in + | (Variable (id,impl,poly,ctx)::idl, decl::hyps) when Names.Id.equal id (NamedDecl.get_id decl) -> let l, r = aux (idl,hyps) in - (id',impl,b,t) :: l, if poly then Univ.ContextSet.union r ctx else r + (decl,impl) :: l, if poly then Univ.ContextSet.union r ctx else r | (Variable (_,_,poly,ctx)::idl,hyps) -> let l, r = aux (idl,hyps) in l, if poly then Univ.ContextSet.union r ctx else r @@ -448,17 +458,11 @@ let extract_hyps (secs,ohyps) = | [], _ -> [],Univ.ContextSet.empty in aux (secs,ohyps) -let instance_from_variable_context sign = - let rec inst_rec = function - | (id,b,None,_) :: sign -> id :: inst_rec sign - | _ :: sign -> inst_rec sign - | [] -> [] in - Array.of_list (inst_rec sign) - -let named_of_variable_context ctx = let open Context.Named.Declaration in - List.map (function id,_,None,t -> LocalAssum (id,t) - | id,_,Some b,t -> LocalDef (id,b,t)) - ctx +let instance_from_variable_context = + List.map fst %> List.filter is_local_assum %> List.map NamedDecl.get_id %> Array.of_list + +let named_of_variable_context = + List.map fst let add_section_replacement f g poly hyps = match !sectab with @@ -519,16 +523,16 @@ let (f_xml_open_section, xml_open_section) = Hook.make ~default:ignore () let (f_xml_close_section, xml_close_section) = Hook.make ~default:ignore () let open_section id = - let olddir,(mp,oldsec) = !path_prefix in + let olddir,(mp,oldsec) = !lib_state.path_prefix in let dir = add_dirpath_suffix olddir id in let prefix = dir, (mp, add_dirpath_suffix oldsec id) in if Nametab.exists_section dir then - errorlabstrm "open_section" (pr_id id ++ str " already exists."); + user_err ~hdr:"open_section" (pr_id id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:`No in add_entry (make_oname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix); - path_prefix := prefix; + lib_state := { !lib_state with path_prefix = prefix }; if !Flags.xml_export then Hook.get f_xml_open_section id; add_section () @@ -554,8 +558,8 @@ let close_section () = error "No opened section." in let (secdecls,mark,before) = split_lib_at_opening oname in - lib_stk := before; - let full_olddir = fst !path_prefix in + lib_state := { !lib_state with lib_stk = before }; + let full_olddir = fst !lib_state.path_prefix in pop_path_prefix (); add_entry oname (ClosedSection (List.rev (mark::secdecls))); if !Flags.xml_export then Hook.get f_xml_close_section (basename (fst oname)); @@ -566,7 +570,7 @@ let close_section () = (* State and initialization. *) -type frozen = Names.DirPath.t option * library_segment +type frozen = lib_state let freeze ~marshallable = match marshallable with @@ -583,18 +587,15 @@ let freeze ~marshallable = Some(n,OpenedSection(op,Summary.empty_frozen)) | n, ClosedSection _ -> Some (n,ClosedSection []) | _, FrozenState _ -> None) - !lib_stk in - !comp_name, lib_stk + !lib_state.lib_stk in + { !lib_state with lib_stk } | _ -> - !comp_name, !lib_stk + !lib_state -let unfreeze (mn,stk) = - comp_name := mn; - lib_stk := stk; - recalc_path_prefix () +let unfreeze st = lib_state := st let init () = - unfreeze (None,[]); + unfreeze initial_lib_state; Summary.init_summaries (); add_frozen_state () (* Stores e.g. the keywords declared in g_*.ml4 *) diff --git a/library/lib.mli b/library/lib.mli index a8e110c67..9f9d8c7e5 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -160,8 +160,7 @@ val xml_open_section : (Names.Id.t -> unit) Hook.t val xml_close_section : (Names.Id.t -> unit) Hook.t (** {6 Section management for discharge } *) -type variable_info = Names.Id.t * Decl_kinds.binding_kind * - Term.constr option * Term.types +type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind type variable_context = variable_info list type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t diff --git a/library/libobject.ml b/library/libobject.ml index caa03c85b..8757ca08c 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -91,16 +91,8 @@ let declare_object_full odecl = dyn_rebuild_function = rebuild }; (infun,outfun) -(* The "try .. with .. " allows for correct printing when calling - declare_object a loading time. -*) - -let declare_object odecl = - try fst (declare_object_full odecl) - with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e) -let declare_object_full odecl = - try declare_object_full odecl - with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e) +let declare_object odecl = fst (declare_object_full odecl) +let declare_object_full odecl = declare_object_full odecl (* this function describes how the cache, load, open, and export functions are triggered. *) diff --git a/library/library.ml b/library/library.ml index d44f796a7..3086e3d18 100644 --- a/library/library.ml +++ b/library/library.ml @@ -131,7 +131,7 @@ let find_library dir = let try_find_library dir = try find_library dir with Not_found -> - errorlabstrm "Library.find_library" + user_err ~hdr:"Library.find_library" (str "Unknown library " ++ pr_dirpath dir) let register_library_filename dir f = @@ -329,12 +329,12 @@ let locate_qualified_library ?root ?(warn = true) qid = let error_unmapped_dir qid = let prefix, _ = repr_qualid qid in - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ()) let error_lib_not_found qid = - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str"Cannot find library " ++ pr_qualid qid ++ str" in loadpath") let try_locate_absolute_library dir = @@ -378,7 +378,7 @@ let access_table what tables dp i = let t = try fetch_delayed f with Faulty f -> - errorlabstrm "Library.access_table" + user_err ~hdr:"Library.access_table" (str "The file " ++ str f ++ str " (bound to " ++ str dir_path ++ str ") is inaccessible or corrupted,\ncannot load some " ++ str what ++ str " in it.\n") @@ -463,7 +463,7 @@ let rec intern_library (needed, contents) (dir, f) from = let f = match f with Some f -> f | None -> try_locate_absolute_library dir in let m = intern_from_file f in if not (DirPath.equal dir m.library_name) then - errorlabstrm "load_physical_library" + user_err ~hdr:"load_physical_library" (str "The file " ++ str f ++ str " contains library" ++ spc () ++ pr_dirpath m.library_name ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir); @@ -477,7 +477,7 @@ and intern_library_deps libs dir m from = and intern_mandatory_library caller from libs (dir,d) = let digest, libs = intern_library libs (dir, None) (Some from) in if not (Safe_typing.digest_match ~actual:digest ~required:d) then - errorlabstrm "" (str "Compiled library " ++ pr_dirpath caller ++ + user_err (str "Compiled library " ++ pr_dirpath caller ++ str " (in file " ++ str from ++ str ") makes inconsistent assumptions \ over library " ++ pr_dirpath dir); libs @@ -582,8 +582,8 @@ let require_library_from_dirpath modrefl export = let safe_locate_module (loc,qid) = try Nametab.locate_module qid with Not_found -> - user_err_loc - (loc,"import_library", pr_qualid qid ++ str " is not a module") + user_err ~loc ~hdr:"import_library" + (pr_qualid qid ++ str " is not a module") let import_module export modl = (* Optimization: libraries in a raw in the list are imported @@ -607,8 +607,8 @@ let import_module export modl = flush acc; try Declaremods.import_module export mp; aux [] l with Not_found -> - user_err_loc (loc,"import_library", - pr_qualid dir ++ str " is not a module")) + user_err ~loc ~hdr:"import_library" + (pr_qualid dir ++ str " is not a module")) | [] -> flush acc in aux [] modl @@ -619,7 +619,7 @@ let check_coq_overwriting p id = let l = DirPath.repr p in let is_empty = match l with [] -> true | _ -> false in if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then - errorlabstrm "" + user_err (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") @@ -632,7 +632,7 @@ let check_module_name s = (if c = '\'' then str "\"'\"" else (str "'" ++ str (String.make 1 c) ++ str "'")) ++ strbrk " is not allowed in module names\n" in - let err c = errorlabstrm "" (msg c) in + let err c = user_err (msg c) in match String.get s 0 with | 'a' .. 'z' | 'A' .. 'Z' -> for i = 1 to (String.length s)-1 do @@ -668,10 +668,10 @@ let load_library_todo f = let tasks, _, _ = System.marshal_in_segment f ch in let (s5 : seg_proofs), _, _ = System.marshal_in_segment f ch in close_in ch; - if tasks = None then errorlabstrm "restart" (str"not a .vio file"); - if s2 = None then errorlabstrm "restart" (str"not a .vio file"); - if s3 = None then errorlabstrm "restart" (str"not a .vio file"); - if pi3 (Option.get s2) then errorlabstrm "restart" (str"not a .vio file"); + if tasks = None then user_err ~hdr:"restart" (str"not a .vio file"); + if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); + if s3 = None then user_err ~hdr:"restart" (str"not a .vio file"); + if pi3 (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); longf, s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 (************************************************************************) @@ -687,7 +687,7 @@ let current_deps () = let current_reexports () = !libraries_exports_list let error_recursively_dependent_library dir = - errorlabstrm "" + user_err (strbrk "Unable to use logical name " ++ pr_dirpath dir ++ strbrk " to save current library because" ++ strbrk " it already depends on a library of this name.") @@ -734,7 +734,7 @@ let save_library_to ?todo dir f otab = except Int.Set.empty in let is_done_or_todo i x = Future.is_val x || Int.Set.mem i except in Array.iteri (fun i x -> - if not(is_done_or_todo i x) then CErrors.errorlabstrm "library" + if not(is_done_or_todo i x) then CErrors.user_err ~hdr:"library" Pp.(str"Proof object "++int i++str" is not checked nor to be checked")) opaque_table; let sd = { diff --git a/library/library.mllib b/library/library.mllib index 920657365..df4f73503 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -5,7 +5,6 @@ Libobject Summary Nametab Global -Universes Lib Declaremods Loadpath diff --git a/library/nameops.ml b/library/nameops.ml index 71405d024..098f5112f 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -61,15 +61,27 @@ let make_ident sa = function if c < code_of_0 || c > code_of_9 then sa ^ (string_of_int n) else sa ^ "_" ^ (string_of_int n) in Id.of_string s - | None -> Id.of_string (String.copy sa) + | None -> Id.of_string sa let root_of_id id = let suffixstart = cut_ident true id in Id.of_string (String.sub (Id.to_string id) 0 suffixstart) -(* Rem: semantics is a bit different, if an ident starts with toto00 then - after successive renamings it comes to toto09, then it goes on with toto10 *) -let lift_subscript id = +(* Return the same identifier as the original one but whose {i subscript} is incremented. + If the original identifier does not have a suffix, [0] is appended to it. + + Example mappings: + + [bar] ↦ [bar0] + [bar0] ↦ [bar1] + [bar00] ↦ [bar01] + [bar1] ↦ [bar2] + [bar01] ↦ [bar01] + [bar9] ↦ [bar10] + [bar09] ↦ [bar10] + [bar99] ↦ [bar100] +*) +let increment_subscript id = let id = Id.to_string id in let len = String.length id in let rec add carrypos = @@ -80,20 +92,20 @@ let lift_subscript id = add (carrypos-1) end else begin - let newid = String.copy id in - String.fill newid (carrypos+1) (len-1-carrypos) '0'; - newid.[carrypos] <- Char.chr (Char.code c + 1); + let newid = Bytes.of_string id in + Bytes.fill newid (carrypos+1) (len-1-carrypos) '0'; + Bytes.set newid carrypos (Char.chr (Char.code c + 1)); newid end else begin - let newid = id^"0" in + let newid = Bytes.of_string (id^"0") in if carrypos < len-1 then begin - String.fill newid (carrypos+1) (len-1-carrypos) '0'; - newid.[carrypos+1] <- '1' + Bytes.fill newid (carrypos+1) (len-1-carrypos) '0'; + Bytes.set newid (carrypos+1) '1' end; newid end - in Id.of_string (add (len-1)) + in Id.of_bytes (add (len-1)) let has_subscript id = let id = Id.to_string id in @@ -101,9 +113,9 @@ let has_subscript id = let forget_subscript id = let numstart = cut_ident false id in - let newid = String.make (numstart+1) '0' in + let newid = Bytes.make (numstart+1) '0' in String.blit (Id.to_string id) 0 newid 0 numstart; - (Id.of_string newid) + (Id.of_bytes newid) let add_suffix id s = Id.of_string (Id.to_string id ^ s) let add_prefix s id = Id.of_string (s ^ Id.to_string id) diff --git a/library/nameops.mli b/library/nameops.mli index 39ce409bc..3a67b61a1 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -21,9 +21,34 @@ val root_of_id : Id.t -> Id.t (** remove trailing digits, ' and _ *) val add_suffix : Id.t -> string -> Id.t val add_prefix : string -> Id.t -> Id.t -val has_subscript : Id.t -> bool -val lift_subscript : Id.t -> Id.t -val forget_subscript : Id.t -> Id.t +(** Below, by {i subscript} we mean a suffix composed solely from (decimal) digits. *) + +val has_subscript : Id.t -> bool + +val increment_subscript : Id.t -> Id.t +(** Return the same identifier as the original one but whose {i subscript} is incremented. + If the original identifier does not have a suffix, [0] is appended to it. + + Example mappings: + + [bar] ↦ [bar0] + + [bar0] ↦ [bar1] + + [bar00] ↦ [bar01] + + [bar1] ↦ [bar2] + + [bar01] ↦ [bar01] + + [bar9] ↦ [bar10] + + [bar09] ↦ [bar10] + + [bar99] ↦ [bar100] +*) + +val forget_subscript : Id.t -> Id.t val out_name : Name.t -> Id.t (** [out_name] associates [id] to [Name id]. Raises [Failure "Nameops.out_name"] diff --git a/library/nametab.ml b/library/nametab.ml index fa5db37ed..b76048e89 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -16,10 +16,8 @@ open Globnames exception GlobalizationError of qualid -let error_global_not_found_loc loc q = - Loc.raise loc (GlobalizationError q) - -let error_global_not_found q = raise (GlobalizationError q) +let error_global_not_found ?loc q = + Loc.raise ?loc (GlobalizationError q) (* Kinds of global names *) @@ -455,11 +453,11 @@ let global r = try match locate_extended qid with | TrueGlobal ref -> ref | SynDef _ -> - user_err_loc (loc,"global", - str "Unexpected reference to a notation: " ++ - pr_qualid qid) + user_err ~loc ~hdr:"global" + (str "Unexpected reference to a notation: " ++ + pr_qualid qid) with Not_found -> - error_global_not_found_loc loc qid + error_global_not_found ~loc qid (* Exists functions ********************************************************) @@ -534,8 +532,8 @@ let global_inductive r = match global r with | IndRef ind -> ind | ref -> - user_err_loc (loc_of_reference r,"global_inductive", - pr_reference r ++ spc () ++ str "is not an inductive type") + user_err ~loc:(loc_of_reference r) ~hdr:"global_inductive" + (pr_reference r ++ spc () ++ str "is not an inductive type") (********************************************************************) diff --git a/library/nametab.mli b/library/nametab.mli index a8a0572b3..d20c399b6 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -60,8 +60,7 @@ open Globnames exception GlobalizationError of qualid (** Raises a globalization error *) -val error_global_not_found_loc : Loc.t -> qualid -> 'a -val error_global_not_found : qualid -> 'a +val error_global_not_found : ?loc:Loc.t -> qualid -> 'a (** {6 Register visibility of things } *) diff --git a/library/summary.ml b/library/summary.ml index 6efa07f38..2ec4760d6 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -107,8 +107,10 @@ let unfreeze_summaries fs = try fold id decl state with e when CErrors.noncritical e -> let e = CErrors.push e in - Printf.eprintf "Error unfrezing summay %s\n%s\n%!" - (name_of_summary id) (Pp.string_of_ppcmds (CErrors.iprint e)); + Feedback.msg_error + Pp.(seq [str "Error unfrezing summay %s\n%s\n%!"; + str (name_of_summary id); + CErrors.iprint e]); iraise e in (** We rely on the order of the frozen list, and the order of folding *) diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib deleted file mode 100644 index fc51e48ae..000000000 --- a/ltac/ltac.mllib +++ /dev/null @@ -1,22 +0,0 @@ -Taccoerce -Tacsubst -Tacenv -Tactic_debug -Tacintern -Tacentries -Profile_ltac -Tacinterp -Evar_tactics -Tactic_option -Extraargs -G_obligations -Coretactics -Extratactics -Profile_ltac_tactics -G_auto -G_class -Rewrite -G_rewrite -Tauto -G_eqdecide -G_ltac diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index aec6a3264..3b84eaa81 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -105,12 +105,12 @@ module Error = struct Printf.sprintf "Unsupported Unicode character (0x%x)" x) (* Require to fix the Camlp4 signature *) - let print ppf x = Pp.pp_with ~pp_tag:Ppstyle.pp_tag ppf (Pp.str (to_string x)) + let print ppf x = Pp.pp_with ppf (Pp.str (to_string x)) end open Error -let err loc str = Loc.raise (Compat.to_coqloc loc) (Error.E str) +let err loc str = Loc.raise ~loc:(Compat.to_coqloc loc) (Error.E str) let bad_token str = raise (Error.E (Bad_token str)) @@ -240,18 +240,19 @@ let unfreeze tt = (token_tree := tt) (* The string buffering machinery *) -let buff = ref (String.create 80) +let buff = ref (Bytes.create 80) let store len x = - if len >= String.length !buff then - buff := !buff ^ String.create (String.length !buff); - !buff.[len] <- x; + let open Bytes in + if len >= length !buff then + buff := cat !buff (create (length !buff)); + set !buff len x; succ len let rec nstore n len cs = if n>0 then nstore (n-1) (store len (Stream.next cs)) cs else len -let get_buff len = String.sub !buff 0 len +let get_buff len = Bytes.sub_string !buff 0 len (* The classical lexer: idents, numbers, quoted strings, comments *) @@ -382,6 +383,7 @@ let push_char c = real_push_char c let push_string s = Buffer.add_string current_comment s +let push_bytes s = Buffer.add_bytes current_comment s let null_comment s = let rec null i = @@ -716,13 +718,13 @@ let strip s = in if len == String.length s then s else - let s' = String.create len in + let s' = Bytes.create len in let rec loop i i' = if i == String.length s then s' else if s.[i] == ' ' then loop (i + 1) i' - else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end + else begin Bytes.set s' i' s.[i]; loop (i + 1) (i' + 1) end in - loop 0 0 + Bytes.to_string (loop 0 0) let terminal s = let s = strip s in diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index befa0d01b..4a36af2d8 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -218,7 +218,7 @@ module GrammarMake (L:LexerSig) : GrammarSig = struct L.drop_lexer_state (); let loc' = Loc.get_loc (Exninfo.info e) in let loc = match loc' with None -> to_coqloc loc | Some loc -> loc in - Loc.raise loc e + Loc.raise ~loc e let with_parsable (p,state) f x = L.set_lexer_state !state; try @@ -253,7 +253,7 @@ end module GrammarMake (L:LexerSig) : GrammarSig = struct (* We need to refer to Coq's module Loc before it is hidden by include *) - let raise_coq_loc loc e = Loc.raise (to_coqloc loc) e + let raise_coq_loc loc e = Loc.raise ~loc:(to_coqloc loc) e include Camlp4.Struct.Grammar.Static.Make (L) type 'a entry = 'a Entry.t type action = Action.t diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index a292c7463..07e4ddf84 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -71,7 +71,7 @@ let error_level_assoc p current expected = | Extend.LeftA -> str "left" | Extend.RightA -> str "right" | Extend.NonA -> str "non" in - errorlabstrm "" + user_err (str "Level " ++ int p ++ str " is already declared " ++ pr_assoc current ++ str " associative while it is now expected to be " ++ pr_assoc expected ++ str " associative.") @@ -434,7 +434,7 @@ let make_act : type r. r target -> _ -> r gen_eval = function CNotation (loc, notation , env) | ForPattern -> fun notation loc env -> let invalid = List.exists (fun (_, b) -> not b) env.binders in - let () = if invalid then Topconstr.error_invalid_pattern_notation loc in + let () = if invalid then Topconstr.error_invalid_pattern_notation ~loc () in let env = (env.constrs, env.constrlists) in CPatNotation (loc, notation, env, []) diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 7f3a3d10c..47455f984 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -55,9 +55,9 @@ let mk_fixb (id,bl,ann,body,(loc,tyc)) = let mk_cofixb (id,bl,ann,body,(loc,tyc)) = let _ = Option.map (fun (aloc,_) -> - CErrors.user_err_loc - (aloc,"Constr:mk_cofixb", - Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in + CErrors.user_err ~loc:aloc + ~hdr:"Constr:mk_cofixb" + (Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in let ty = match tyc with Some ty -> ty | None -> CHole (loc, None, IntroAnonymous, None) in @@ -215,9 +215,6 @@ GEXTEND Gram CGeneralization (!@loc, Implicit, None, c) | "`("; c = operconstr LEVEL "200"; ")" -> CGeneralization (!@loc, Explicit, None, c) - | IDENT "ltac"; ":"; "("; tac = Tactic.tactic_expr; ")" -> - let arg = Genarg.in_gen (Genarg.rawwit Constrarg.wit_tactic) tac in - CHole (!@loc, None, IntroAnonymous, Some arg) ] ] ; record_declaration: @@ -380,14 +377,14 @@ GEXTEND Gram [ p = pattern; lp = LIST1 NEXT -> (match p with | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, None, lp) - | CPatCstr (_, r, None, l2) -> CErrors.user_err_loc - (cases_pattern_expr_loc p, "compound_pattern", - Pp.str "Nested applications not supported.") + | CPatCstr (_, r, None, l2) -> CErrors.user_err + ~loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" + (Pp.str "Nested applications not supported.") | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp) | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp) - | _ -> CErrors.user_err_loc - (cases_pattern_expr_loc p, "compound_pattern", - Pp.str "Such pattern cannot have arguments.")) + | _ -> CErrors.user_err + ~loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" + (Pp.str "Such pattern cannot have arguments.")) |"@"; r = Prim.reference; lp = LIST0 NEXT -> CPatCstr (!@loc, r, Some lp, []) ] | "1" LEFTA diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index a38043d0c..2db91b8f8 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -28,7 +28,7 @@ let my_int_of_string loc s = if n > 1024 * 2048 then raise Exit; n with Failure _ | Exit -> - CErrors.user_err_loc (loc,"",Pp.str "Cannot support a so large number.") + CErrors.user_err ~loc (Pp.str "Cannot support a so large number.") GEXTEND Gram GLOBAL: @@ -93,7 +93,7 @@ GEXTEND Gram ; ne_string: [ [ s = STRING -> - if s="" then CErrors.user_err_loc(!@loc, "", Pp.str"Empty string."); s + if s="" then CErrors.user_err ~loc:(!@loc) (Pp.str"Empty string."); s ] ] ; ne_lstring: diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 70c5d5d88..4c5280538 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -13,7 +13,6 @@ open Misctypes open Tok open Pcoq -open Pcoq.Tactic open Pcoq.Prim open Pcoq.Constr open Pcoq.Vernac_ @@ -26,9 +25,11 @@ let hint_proof_using e = function | None -> None | Some s -> Some (Gram.entry_parse e (Gram.parsable (Stream.of_string s))) +let hint = Gram.entry_create "hint" + (* Proof commands *) GEXTEND Gram - GLOBAL: command; + GLOBAL: hint command; opt_hintbases: [ [ -> [] @@ -39,12 +40,6 @@ GEXTEND Gram | IDENT "Proof" -> VernacProof (None,hint_proof_using G_vernac.section_subset_expr None) | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn - | IDENT "Proof"; "with"; ta = tactic; - l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> - VernacProof (Some ta,hint_proof_using G_vernac.section_subset_expr l) - | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; - ta = OPT [ "with"; ta = tactic -> ta ] -> - VernacProof (ta,Some l) | IDENT "Proof"; c = lconstr -> VernacExactProof c | IDENT "Abort" -> VernacAbort None | IDENT "Abort"; IDENT "All" -> VernacAbortAll @@ -122,10 +117,7 @@ GEXTEND Gram | IDENT "Opaque"; lc = LIST1 global -> HintsTransparency (lc, false) | IDENT "Mode"; l = global; m = mode -> HintsMode (l, m) | IDENT "Unfold"; lqid = LIST1 global -> HintsUnfold lqid - | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc - | IDENT "Extern"; n = natural; c = OPT constr_pattern ; "=>"; - tac = tactic -> - HintsExtern (n,c,tac) ] ] + | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc ] ] ; constr_body: [ [ ":="; c = lconstr -> c diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 0c4dbcc8d..18807113c 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -115,7 +115,7 @@ GEXTEND Gram | Some (SelectNth g) -> c (Some g) | None -> c None | _ -> - VernacError (UserError ("",str"Typing and evaluation commands, cannot be used with the \"all:\" selector.")) + VernacError (UserError (None,str"Typing and evaluation commands, cannot be used with the \"all:\" selector.")) end ] ] ; located_vernac: @@ -260,7 +260,7 @@ GEXTEND Gram ProveBody (bl, t) ] ] ; reduce: - [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r + [ [ IDENT "Eval"; r = red_expr; "in" -> Some r | -> None ] ] ; one_decl_notation: @@ -580,12 +580,6 @@ let warn_deprecated_implicit_arguments = CWarnings.create ~name:"deprecated-implicit-arguments" ~category:"deprecated" (fun () -> strbrk "Implicit Arguments is deprecated; use Arguments instead") -let warn_deprecated_arguments_syntax = - CWarnings.create ~name:"deprecated-arguments-syntax" ~category:"deprecated" - (fun () -> strbrk "The \"/\" and \"!\" modifiers have an effect only " - ++ strbrk "in the first arguments list. The syntax allowing" - ++ strbrk " them to appear in other lists is deprecated.") - (* Extensions: implicits, coercions, etc. *) GEXTEND Gram GLOBAL: gallina_ext instance_name hint_info; @@ -663,10 +657,7 @@ GEXTEND Gram args = LIST0 argument_spec_block; more_implicits = OPT [ ","; impl = LIST1 - [ impl = LIST0 more_implicits_block -> - let warn_deprecated = List.exists fst impl in - if warn_deprecated then warn_deprecated_arguments_syntax ~loc:!@loc (); - List.flatten (List.map snd impl)] + [ impl = LIST0 more_implicits_block -> List.flatten impl] SEP "," -> impl ]; mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> l ] -> @@ -783,12 +774,11 @@ GEXTEND Gram ]; (* Same as [argument_spec_block], but with only implicit status and names *) more_implicits_block: [ - [ (bang,name) = name_or_bang -> (bang, [(snd name, Vernacexpr.NotImplicit)]) - | "/" -> (true (* Should warn about deprecated syntax *), []) - | "["; items = LIST1 name_or_bang; "]" -> - (List.exists fst items, List.map (fun (_,(_,name)) -> (name, Vernacexpr.Implicit)) items) - | "{"; items = LIST1 name_or_bang; "}" -> - (List.exists fst items, List.map (fun (_,(_,name)) -> (name, Vernacexpr.MaximallyImplicit)) items) + [ name = name -> [(snd name, Vernacexpr.NotImplicit)] + | "["; items = LIST1 name; "]" -> + List.map (fun name -> (snd name, Vernacexpr.Implicit)) items + | "{"; items = LIST1 name; "}" -> + List.map (fun name -> (snd name, Vernacexpr.MaximallyImplicit)) items ] ]; strategy_level: @@ -929,7 +919,7 @@ GEXTEND Gram VernacRemoveOption ([table], v) ]] ; query_command: (* TODO: rapprocher Eval et Check *) - [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr -> + [ [ IDENT "Eval"; r = red_expr; "in"; c = lconstr -> fun g -> VernacCheckMayEval (Some r, g, c) | IDENT "Compute"; c = lconstr -> fun g -> VernacCheckMayEval (Some (Genredexpr.CbvVm None), g, c) @@ -1086,7 +1076,7 @@ GEXTEND Gram (* registration of a custom reduction *) | IDENT "Declare"; IDENT "Reduction"; s = IDENT; ":="; - r = Tactic.red_expr -> + r = red_expr -> VernacDeclareReduction (s,r) ] ]; diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib index 8df519b56..05e2911c2 100644 --- a/parsing/highparsing.mllib +++ b/parsing/highparsing.mllib @@ -2,4 +2,3 @@ G_constr G_vernac G_prim G_proofs -G_tactic diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 007a6c767..b8405ca8c 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -326,48 +326,6 @@ module Module = let module_type = Gram.entry_create "module_type" end -module Tactic = - struct - (* Main entry for extensions *) - let simple_tactic = Gram.entry_create "tactic:simple_tactic" - - (* Entries that can be referred via the string -> Gram.entry table *) - (* Typically for tactic user extensions *) - let open_constr = - make_gen_entry utactic "open_constr" - let constr_with_bindings = - make_gen_entry utactic "constr_with_bindings" - let bindings = - make_gen_entry utactic "bindings" - let hypident = Gram.entry_create "hypident" - let constr_may_eval = make_gen_entry utactic "constr_may_eval" - let constr_eval = make_gen_entry utactic "constr_eval" - let uconstr = - make_gen_entry utactic "uconstr" - let quantified_hypothesis = - make_gen_entry utactic "quantified_hypothesis" - let destruction_arg = make_gen_entry utactic "destruction_arg" - let int_or_var = make_gen_entry utactic "int_or_var" - let red_expr = make_gen_entry utactic "red_expr" - let simple_intropattern = - make_gen_entry utactic "simple_intropattern" - let in_clause = make_gen_entry utactic "in_clause" - let clause_dft_concl = - make_gen_entry utactic "clause" - - - (* Main entries for ltac *) - let tactic_arg = Gram.entry_create "tactic:tactic_arg" - let tactic_expr = make_gen_entry utactic "tactic_expr" - let binder_tactic = make_gen_entry utactic "binder_tactic" - - let tactic = make_gen_entry utactic "tactic" - - (* Main entry for quotations *) - let tactic_eoi = eoi_entry tactic - - end - module Vernac_ = struct let gec_vernac s = Gram.entry_create ("vernac:" ^ s) @@ -380,6 +338,7 @@ module Vernac_ = let vernac = gec_vernac "Vernac.vernac" let vernac_eoi = eoi_entry vernac let rec_definition = gec_vernac "Vernac.rec_definition" + let red_expr = make_gen_entry utactic "red_expr" let hint_info = gec_vernac "hint_info" (* Main vernac entry *) let main_entry = Gram.entry_create "vernac" @@ -502,27 +461,12 @@ let with_grammar_rule_protection f x = let () = let open Stdarg in - let open Constrarg in -(* Grammar.register0 wit_unit; *) -(* Grammar.register0 wit_bool; *) Grammar.register0 wit_int (Prim.integer); Grammar.register0 wit_string (Prim.string); Grammar.register0 wit_pre_ident (Prim.preident); - Grammar.register0 wit_int_or_var (Tactic.int_or_var); - Grammar.register0 wit_intro_pattern (Tactic.simple_intropattern); Grammar.register0 wit_ident (Prim.ident); Grammar.register0 wit_var (Prim.var); Grammar.register0 wit_ref (Prim.reference); - Grammar.register0 wit_quant_hyp (Tactic.quantified_hypothesis); Grammar.register0 wit_constr (Constr.constr); - Grammar.register0 wit_uconstr (Tactic.uconstr); - Grammar.register0 wit_open_constr (Tactic.open_constr); - Grammar.register0 wit_constr_with_bindings (Tactic.constr_with_bindings); - Grammar.register0 wit_bindings (Tactic.bindings); -(* Grammar.register0 wit_hyp_location_flag; *) - Grammar.register0 wit_red_expr (Tactic.red_expr); - Grammar.register0 wit_tactic (Tactic.tactic); - Grammar.register0 wit_ltac (Tactic.tactic); - Grammar.register0 wit_clause_dft_concl (Tactic.clause_dft_concl); - Grammar.register0 wit_destruction_arg (Tactic.destruction_arg); + Grammar.register0 wit_red_expr (Vernac_.red_expr); () diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index fc1727fc1..cf5174af9 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -12,7 +12,6 @@ open Extend open Vernacexpr open Genarg open Constrexpr -open Tacexpr open Libnames open Misctypes open Genredexpr @@ -179,30 +178,6 @@ module Module : val module_type : module_ast Gram.entry end -module Tactic : - sig - val open_constr : constr_expr Gram.entry - val constr_with_bindings : constr_expr with_bindings Gram.entry - val bindings : constr_expr bindings Gram.entry - val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry - val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry - val constr_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry - val uconstr : constr_expr Gram.entry - val quantified_hypothesis : quantified_hypothesis Gram.entry - val destruction_arg : constr_expr with_bindings destruction_arg Gram.entry - val int_or_var : int or_var Gram.entry - val red_expr : raw_red_expr Gram.entry - val simple_tactic : raw_tactic_expr Gram.entry - val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry - val in_clause : Names.Id.t Loc.located Locus.clause_expr Gram.entry - val clause_dft_concl : Names.Id.t Loc.located Locus.clause_expr Gram.entry - val tactic_arg : raw_tactic_arg Gram.entry - val tactic_expr : raw_tactic_expr Gram.entry - val binder_tactic : raw_tactic_expr Gram.entry - val tactic : raw_tactic_expr Gram.entry - val tactic_eoi : raw_tactic_expr Gram.entry - end - module Vernac_ : sig val gallina : vernac_expr Gram.entry @@ -214,6 +189,7 @@ module Vernac_ : val vernac_eoi : vernac_expr Gram.entry val noedit_mode : vernac_expr Gram.entry val command_entry : vernac_expr Gram.entry + val red_expr : raw_red_expr Gram.entry val hint_info : Vernacexpr.hint_info_expr Gram.entry end diff --git a/plugins/btauto/g_btauto.ml4 b/plugins/btauto/g_btauto.ml4 index f3e2c99f4..298027448 100644 --- a/plugins/btauto/g_btauto.ml4 +++ b/plugins/btauto/g_btauto.ml4 @@ -8,6 +8,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin + DECLARE PLUGIN "btauto_plugin" TACTIC EXTEND btauto diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 6e8b2eb0f..2c5b108e5 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -15,7 +15,7 @@ let get_inductive dir s = Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ())) let decomp_term (c : Term.constr) = - Term.kind_of_term (Term.strip_outer_cast c) + Term.kind_of_term (Termops.strip_outer_cast c) let lapp c v = Term.mkApp (Lazy.force c, v) diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index bc53b113d..7347c3c2c 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -444,7 +444,7 @@ and applist_projection c l = let p = Projection.make (fst c) false in (match l with | [] -> (* Expand the projection *) - let ty,_ = Typeops.type_of_constant (Global.env ()) c in + let ty = Typeops.type_of_constant_in (Global.env ()) c in (* FIXME constraints *) let pb = Environ.lookup_projection p (Global.env()) in let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index fd46d8069..b5ca2f50f 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -23,7 +23,9 @@ open Pp open CErrors open Util open Proofview.Notations -open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration let reference dir s = lazy (Coqlib.gen_reference "CC" dir s) @@ -84,7 +86,7 @@ let rec decompose_term env sigma t= let p' = Projection.map canon_const p in (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c)) | _ -> - let t = strip_outer_cast t in + let t = Termops.strip_outer_cast t in if closed0 t then Symb t else raise Not_found (* decompose equality in members and type *) @@ -155,7 +157,7 @@ let rec quantified_atom_of_constr env sigma nrels term = let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else - quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma (succ nrels) ff + quantified_atom_of_constr (Environ.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma (succ nrels) ff | _ -> let patts=patterns_of_constr env sigma nrels term in `Rule patts @@ -170,7 +172,7 @@ let litteral_of_constr env sigma term= else begin try - quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma 1 ff + quantified_atom_of_constr (Environ.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end @@ -192,10 +194,10 @@ let make_prb gls depth additionnal_terms = ignore (add_term state t)) additionnal_terms; List.iter (fun decl -> - let (id,_,e) = Context.Named.Declaration.to_tuple decl in + let id = NamedDecl.get_id decl in begin let cid=mkVar id in - match litteral_of_constr env sigma e with + match litteral_of_constr env sigma (NamedDecl.get_type decl) with `Eq (t,a,b) -> add_equality state cid a b | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b | `Other ph -> @@ -456,7 +458,7 @@ let cc_tactic depth additionnal_terms = end } let cc_fail gls = - errorlabstrm "Congruence" (Pp.str "congruence failed.") + user_err ~hdr:"Congruence" (Pp.str "congruence failed.") let congruence_tac depth l = Tacticals.New.tclORELSE diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index 52a135119..7e76854b1 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -8,9 +8,9 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Cctac open Stdarg -open Constrarg DECLARE PLUGIN "cc_plugin" diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index a862423e9..2b63ed6d6 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open CErrors open Util open Names @@ -90,8 +91,8 @@ let rec add_vars_of_simple_pattern globs = function (* Loc.raise loc (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) | CPatOr (loc, _)-> - Loc.raise loc - (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) + Loc.raise ~loc + (UserError (Some "simple_pattern",str "\"(_ | _)\" is not allowed here")) | CPatDelimiters (_,_,p) -> add_vars_of_simple_pattern globs p | CPatCstr (_,_,pl1,pl2) -> @@ -328,7 +329,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = let _ = let expected = mib.Declarations.mind_nparams - num_params in if not (Int.equal (List.length params) expected) then - errorlabstrm "suppose it is" + user_err ~hdr:"suppose it is" (str "Wrong number of extra arguments: " ++ (if Int.equal expected 0 then str "none" else int expected) ++ spc () ++ str "expected.") in @@ -348,7 +349,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = Thesis (Plain) -> Glob_term.GSort(Loc.ghost,GProp) | Thesis (For rec_occ) -> if not (Id.List.mem rec_occ pat_vars) then - errorlabstrm "suppose it is" + user_err ~hdr:"suppose it is" (str "Variable " ++ Nameops.pr_id rec_occ ++ str " does not occur in pattern."); Glob_term.GSort(Loc.ghost,GProp) diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index d30fcf603..deb2ede1d 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open CErrors open Util open Pp @@ -32,6 +33,9 @@ open Misctypes open Sigma.Notations open Context.Named.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (* Strictness option *) let clear ids { it = goal; sigma } = @@ -43,7 +47,7 @@ let clear ids { it = goal; sigma } = let (hyps, concl) = try Evarutil.clear_hyps_in_evi env evdref sign cl ids with Evarutil.ClearDependencyError (id, _) -> - errorlabstrm "" (str "Cannot clear " ++ pr_id id) + user_err (str "Cannot clear " ++ pr_id id) in let sigma = !evdref in let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in @@ -247,7 +251,7 @@ let close_previous_case pts = let filter_hyps f gls = let filter_aux id = - let id = get_id id in + let id = NamedDecl.get_id id in if f id then tclIDTAC else @@ -357,8 +361,7 @@ let enstack_subsubgoals env se stack gls= let nlast=succ last in let (llast,holes,metas) = meta_aux nlast (mkMeta nlast :: lenv) q in - let open Context.Rel.Declaration in - (llast,holes,(nlast,special_nf gls (substl lenv (get_type decl)))::metas) in + (llast,holes,(nlast,special_nf gls (substl lenv (RelDecl.get_type decl)))::metas) in let (nlast,holes,nmetas) = meta_aux se.se_last_meta [] (List.rev rc) in let refiner = applist (appterm,List.rev holes) in @@ -821,9 +824,8 @@ let define_tac id args body gls = let cast_tac id_or_thesis typ gls = match id_or_thesis with - This id -> - let body = pf_get_hyp gls id |> get_value in - Proofview.V82.of_tactic (convert_hyp (of_tuple (id,body,typ))) gls + | This id -> + Proofview.V82.of_tactic (id |> pf_get_hyp gls |> NamedDecl.set_id id |> NamedDecl.set_type typ |> convert_hyp) gls | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> @@ -1082,12 +1084,12 @@ let thesis_for obj typ per_info env= let cind,all_args=decompose_app typ in let ind,u = destInd cind in let _ = if not (eq_ind ind per_info.per_ind) then - errorlabstrm "thesis_for" + user_err ~hdr:"thesis_for" ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str"cannot give an induction hypothesis (wrong inductive type).") in let params,args = List.chop per_info.per_nparams all_args in let _ = if not (List.for_all2 eq_constr params per_info.per_params) then - errorlabstrm "thesis_for" + user_err ~hdr:"thesis_for" ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 6c17dcc4f..a71d20f0d 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -10,6 +10,7 @@ DECLARE PLUGIN "decl_mode_plugin" +open Ltac_plugin open Compat open Pp open Decl_expr @@ -19,7 +20,7 @@ open Vernacexpr open Tok (* necessary for camlp4 *) open Pcoq.Constr -open Pcoq.Tactic +open Pltac open Ppdecl_proof let pr_goal gs = diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml index 59a0bb5a2..f5de638ed 100644 --- a/plugins/decl_mode/ppdecl_proof.ml +++ b/plugins/decl_mode/ppdecl_proof.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open CErrors open Pp open Decl_expr diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.ml4 index d4dc7e0ee..deadb3b4d 100644 --- a/plugins/derive/g_derive.ml4 +++ b/plugins/derive/g_derive.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Constrarg +open Stdarg (*i camlp4deps: "grammar/grammar.cma" i*) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 3c5f6cb72..fc8d5356c 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -67,7 +67,9 @@ let pp_boxed_tuple f = function blocks is less that a line length. To avoid this awkward situation, we attach a big virtual size to [fnl] newlines. *) -let fnl () = stras (1000000,"") ++ fnl () +(* EG: This looks quite suspicious... but beware of bugs *) +(* let fnl () = stras (1000000,"") ++ fnl () *) +let fnl () = fnl () let fnl2 () = fnl () ++ fnl () @@ -91,10 +93,7 @@ let begins_with_CoqXX s = let unquote s = if lang () != Scheme then s - else - let s = String.copy s in - for i=0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done; - s + else String.map (fun c -> if c == '\'' then '~' else c) s let rec qualify delim = function | [] -> assert false @@ -145,7 +144,7 @@ type env = Id.t list * Id.Set.t (*s Generic renaming issues for local variable names. *) let rec rename_id id avoid = - if Id.Set.mem id avoid then rename_id (lift_subscript id) avoid else id + if Id.Set.mem id avoid then rename_id (increment_subscript id) avoid else id let rec rename_vars avoid = function | [] -> @@ -308,15 +307,16 @@ end module DupMap = Map.Make(DupOrd) -let add_duplicate, check_duplicate = +let add_duplicate, get_duplicate = let index = ref 0 and dups = ref DupMap.empty in register_cleanup (fun () -> index := 0; dups := DupMap.empty); let add mp l = incr index; let ren = "Coq__" ^ string_of_int !index in dups := DupMap.add (mp,l) ren !dups - and check mp l = DupMap.find (mp, l) !dups - in (add,check) + and get mp l = + try Some (DupMap.find (mp, l) !dups) with Not_found -> None + in (add,get) type reset_kind = AllButExternal | Everything @@ -510,10 +510,11 @@ let pp_duplicate k' prefix mp rls olab = (* Here rls=s::rls', we search the label for s inside mp *) List.tl rls, get_nth_label_mp (mp_length mp - mp_length prefix) mp in - try dottify (check_duplicate prefix lbl :: rls') - with Not_found -> - assert (get_phase () == Pre); (* otherwise it's too late *) - add_duplicate prefix lbl; dottify rls + match get_duplicate prefix lbl with + | Some ren -> dottify (ren :: rls') + | None -> + assert (get_phase () == Pre); (* otherwise it's too late *) + add_duplicate prefix lbl; dottify rls let fstlev_ks k = function | [] -> assert false diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 2f5601964..b8e95afb3 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -62,7 +62,7 @@ val top_visible_mp : unit -> module_path val push_visible : module_path -> module_path list -> unit val pop_visible : unit -> unit -val check_duplicate : module_path -> Label.t -> string +val get_duplicate : module_path -> Label.t -> string option type reset_kind = AllButExternal | Everything diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 52f22ee60..2b12462ad 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -472,13 +472,14 @@ let formatter dry file = if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) else match file with - | Some f -> Pp_control.with_output_to f + | Some f -> Topfmt.with_output_to f | None -> Format.formatter_of_buffer buf in + (* XXX: Fixme, this shouldn't depend on Topfmt *) (* We never want to see ellipsis ... in extracted code *) Format.pp_set_max_boxes ft max_int; (* We reuse the width information given via "Set Printing Width" *) - (match Pp_control.get_margin () with + (match Topfmt.get_margin () with | None -> () | Some i -> Format.pp_set_margin ft i; @@ -507,8 +508,7 @@ let print_structure_to_file (fn,si,mo) dry struc = in (* First, a dry run, for computing objects to rename or duplicate *) set_phase Pre; - let devnull = formatter true None in - pp_with devnull (d.pp_struct struc); + ignore (d.pp_struct struc); let opened = opened_libraries () in (* Print the implementation *) let cout = if dry then None else Option.map open_out fn in @@ -519,8 +519,10 @@ let print_structure_to_file (fn,si,mo) dry struc = set_phase Impl; pp_with ft (d.preamble mo comment opened unsafe_needs); pp_with ft (d.pp_struct struc); + Format.pp_print_flush ft (); Option.iter close_out cout; with reraise -> + Format.pp_print_flush ft (); Option.iter close_out cout; raise reraise end; if not dry then Option.iter info_file fn; @@ -533,8 +535,10 @@ let print_structure_to_file (fn,si,mo) dry struc = set_phase Intf; pp_with ft (d.sig_preamble mo comment opened unsafe_needs); pp_with ft (d.pp_sig (signature_of_structure struc)); + Format.pp_print_flush ft (); close_out cout; with reraise -> + Format.pp_print_flush ft (); close_out cout; raise reraise end; info_file si) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index a980a43f5..2b19c2805 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -258,7 +258,7 @@ let rec extract_type env db j c args = | Const (kn,u as c) -> let r = ConstRef kn in let cb = lookup_constant kn env in - let typ,_ = Typeops.type_of_constant env c in + let typ = Typeops.type_of_constant_in env c in (match flag_of_type env typ with | (Logic,_) -> assert false (* Cf. logical cases above *) | (Info, TypeScheme) -> diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index 19fda4aea..3ed959cf2 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -12,9 +12,9 @@ DECLARE PLUGIN "extraction_plugin" (* ML names *) +open Ltac_plugin open Genarg open Stdarg -open Constrarg open Pcoq.Prim open Pp open Names diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 5d10cb939..d8e382155 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -66,7 +66,7 @@ let pp_header_comment = function | None -> mt () | Some com -> pp_comment com ++ fnl2 () -let then_nl pp = if Pp.is_empty pp then mt () else pp ++ fnl () +let then_nl pp = if Pp.ismt pp then mt () else pp ++ fnl () let pp_tdummy usf = if usf.tdummy || usf.tunknown then str "type __ = Obj.t" ++ fnl () else mt () @@ -555,24 +555,6 @@ let pp_decl = function | Dfix (rv,defs,typs) -> pp_Dfix (rv,defs,typs) -let pp_alias_decl ren = function - | Dind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } - | Dtype (r, l, _) -> - let name = pp_global Type r in - let l = rename_tvars keywords l in - let ids = pp_parameters l in - hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ - str (ren^".") ++ name) - | Dterm (r, a, t) -> - let name = pp_global Term r in - hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) - | Dfix (rv, _, _) -> - prvecti (fun i r -> if is_inline_custom r then mt () else - let name = pp_global Term r in - hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) ++ - fnl ()) - rv - let pp_spec = function | Sval (r,_) when is_inline_custom r -> mt () | Stype (r,_,_) when is_inline_custom r -> mt () @@ -597,43 +579,32 @@ let pp_spec = function in hov 2 (str "type " ++ ids ++ name ++ def) -let pp_alias_spec ren = function - | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } - | Stype (r,l,_) -> - let name = pp_global Type r in - let l = rename_tvars keywords l in - let ids = pp_parameters l in - hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ - str (ren^".") ++ name) - | Sval _ -> assert false - let rec pp_specif = function | (_,Spec (Sval _ as s)) -> pp_spec s | (l,Spec s) -> - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in + (match Common.get_duplicate (top_visible_mp ()) l with + | None -> pp_spec s + | Some ren -> hov 1 (str ("module "^ren^" : sig") ++ fnl () ++ pp_spec s) ++ fnl () ++ str "end" ++ fnl () ++ - pp_alias_spec ren s - with Not_found -> pp_spec s) + str ("include module type of struct include "^ren^" end")) | (l,Smodule mt) -> let def = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module " ++ name ++ str " :" ++ fnl () ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in + (match Common.get_duplicate (top_visible_mp ()) l with + | None -> Pp.mt () + | Some ren -> fnl () ++ hov 1 (str ("module "^ren^" :") ++ spc () ++ - str "module type of struct include " ++ name ++ str " end") - with Not_found -> Pp.mt ()) + str "module type of struct include " ++ name ++ str " end")) | (l,Smodtype mt) -> let def = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ str ("module type "^ren^" = ") ++ name - with Not_found -> Pp.mt ()) + (match Common.get_duplicate (top_visible_mp ()) l with + | None -> Pp.mt () + | Some ren -> fnl () ++ str ("module type "^ren^" = ") ++ name) and pp_module_type params = function | MTident kn -> @@ -647,15 +618,17 @@ and pp_module_type params = function push_visible mp params; let try_pp_specif l x = let px = pp_specif x in - if Pp.is_empty px then l else px::l + if Pp.ismt px then l else px::l in (* We cannot use fold_right here due to side effects in pp_specif *) let l = List.fold_left try_pp_specif [] sign in let l = List.rev l in pop_visible (); str "sig" ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ - fnl () ++ str "end" + (if List.is_empty l then mt () + else + v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl ()) + ++ str "end" | MTwith(mt,ML_With_type(idl,vl,typ)) -> let ids = pp_parameters (rename_tvars keywords vl) in let mp_mt = msid_of_mt mt in @@ -682,12 +655,11 @@ let is_short = function MEident _ | MEapply _ -> true | _ -> false let rec pp_structure_elem = function | (l,SEdecl d) -> - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in + (match Common.get_duplicate (top_visible_mp ()) l with + | None -> pp_decl d + | Some ren -> hov 1 (str ("module "^ren^" = struct") ++ fnl () ++ pp_decl d) ++ - fnl () ++ str "end" ++ fnl () ++ - pp_alias_decl ren d - with Not_found -> pp_decl d) + fnl () ++ str "end" ++ fnl () ++ str ("include "^ren)) | (l,SEmodule m) -> let typ = (* virtual printing of the type, in order to have a correct mli later*) @@ -700,18 +672,16 @@ let rec pp_structure_elem = function hov 1 (str "module " ++ name ++ typ ++ str " =" ++ (if is_short m.ml_mod_expr then spc () else fnl ()) ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ str ("module "^ren^" = ") ++ name - with Not_found -> mt ()) + (match Common.get_duplicate (top_visible_mp ()) l with + | Some ren -> fnl () ++ str ("module "^ren^" = ") ++ name + | None -> mt ()) | (l,SEmodtype m) -> let def = pp_module_type [] m in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ str ("module type "^ren^" = ") ++ name - with Not_found -> mt ()) + (match Common.get_duplicate (top_visible_mp ()) l with + | None -> mt () + | Some ren -> fnl () ++ str ("module type "^ren^" = ") ++ name) and pp_module_expr params = function | MEident mp -> pp_modname mp @@ -726,15 +696,17 @@ and pp_module_expr params = function push_visible mp params; let try_pp_structure_elem l x = let px = pp_structure_elem x in - if Pp.is_empty px then l else px::l + if Pp.ismt px then l else px::l in (* We cannot use fold_right here due to side effects in pp_structure_elem *) let l = List.fold_left try_pp_structure_elem [] sel in let l = List.rev l in pop_visible (); str "struct" ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ - fnl () ++ str "end" + (if List.is_empty l then mt () + else + v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl ()) + ++ str "end" let rec prlist_sep_nonempty sep f = function | [] -> mt () @@ -742,7 +714,7 @@ let rec prlist_sep_nonempty sep f = function | h::t -> let e = f h in let r = prlist_sep_nonempty sep f t in - if Pp.is_empty e then r + if Pp.ismt e then r else e ++ sep () ++ r let do_struct f s = diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index a6309e61f..8d0cc4a0d 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -40,11 +40,7 @@ let preamble _ comment _ usf = (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ()) let pr_id id = - let s = Id.to_string id in - for i = 0 to String.length s - 1 do - if s.[i] == '\'' then s.[i] <- '~' - done; - str s + str @@ String.map (fun c -> if c == '\'' then '~' else c) (Id.to_string id) let paren = pp_par true diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index ff66d915f..d6a334c5f 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -293,7 +293,7 @@ let pr_long_global ref = pr_path (Nametab.path_of_global ref) (*S Warning and Error messages. *) -let err s = errorlabstrm "Extraction" s +let err s = user_err ~hdr:"Extraction" s let warn_extraction_axiom_to_realize = CWarnings.create ~name:"extraction-axiom-to-realize" ~category:"extraction" @@ -773,9 +773,7 @@ let file_of_modfile mp = | MPfile f -> Id.to_string (List.hd (DirPath.repr f)) | _ -> assert false in - let s = String.copy (string_of_modfile mp) in - if s.[0] != s0.[0] then s.[0] <- s0.[0]; - s + String.mapi (fun i c -> if i = 0 then s0.[0] else c) (string_of_modfile mp) let add_blacklist_entries l = blacklist_table := diff --git a/plugins/extraction/vo.itarget b/plugins/extraction/vo.itarget index 3563f71df..9c30c5eb3 100644 --- a/plugins/extraction/vo.itarget +++ b/plugins/extraction/vo.itarget @@ -1,4 +1,3 @@ -Extraction.vo ExtrHaskellBasic.vo ExtrHaskellNatNum.vo ExtrHaskellNatInt.vo diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 58744b575..b34a36492 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -15,7 +15,8 @@ open Tacmach open Util open Declarations open Globnames -open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration let qflag=ref true @@ -141,7 +142,7 @@ let build_atoms gl metagen side cciterm = end; let v = ind_hyps 0 i l gl in let g i _ decl = - build_rec env polarity (lift i (get_type decl)) in + build_rec env polarity (lift i (RelDecl.get_type decl)) in let f l = List.fold_left_i g (1-(List.length l)) () l in if polarity && (* we have a constant constructor *) @@ -152,7 +153,7 @@ let build_atoms gl metagen side cciterm = let var=mkMeta (metagen true) in let v =(ind_hyps 1 i l gl).(0) in let g i _ decl = - build_rec (var::env) polarity (lift i (get_type decl)) in + build_rec (var::env) polarity (lift i (RelDecl.get_type decl)) in List.fold_left_i g (2-(List.length l)) () v | Forall(_,b)-> let var=mkMeta (metagen true) in @@ -225,7 +226,7 @@ let build_formula side nam typ gl metagen= | And(_,_,_) -> Rand | Or(_,_,_) -> Ror | Exists (i,l) -> - let d = get_type (List.last (ind_hyps 0 i l gl).(0)) in + let d = RelDecl.get_type (List.last (ind_hyps 0 i l gl).(0)) in Rexists(m,d,trivial) | Forall (_,a) -> Rforall | Arrow (a,b) -> Rarrow in diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 43fac8ad8..e28d6aa62 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Formula open Sequent open Ground @@ -15,8 +16,8 @@ open Goptions open Tacticals open Tacinterp open Libnames -open Constrarg open Stdarg +open Tacarg open Pcoq.Prim DECLARE PLUGIN "ground_plugin" diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 628af4e71..d6cd7e2a0 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open Formula open Sequent open Rules diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index ffb63af07..7ffc78928 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -19,7 +19,8 @@ open Formula open Sequent open Globnames open Locus -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic @@ -36,12 +37,12 @@ let wrap n b continue seq gls= match nc with []->anomaly (Pp.str "Not the expected number of hyps") | nd::q-> - let id = get_id nd in + let id = NamedDecl.get_id nd in if occur_var env id (pf_concl gls) || List.exists (occur_var_in_decl env id) ctx then (aux (i-1) q (nd::ctx)) else - add_formula Hyp (VarRef id) (get_type nd) (aux (i-1) q (nd::ctx)) gls in + add_formula Hyp (VarRef id) (NamedDecl.get_type nd) (aux (i-1) q (nd::ctx)) gls in let seq1=aux n nc [] in let seq2=if b then add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v index 1d7ee93ea..a96254713 100644 --- a/plugins/fourier/Fourier.v +++ b/plugins/fourier/Fourier.v @@ -13,6 +13,6 @@ Require Export DiscrR. Require Export Fourier_util. Declare ML Module "fourier_plugin". -Ltac fourier := abstract (fourierz; field; discrR). +Ltac fourier := abstract (compute [IZR IPR IPR_2] in *; fourierz; field; discrR). Ltac fourier_eq := apply Rge_antisym; fourier. diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 51bd3009a..8e193c753 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -462,7 +462,7 @@ let rec fourier () = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; - let goal = strip_outer_cast concl in + let goal = Termops.strip_outer_cast concl in let fhyp=Id.of_string "new_hyp_for_fourier" in (* si le but est une inéquation, on introduit son contraire, et le but à prouver devient False *) diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 index 7c665ae7b..1960fa835 100644 --- a/plugins/fourier/g_fourier.ml4 +++ b/plugins/fourier/g_fourier.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open FourierR DECLARE PLUGIN "fourier_plugin" diff --git a/plugins/funind/FunInd.v b/plugins/funind/FunInd.v deleted file mode 100644 index e69de29bb..000000000 --- a/plugins/funind/FunInd.v +++ /dev/null diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 0bbe4bb4c..3199474dd 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -16,6 +16,8 @@ open Libnames open Globnames open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (* let msgnl = Pp.msgnl *) (* @@ -307,7 +309,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = try let witness = Int.Map.find i sub in if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (Termops.pop end_of_type,ctxt_size,mkLetIn (get_name decl, witness, get_type decl, witness_fun)) + (Termops.pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) @@ -938,8 +940,8 @@ let generalize_non_dep hyp g = ((* observe_tac "thin" *) (thin to_revert)) g -let id_of_decl decl = Nameops.out_name (get_name decl) -let var_of_decl decl = mkVar (id_of_decl decl) +let id_of_decl = RelDecl.get_name %> Nameops.out_name +let var_of_decl = id_of_decl %> mkVar let revert idl = tclTHEN (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) @@ -1072,7 +1074,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (Name new_id) ) in - let fresh_decl = map_name fresh_id in + let fresh_decl = RelDecl.map_name fresh_id in let princ_info : elim_scheme = { princ_info with params = List.map fresh_decl princ_info.params; @@ -1119,11 +1121,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam ) in observe (str "full_params := " ++ - prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) + prlist_with_sep spc (RelDecl.get_name %> Nameops.out_name %> Ppconstr.pr_id) full_params ); observe (str "princ_params := " ++ - prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) + prlist_with_sep spc (RelDecl.get_name %> Nameops.out_name %> Ppconstr.pr_id) princ_params ); observe (str "fbody_with_full_params := " ++ @@ -1165,7 +1167,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let pte_to_fix,rev_info = List.fold_left_i (fun i (acc_map,acc_info) decl -> - let pte = get_name decl in + let pte = RelDecl.get_name decl in let infos = info_array.(i) in let type_args,_ = decompose_prod infos.types in let nargs = List.length type_args in @@ -1276,7 +1278,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (do_replace evd full_params (fix_info.idx + List.length princ_params) - (args_id@(List.map (fun decl -> Nameops.out_name (get_name decl)) princ_params)) + (args_id@(List.map (RelDecl.get_name %> Nameops.out_name) princ_params)) (all_funs.(fix_info.num_in_block)) fix_info.num_in_block all_funs @@ -1555,7 +1557,7 @@ let prove_principle_for_gen | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (fun decl -> mkVar (Nameops.out_name (get_name decl))) (pre_rec_arg@princ_info.params) in + let subst_constrs = List.map (get_name %> Nameops.out_name %> mkVar) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in @@ -1583,7 +1585,7 @@ let prove_principle_for_gen ) g in - let args_ids = List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.args in + let args_ids = List.map (get_name %> Nameops.out_name) princ_info.args in let lemma = match !tcc_lemma_ref with | None -> error "No tcc proof !!" @@ -1630,7 +1632,7 @@ let prove_principle_for_gen [ observe_tac "start_tac" start_tac; h_intros - (List.rev_map (fun decl -> Nameops.out_name (get_name decl)) + (List.rev_map (get_name %> Nameops.out_name) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by @@ -1668,7 +1670,7 @@ let prove_principle_for_gen in let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in let predicates_names = - List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.predicates + List.map (get_name %> Nameops.out_name) princ_info.predicates in let pte_info = { proving_tac = @@ -1684,7 +1686,7 @@ let prove_principle_for_gen is_mes acc_inv fix_id (!tcc_list@(List.map - (fun decl -> (Nameops.out_name (get_name decl))) + (get_name %> Nameops.out_name) (princ_info.args@princ_info.params) )@ ([acc_rec_arg_id])) eqs ) @@ -1713,7 +1715,7 @@ let prove_principle_for_gen (* observe_tac "instanciate_hyps_with_args" *) (instanciate_hyps_with_args make_proof - (List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.branches) + (List.map (get_name %> Nameops.out_name) princ_info.branches) (List.rev args_ids) ) gl' diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 5e72b8672..cc699e5d3 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -14,6 +14,8 @@ open Functional_principles_proofs open Misctypes open Sigma.Notations +module RelDecl = Context.Rel.Declaration + exception Toberemoved_with_rel of int*constr exception Toberemoved @@ -38,7 +40,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | Name x -> let id = Namegen.next_ident_away x avoid in Hashtbl.add tbl id x; - set_name (Name id) decl :: change_predicates_names (id::avoid) predicates + RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates | Anonymous -> anomaly (Pp.str "Anonymous property binder ")) in let avoid = (Termops.ids_of_context env_with_params ) in @@ -51,7 +53,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod (get_type decl) in + let args,_ = decompose_prod (RelDecl.get_type decl) in let real_args = if princ_type_info.indarg_in_concl then List.tl args @@ -609,7 +611,7 @@ let build_scheme fas = try Smartlocate.global_with_alias f with Not_found -> - errorlabstrm "FunInd.build_scheme" + user_err ~hdr:"FunInd.build_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in @@ -643,7 +645,7 @@ let build_case_scheme fa = let (_,f,_) = fa in try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f)) with Not_found -> - errorlabstrm "FunInd.build_case_scheme" + user_err ~hdr:"FunInd.build_case_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in let first_fun,u = destConst funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 42e490315..368b23be3 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Compat open Util open Term @@ -14,11 +15,11 @@ open Constrexpr open Indfun_common open Indfun open Genarg -open Constrarg +open Stdarg open Misctypes open Pcoq.Prim open Pcoq.Constr -open Pcoq.Tactic +open Pltac DECLARE PLUGIN "recdef_plugin" @@ -143,7 +144,7 @@ END module Gram = Pcoq.Gram module Vernac = Pcoq.Vernac_ -module Tactic = Pcoq.Tactic +module Tactic = Pltac type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 52179ae50..de2e5ea4e 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -12,6 +12,9 @@ open Util open Glob_termops open Misctypes +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + let observe strm = if do_observe () then Feedback.msg_debug strm @@ -333,19 +336,20 @@ let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> - let value = Option.map (fun x-> fst (Pretyping.understand env (Evd.from_env env) x)) raw_value in - let typ,ctx = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in - let open Context.Named.Declaration in - Environ.push_named (of_tuple (id,value,typ)) env + let typ,_ = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in + (match raw_value with + | None -> + Environ.push_named (NamedDecl.LocalAssum (id,typ)) env + | Some value -> + Environ.push_named (NamedDecl.LocalDef (id, value, typ)) env) let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = - let open Context.Rel.Declaration in observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); match pat with - | PatVar(_,na) -> Environ.push_rel (LocalAssum (na,typ)) env + | PatVar(_,na) -> Environ.push_rel (RelDecl.LocalAssum (na,typ)) env | PatCstr(_,c,patl,na) -> let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env (Evd.from_env env) typ @@ -353,7 +357,7 @@ let add_pat_variables pat typ env : Environ.env = in let constructors = Inductiveops.get_constructors env indf in let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in - let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in + let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in @@ -361,20 +365,28 @@ let add_pat_variables pat typ env : Environ.env = fst ( Context.Rel.fold_outside (fun decl (env,ctxt) -> - let _,v,t = Context.Rel.Declaration.to_tuple decl in - match Context.Rel.Declaration.get_name decl with - | Anonymous -> assert false - | Name id -> + let open Context.Rel.Declaration in + match decl with + | LocalAssum (Anonymous,_) | LocalDef (Anonymous,_,_) -> assert false + | LocalAssum (Name id, t) -> + let new_t = substl ctxt t in + observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ + str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ + str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () + ); + let open Context.Named.Declaration in + (Environ.push_named (LocalAssum (id,new_t)) env,mkVar id::ctxt) + | LocalDef (Name id, v, t) -> let new_t = substl ctxt t in - let new_v = Option.map (substl ctxt) v in + let new_v = substl ctxt v in observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ - Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ - Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) + str "old value := " ++ Printer.pr_lconstr v ++ fnl () ++ + str "new value := " ++ Printer.pr_lconstr new_v ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (of_tuple (id,new_v,new_t)) env,mkVar id::ctxt) + (Environ.push_named (LocalDef (id,new_v,new_t)) env,mkVar id::ctxt) ) (Environ.rel_context new_env) ~init:(env,[]) @@ -402,8 +414,7 @@ let rec pattern_to_term_and_type env typ = function in let constructors = Inductiveops.get_constructors env indf in let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in - let open Context.Rel.Declaration in - let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in + let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in let _,cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = @@ -602,10 +613,9 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in let new_env = - let open Context.Named.Declaration in match n with Anonymous -> env - | Name id -> Environ.push_named (of_tuple (id,Some v_as_constr,v_type)) env + | Name id -> Environ.push_named (NamedDecl.LocalDef (id,v_as_constr,v_type)) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_letin n) v_res b_res @@ -621,7 +631,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ + user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in @@ -653,7 +663,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ + user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in @@ -976,8 +986,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (fun acc var_as_constr arg -> if isRel var_as_constr then - let open Context.Rel.Declaration in - let na = get_name (Environ.lookup_rel (destRel var_as_constr) env) in + let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in match na with | Anonymous -> acc | Name id' -> @@ -1189,7 +1198,7 @@ let rec compute_cst_params relnames params = function | GSort _ -> params | GHole _ -> params | GIf _ | GRec _ | GCast _ -> - raise (UserError("compute_cst_params", str "Not handled case")) + raise (UserError(Some "compute_cst_params", str "Not handled case")) and compute_cst_params_from_app acc (params,rtl) = match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 01e5ef7fb..4e561fc7e 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -406,7 +406,7 @@ let is_free_in id = | GIf(_,cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 - | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GRec _ -> raise (UserError(None,str "Not handled GRec")) | GSort _ -> false | GHole _ -> false | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t @@ -502,7 +502,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern lhs, replace_var_by_pattern rhs ) - | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GRec _ -> raise (UserError(None,str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> @@ -655,7 +655,7 @@ let zeta_normalize = zeta_normalize_term lhs, zeta_normalize_term rhs ) - | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GRec _ -> raise (UserError(None,str "Not handled GRec")) | GSort _ -> rt | GHole _ -> rt | GCast(loc,b,c) -> diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 18817f504..99b04898b 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,4 +1,3 @@ -open Context.Rel.Declaration open CErrors open Util open Names @@ -13,11 +12,13 @@ open Misctypes open Decl_kinds open Sigma.Notations +module RelDecl = Context.Rel.Declaration + let is_rec_info scheme_info = let test_branche min acc decl = acc || ( let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (get_type decl))) in + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (RelDecl.get_type decl))) in let free_rels_in_br = Termops.free_rels new_branche in let max = min + scheme_info.Tactics.npredicates in Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br @@ -42,7 +43,7 @@ let functional_induction with_clean c princl pat = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' with Not_found -> - errorlabstrm "" (str "Cannot find induction information on "++ + user_err (str "Cannot find induction information on "++ Printer.pr_lconstr (mkConst c') ) in match Tacticals.elimination_sort_of_goal g with @@ -70,11 +71,11 @@ let functional_induction with_clean c princl pat = (b,a) (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) with Not_found -> (* This one is neither defined ! *) - errorlabstrm "" (str "Cannot find induction principle for " + user_err (str "Cannot find induction principle for " ++Printer.pr_lconstr (mkConst c') ) in (princ,NoBindings, Tacmach.pf_unsafe_type_of g' princ,g') - | _ -> raise (UserError("",str "functional induction must be used with a function" )) + | _ -> raise (UserError(None,str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> princ,binding,Tacmach.pf_unsafe_type_of g princ,g @@ -175,7 +176,7 @@ let build_newrecursive l = match body_opt with | Some body -> (fixna,bll,ar,body) - | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") + | None -> user_err ~hdr:"Function" (str "Body of Function must be given") ) l in build_newrecursive l' @@ -321,7 +322,7 @@ let error_error names e = in match e with | Building_graph e -> - errorlabstrm "" + user_err (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) @@ -391,7 +392,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [(((_,fname),pl),_,bl,ret_type,body),_] when not is_rec -> - let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in Command.do_definition fname (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl @@ -630,7 +631,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook pconstants = @@ -656,7 +657,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let fixpoint_exprl = [fixpoint_expr] in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in - let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) @@ -834,9 +835,9 @@ let make_graph (f_ref:global_reference) = | ConstRef c -> begin try c,Global.lookup_constant c with Not_found -> - raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) + raise (UserError (None,str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) end - | _ -> raise (UserError ("", str "Not a function reference") ) + | _ -> raise (UserError (None, str "Not a function reference") ) in (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom !" diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index f56e92414..a45effb16 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -49,7 +49,7 @@ let locate_constant ref = let locate_with_msg msg f x = try f x - with Not_found -> raise (CErrors.UserError("", msg)) + with Not_found -> raise (CErrors.UserError(None, msg)) let filter_map filter f = @@ -73,7 +73,7 @@ let chop_rlambda_n = | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b | _ -> - raise (CErrors.UserError("chop_rlambda_n", + raise (CErrors.UserError(Some "chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) in chop_lambda_n [] @@ -85,7 +85,7 @@ let chop_rprod_n = else match rt with | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> raise (CErrors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) + | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] @@ -110,7 +110,7 @@ let const_of_id id = in try Constrintern.locate_reference princ_ref with Not_found -> - CErrors.errorlabstrm "IndFun.const_of_id" + CErrors.user_err ~hdr:"IndFun.const_of_id" (str "cannot find " ++ Nameops.pr_id id) let def_of_const t = diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 26fc88a60..70333b063 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open Tacexpr open Declarations open CErrors @@ -23,6 +24,8 @@ open Misctypes open Termops open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (* Some pretty printing function for debugging purpose *) let pr_binding prc = @@ -137,7 +140,7 @@ let generate_type evd g_to_f f graph i = let fun_ctxt,res_type = match ctxt with | [] | [_] -> anomaly (Pp.str "Not a valid context") - | decl :: fun_ctxt -> fun_ctxt, get_type decl + | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl in let rec args_from_decl i accu = function | [] -> accu @@ -148,7 +151,7 @@ let generate_type evd g_to_f f graph i = args_from_decl (succ i) (t :: accu) l in (*i We need to name the vars [res] and [fv] i*) - let filter = fun decl -> match get_name decl with + let filter = fun decl -> match RelDecl.get_name decl with | Name id -> Some id | Anonymous -> None in @@ -269,7 +272,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (fun decl -> List.map (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (get_type decl))))) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (RelDecl.get_type decl))))) ) branches in @@ -399,7 +402,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes | hres::res::decl::ctxt -> let res = Termops.it_mkLambda_or_LetIn (Termops.it_mkProd_or_LetIn concl [hres;res]) - (LocalAssum (get_name decl, get_type decl) :: ctxt) + (LocalAssum (RelDecl.get_name decl, RelDecl.get_type decl) :: ctxt) in res ) @@ -415,7 +418,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let params_bindings,avoid = List.fold_left2 (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.out_name (RelDecl.get_name decl)) avoid in p::bindings,id::avoid ) ([],pf_ids_of_hyps g) @@ -425,7 +428,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let lemmas_bindings = List.rev (fst (List.fold_left2 (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.out_name (RelDecl.get_name decl)) avoid in (nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates @@ -682,7 +685,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (fun decl -> List.map (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (nb_prod (get_type decl))) + (generate_fresh_id (Id.of_string "y") ids (nb_prod (RelDecl.get_type decl))) ) branches in @@ -998,7 +1001,7 @@ let invfun qhyp f = let f = match f with | ConstRef f -> f - | _ -> raise (CErrors.UserError("",str "Not a function")) + | _ -> raise (CErrors.UserError(None,str "Not a function")) in try let finfos = find_Function_infos f in @@ -1043,19 +1046,19 @@ let invfun qhyp f g = functional_inversion kn hid f2 f_correct g with | Failure "" -> - errorlabstrm "" (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") + user_err (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") | Option.IsNone -> if do_observe () then error "Cannot use equivalence with graph for any side of the equality" - else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) | Not_found -> if do_observe () then error "No graph found for any side of equality" - else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) end - | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") + | _ -> user_err (Ppconstr.pr_id hid ++ str " must be an equality ") end) qhyp end diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index de4210af5..19c2ed417 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -26,6 +26,8 @@ open Glob_termops open Decl_kinds open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (** {1 Utilities} *) (** {2 Useful operations on constr and glob_constr} *) @@ -57,8 +59,8 @@ let understand = Pretyping.understand (Global.env()) Evd.empty let id_of_name = function Anonymous -> Id.of_string "H" | Name id -> id;; -let name_of_string str = Name (Id.of_string str) -let string_of_name nme = Id.to_string (id_of_name nme) +let name_of_string = Id.of_string %> Name.mk_name +let string_of_name = id_of_name %> Id.to_string (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) let isVarf f x = @@ -79,7 +81,7 @@ let ident_global_exist id = global env) with base [id]. *) let next_ident_fresh (id:Id.t) = let res = ref id in - while ident_global_exist !res do res := Nameops.lift_subscript !res done; + while ident_global_exist !res do res := Nameops.increment_subscript !res done; !res @@ -137,7 +139,7 @@ let showind (id:Id.t) = let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in List.iter (fun decl -> print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":"); - prconstr (get_type decl); print_string "\n") + prconstr (RelDecl.get_type decl); print_string "\n") ib1.mind_arity_ctxt; Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1); Array.iteri @@ -460,12 +462,12 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in let _ = prstr "\notherprms1:\n" in let _ = - List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); - prconstr (get_type decl); prstr "\n") + List.iter (fun decl -> prstr (string_of_name (RelDecl.get_name decl) ^ " : "); + prconstr (RelDecl.get_type decl); prstr "\n") otherprms1 in let _ = prstr "\notherprms2:\n" in let _ = - List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); prconstr (get_type decl); prstr "\n") + List.iter (fun decl -> prstr (string_of_name (RelDecl.get_name decl) ^ " : "); prconstr (RelDecl.get_type decl); prstr "\n") otherprms2 in { ident=id; @@ -827,7 +829,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = List.fold_left (fun (acc,env) decl -> let nm = Context.Rel.Declaration.get_name decl in - let c = get_type decl in + let c = RelDecl.get_type decl in let typ = Constrextern.extern_constr false env Evd.empty c in let newenv = Environ.push_rel (LocalAssum (nm,c)) env in CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv) @@ -901,7 +903,7 @@ let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = locate_constant f_ref in try find_Function_infos (kn_of_id id) with Not_found -> - errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme") + user_err ~hdr:"indfun" (Nameops.pr_id id ++ str " has no functional scheme") (** [merge id1 id2 args1 args2 id] builds and declares a new inductive type called [id], representing the merged graphs of both graphs diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index fa84e4ddf..e00fa528a 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -78,8 +78,10 @@ let def_of_const t = let type_of_const t = match (kind_of_term t) with - Const sp -> Typeops.type_of_constant (Global.env()) sp - |_ -> assert false + | Const sp -> + (* FIXME discarding universe constraints *) + Typeops.type_of_constant_in (Global.env()) sp + |_ -> assert false let constr_of_global x = fst (Universes.unsafe_constr_of_global x) @@ -307,7 +309,7 @@ let check_not_nested forbidden e = | Rel _ -> () | Var x -> if Id.List.mem x forbidden - then errorlabstrm "Recdef.check_not_nested" + then user_err ~hdr:"Recdef.check_not_nested" (str "check_not_nested: failure " ++ pr_id x) | Meta _ | Evar _ | Sort _ -> () | Cast(e,_,t) -> check_not_nested e;check_not_nested t @@ -327,7 +329,7 @@ let check_not_nested forbidden e = try check_not_nested e with UserError(_,p) -> - errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) + user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = @@ -377,7 +379,7 @@ type journey_info = let rec add_vars forbidden e = match kind_of_term e with | Var x -> x::forbidden - | _ -> fold_constr add_vars forbidden e + | _ -> Term.fold_constr add_vars forbidden e let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = @@ -442,7 +444,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info with e when CErrors.noncritical e -> - errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Lambda(n,t,b) -> begin @@ -450,7 +452,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info with e when CErrors.noncritical e -> - errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Case(ci,t,a,l) -> begin @@ -478,7 +480,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo expr_info.is_main_branch new_continuation_tac new_infos - | Case _ -> errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") + | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_lconstr expr_info.info) end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} @@ -723,8 +725,8 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) )) with - | UserError("Refiner.thensn_tac3",_) - | UserError("Refiner.tclFAIL_s",_) -> + | UserError(Some "Refiner.thensn_tac3",_) + | UserError(Some "Refiner.tclFAIL_s",_) -> (observe_tac (str "is computable " ++ Printer.pr_lconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) )) g @@ -1422,7 +1424,7 @@ let start_equation (f:global_reference) (term_f:global_reference) (cont_tactic:Id.t list -> tactic) g = let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_global term_f in - let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in + let nargs = nb_prod (type_of_const terminate_constr) in let x = n_x_id ids nargs in observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ h_intros x; @@ -1538,7 +1540,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num begin if do_observe () then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) - else CErrors.errorlabstrm "Cannot create equation Lemma" + else CErrors.user_err ~hdr:"Cannot create equation Lemma" (str "Cannot create equation lemma." ++ spc () ++ str "This may be because the function is nested-recursive.") ; diff --git a/plugins/funind/vo.itarget b/plugins/funind/vo.itarget index a17a5ec12..33c968302 100644 --- a/plugins/funind/vo.itarget +++ b/plugins/funind/vo.itarget @@ -1,2 +1 @@ -FunInd.vo Recdef.vo diff --git a/ltac/tauto.mli b/plugins/ltac/Ltac.v index e69de29bb..e69de29bb 100644 --- a/ltac/tauto.mli +++ b/plugins/ltac/Ltac.v diff --git a/plugins/ltac/LtacDummy.v b/plugins/ltac/LtacDummy.v deleted file mode 100644 index 4f96bbaeb..000000000 --- a/plugins/ltac/LtacDummy.v +++ /dev/null @@ -1,2 +0,0 @@ -(* The sole reason of this file is to trick coq's build system to build the dummy ltac plugin *) -Declare ML Module "ltac_plugin". diff --git a/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 index 618666758..28ff6df83 100644 --- a/ltac/coretactics.ml4 +++ b/plugins/ltac/coretactics.ml4 @@ -13,7 +13,7 @@ open Names open Locus open Misctypes open Genredexpr -open Constrarg +open Stdarg open Extraargs open Sigma.Notations diff --git a/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index 30aeba3bb..c5b26e6d5 100644 --- a/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -18,6 +18,8 @@ open Sigma.Notations open Proofview.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + (* The instantiate tactic *) let instantiate_evar evk (ist,rawc) sigma = @@ -48,7 +50,7 @@ let instantiate_tac n c ido = | _ -> error "Please be more specific: in type or value?") | InHypTypeOnly -> - evar_list (get_type decl) + evar_list (NamedDecl.get_type decl) | InHypValueOnly -> (match decl with | LocalDef (_,body,_) -> evar_list body diff --git a/ltac/evar_tactics.mli b/plugins/ltac/evar_tactics.mli index e67540c05..e67540c05 100644 --- a/ltac/evar_tactics.mli +++ b/plugins/ltac/evar_tactics.mli diff --git a/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 index 0db1cd7ba..53b726432 100644 --- a/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.ml4 @@ -11,7 +11,7 @@ open Pp open Genarg open Stdarg -open Constrarg +open Tacarg open Pcoq.Prim open Pcoq.Constr open Names @@ -31,15 +31,15 @@ let create_generic_quotation name e wit = let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string -let () = create_generic_quotation "ident" Pcoq.Prim.ident Constrarg.wit_ident -let () = create_generic_quotation "reference" Pcoq.Prim.reference Constrarg.wit_ref -let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Constrarg.wit_uconstr -let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Constrarg.wit_constr -let () = create_generic_quotation "ipattern" Pcoq.Tactic.simple_intropattern Constrarg.wit_intro_pattern -let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Constrarg.wit_open_constr +let () = create_generic_quotation "ident" Pcoq.Prim.ident Stdarg.wit_ident +let () = create_generic_quotation "reference" Pcoq.Prim.reference Stdarg.wit_ref +let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Stdarg.wit_uconstr +let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Stdarg.wit_constr +let () = create_generic_quotation "ipattern" Pltac.simple_intropattern Stdarg.wit_intro_pattern +let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Stdarg.wit_open_constr let () = let inject (loc, v) = Tacexpr.Tacexp v in - Tacentries.create_ltac_quotation "ltac" inject (Pcoq.Tactic.tactic_expr, Some 5) + Tacentries.create_ltac_quotation "ltac" inject (Pltac.tactic_expr, Some 5) (** Backward-compatible tactic notation entry names *) @@ -262,7 +262,7 @@ let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl -let in_clause' = Pcoq.Tactic.in_clause +let in_clause' = Pltac.in_clause ARGUMENT EXTEND in_clause TYPED AS clause_dft_concl diff --git a/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index b12187e18..b12187e18 100644 --- a/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli diff --git a/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index d88bcd7eb..1223f6eb4 100644 --- a/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -11,10 +11,10 @@ open Pp open Genarg open Stdarg -open Constrarg +open Tacarg open Extraargs open Pcoq.Prim -open Pcoq.Tactic +open Pltac open Mod_subst open Names open Tacexpr @@ -27,7 +27,6 @@ open Equality open Misctypes open Sigma.Notations open Proofview.Notations -open Constrarg DECLARE PLUGIN "extratactics" @@ -53,7 +52,7 @@ let replace_in_clause_maybe_by ist c1 c2 cl tac = let replace_term ist dir_opt c cl = with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) -let clause = Pcoq.Tactic.clause_dft_concl +let clause = Pltac.clause_dft_concl TACTIC EXTEND replace ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] @@ -320,7 +319,8 @@ let project_hint pri l2r r = (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) let add_hints_iff l2r lc n bl = - Hints.add_hints true bl + let l = Locality.LocalityFixme.consume () in + Hints.add_hints (Locality.make_module_locality l) bl (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc)) VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF @@ -1005,7 +1005,7 @@ let pr_cmp' _prc _prlc _prt = pr_cmp let pr_test_gen f (Test(c,x,y)) = Pp.(f x ++ pr_cmp c ++ f y) -let pr_test = pr_test_gen (Pptactic.pr_or_var Pp.int) +let pr_test = pr_test_gen (Pputils.pr_or_var Pp.int) let pr_test' _prc _prlc _prt = pr_test diff --git a/ltac/extratactics.mli b/plugins/ltac/extratactics.mli index 18334dafe..18334dafe 100644 --- a/ltac/extratactics.mli +++ b/plugins/ltac/extratactics.mli diff --git a/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index 6a8fa8d69..fcc2b86a9 100644 --- a/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -11,11 +11,12 @@ open Pp open Genarg open Stdarg -open Constrarg open Pcoq.Prim open Pcoq.Constr -open Pcoq.Tactic +open Pltac +open Hints open Tacexpr +open Names DECLARE PLUGIN "g_auto" @@ -149,15 +150,6 @@ TACTIC EXTEND autounfold_one [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] END -TACTIC EXTEND autounfoldify -| [ "autounfoldify" constr(x) ] -> [ - let db = match Term.kind_of_term x with - | Term.Const (c,_) -> Names.Label.to_string (Names.con_label c) - | _ -> assert false - in Eauto.autounfold ["core";db] Locusops.onConcl - ] -END - TACTIC EXTEND unify | ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] | ["unify" constr(x) constr(y) "with" preident(base) ] -> [ diff --git a/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4 index 7e26b5d18..ca9537c82 100644 --- a/ltac/g_class.ml4 +++ b/plugins/ltac/g_class.ml4 @@ -10,9 +10,10 @@ open Misctypes open Class_tactics -open Pcoq.Tactic +open Pltac open Stdarg -open Constrarg +open Tacarg +open Names DECLARE PLUGIN "g_class" diff --git a/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4 index 905653281..679aa1127 100644 --- a/ltac/g_eqdecide.ml4 +++ b/plugins/ltac/g_eqdecide.ml4 @@ -15,6 +15,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) open Eqdecide +open Names DECLARE PLUGIN "g_eqdecide" diff --git a/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index a3ca4ebc4..aab568746 100644 --- a/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -17,10 +17,13 @@ open Misctypes open Genarg open Genredexpr open Tok (* necessary for camlp4 *) +open Names open Pcoq +open Pcoq.Constr +open Pcoq.Vernac_ open Pcoq.Prim -open Pcoq.Tactic +open Pltac let fail_default_value = ArgArg 0 @@ -30,14 +33,15 @@ let arg_of_expr = function let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n -let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat -let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c +let genarg_of_ipattern pat = in_gen (rawwit Stdarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c +let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac let reference_to_id = function | Libnames.Ident (loc, id) -> (loc, id) | Libnames.Qualid (loc,_) -> - CErrors.user_err_loc (loc, "", - str "This expression should be a simple identifier.") + CErrors.user_err ~loc + (str "This expression should be a simple identifier.") let tactic_mode = Gram.entry_create "vernac:tactic_command" @@ -71,14 +75,17 @@ let test_bracket_ident = (* Tactics grammar rules *) +let hint = G_proofs.hint + let warn_deprecated_appcontext = CWarnings.create ~name:"deprecated-appcontext" ~category:"deprecated" (fun () -> strbrk "appcontext is deprecated and will be removed " ++ strbrk "in a future version") GEXTEND Gram - GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg - tactic_mode constr_may_eval constr_eval toplevel_selector; + GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint + tactic_mode constr_may_eval constr_eval toplevel_selector + operconstr; tactic_then_last: [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> @@ -220,8 +227,8 @@ GEXTEND Gram | "multimatch" -> General ] ] ; input_fun: - [ [ "_" -> None - | l = ident -> Some l ] ] + [ [ "_" -> Anonymous + | l = ident -> Name l ] ] ; let_clause: [ [ id = identref; ":="; te = tactic_expr -> @@ -286,15 +293,15 @@ GEXTEND Gram (* Definitions for tactics *) tacdef_body: [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> - if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) + if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) else let id = reference_to_id name in - Vernacexpr.TacticDefinition (id, TacFun (it, body)) + Tacexpr.TacticDefinition (id, TacFun (it, body)) | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - if redef then Vernacexpr.TacticRedefinition (name, body) + if redef then Tacexpr.TacticRedefinition (name, body) else let id = reference_to_id name in - Vernacexpr.TacticDefinition (id, body) + Tacexpr.TacticDefinition (id, body) ] ] ; tactic: @@ -329,9 +336,28 @@ GEXTEND Gram tactic_mode: [ [ g = OPT toplevel_selector; tac = G_vernac.subgoal_command -> tac g ] ] ; + command: + [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; + l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> + Vernacexpr.VernacProof (Some (in_tac ta), G_proofs.hint_proof_using G_vernac.section_subset_expr l) + | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; + ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] -> + Vernacexpr.VernacProof (ta,Some l) ] ] + ; + hint: + [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; + tac = Pltac.tactic -> + Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] + ; + operconstr: LEVEL "0" + [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> + let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in + CHole (!@loc, None, IntroAnonymous, Some arg) ] ] + ; END -open Constrarg +open Stdarg +open Tacarg open Vernacexpr open Vernac_classifier open Goptions @@ -474,8 +500,8 @@ let pr_tacdef_body tacdef_body = | Tacexpr.TacFun (idl,b) -> idl,b | _ -> [], body in id ++ - prlist (function None -> str " _" - | Some id -> spc () ++ Nameops.pr_id id) idl + prlist (function Anonymous -> str " _" + | Name id -> spc () ++ Nameops.pr_id id) idl ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++ Pptactic.pr_raw_tactic body diff --git a/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 index 987b9d538..d286a5870 100644 --- a/ltac/g_obligations.ml4 +++ b/plugins/ltac/g_obligations.ml4 @@ -17,7 +17,7 @@ open Libnames open Constrexpr open Constrexpr_ops open Stdarg -open Constrarg +open Tacarg open Extraargs let (set_default_tactic, get_default_tactic, print_default_tactic) = @@ -30,12 +30,23 @@ let () = end in Obligations.default_tactic := tac +let with_tac f tac = + let env = { Genintern.genv = Global.env (); ltacvars = Names.Id.Set.empty } in + let tac = match tac with + | None -> None + | Some tac -> + let tac = Genarg.in_gen (Genarg.rawwit wit_ltac) tac in + let _, tac = Genintern.generic_intern env tac in + Some tac + in + f tac + (* We define new entries for programs, with the use of this module * Subtac. These entries are named Subtac.<foo> *) module Gram = Pcoq.Gram -module Tactic = Pcoq.Tactic +module Tactic = Pltac open Pcoq @@ -66,6 +77,9 @@ GEXTEND Gram open Obligations +let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac +let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac + let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl diff --git a/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index 28078efd6..b1c4f58eb 100644 --- a/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -21,10 +21,10 @@ open Tacmach open Tacticals open Rewrite open Stdarg -open Constrarg +open Pcoq.Vernac_ open Pcoq.Prim open Pcoq.Constr -open Pcoq.Tactic +open Pltac DECLARE PLUGIN "g_rewrite" @@ -64,13 +64,13 @@ let subst_strategy s str = str let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" let pr_raw_strategy prc prlc _ (s : raw_strategy) = - let prr = Pptactic.pr_red_expr (prc, prlc, Pptactic.pr_or_by_notation Libnames.pr_reference, prc) in + let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_reference, prc) in Rewrite.pr_strategy prc prr s let pr_glob_strategy prc prlc _ (s : glob_strategy) = let prr = Pptactic.pr_red_expr (Ppconstr.pr_constr_expr, Ppconstr.pr_lconstr_expr, - Pptactic.pr_or_by_notation Libnames.pr_reference, + Pputils.pr_or_by_notation Libnames.pr_reference, Ppconstr.pr_constr_expr) in Rewrite.pr_strategy prc prr s diff --git a/parsing/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 index 3152afb28..fa01baab7 100644 --- a/parsing/g_tactic.ml4 +++ b/plugins/ltac/g_tactic.ml4 @@ -120,7 +120,7 @@ let lookup_at_as_comma = open Constr open Prim -open Tactic +open Pltac let mk_fix_tac (loc,id,bl,ann,ty) = let n = @@ -135,9 +135,9 @@ let mk_fix_tac (loc,id,bl,ann,ty) = let mk_cofix_tac (loc,id,bl,ann,ty) = let _ = Option.map (fun (aloc,_) -> - user_err_loc - (aloc,"Constr:mk_cofix_tac", - Pp.str"Annotation forbidden in cofix expression.")) ann in + user_err ~loc:aloc + ~hdr:"Constr:mk_cofix_tac" + (Pp.str"Annotation forbidden in cofix expression.")) ann in (id,CProdN(loc,bl,ty)) (* Functions overloaded by quotifier *) @@ -192,7 +192,7 @@ let merge_occurrences loc cl = function | None -> if Locusops.clause_with_generic_occurrences cl then (None, cl) else - user_err_loc (loc,"",str "Found an \"at\" clause without \"with\" clause.") + user_err ~loc (str "Found an \"at\" clause without \"with\" clause.") | Some (occs, p) -> let ans = match occs with | AllOccurrences -> cl @@ -204,9 +204,9 @@ let merge_occurrences loc cl = function { cl with onhyps = Some [(occs, id), l] } | _ -> if Locusops.clause_with_generic_occurrences cl then - user_err_loc (loc,"",str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") + user_err ~loc (str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") else - user_err_loc (loc,"",str "Cannot use clause \"at\" twice.") + user_err ~loc (str "Cannot use clause \"at\" twice.") end in (Some p, ans) @@ -217,6 +217,8 @@ let warn_deprecated_eqn_syntax = (* Auxiliary grammar rules *) +open Vernac_ + GEXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis bindings red_expr int_or_var open_constr uconstr @@ -323,8 +325,9 @@ GEXTEND Gram l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> let loc0,pat = pat in let f c pat = - let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in - IntroAction (IntroApplyOn (c,(loc,pat))) in + let loc1 = Constrexpr_ops.constr_loc c in + let loc = Loc.merge loc0 loc1 in + IntroAction (IntroApplyOn ((loc1,c),(loc,pat))) in !@loc, List.fold_right f l pat ] ] ; simple_intropattern_closed: diff --git a/plugins/ltac/ltac_dummy.ml b/plugins/ltac/ltac_dummy.ml deleted file mode 100644 index e69de29bb..000000000 --- a/plugins/ltac/ltac_dummy.ml +++ /dev/null diff --git a/plugins/ltac/ltac_dummy.mli b/plugins/ltac/ltac_dummy.mli deleted file mode 100644 index e69de29bb..000000000 --- a/plugins/ltac/ltac_dummy.mli +++ /dev/null diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index 6efb477cc..af1c7149d 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -1 +1,27 @@ -Ltac_dummy +Tacarg +Pptactic +Pltac +Taccoerce +Tacsubst +Tacenv +Tactic_debug +Tacintern +Tacentries +Profile_ltac +Tactic_matching +Tacinterp +Evar_tactics +Tactic_option +Extraargs +G_obligations +Coretactics +Extratactics +Profile_ltac_tactics +G_auto +G_class +Rewrite +G_rewrite +Tauto +G_eqdecide +G_tactic +G_ltac diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml new file mode 100644 index 000000000..1d21118ae --- /dev/null +++ b/plugins/ltac/pltac.ml @@ -0,0 +1,65 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Pcoq + +(* Main entry for extensions *) +let simple_tactic = Gram.entry_create "tactic:simple_tactic" + +let make_gen_entry _ name = Gram.entry_create ("tactic:" ^ name) + +(* Entries that can be referred via the string -> Gram.entry table *) +(* Typically for tactic user extensions *) +let open_constr = + make_gen_entry utactic "open_constr" +let constr_with_bindings = + make_gen_entry utactic "constr_with_bindings" +let bindings = + make_gen_entry utactic "bindings" +let hypident = Gram.entry_create "hypident" +let constr_may_eval = make_gen_entry utactic "constr_may_eval" +let constr_eval = make_gen_entry utactic "constr_eval" +let uconstr = + make_gen_entry utactic "uconstr" +let quantified_hypothesis = + make_gen_entry utactic "quantified_hypothesis" +let destruction_arg = make_gen_entry utactic "destruction_arg" +let int_or_var = make_gen_entry utactic "int_or_var" +let simple_intropattern = + make_gen_entry utactic "simple_intropattern" +let in_clause = make_gen_entry utactic "in_clause" +let clause_dft_concl = + make_gen_entry utactic "clause" + + +(* Main entries for ltac *) +let tactic_arg = Gram.entry_create "tactic:tactic_arg" +let tactic_expr = make_gen_entry utactic "tactic_expr" +let binder_tactic = make_gen_entry utactic "binder_tactic" + +let tactic = make_gen_entry utactic "tactic" + +(* Main entry for quotations *) +let tactic_eoi = eoi_entry tactic + +let () = + let open Stdarg in + let open Tacarg in + register_grammar wit_int_or_var (int_or_var); + register_grammar wit_intro_pattern (simple_intropattern); + register_grammar wit_quant_hyp (quantified_hypothesis); + register_grammar wit_uconstr (uconstr); + register_grammar wit_open_constr (open_constr); + register_grammar wit_constr_with_bindings (constr_with_bindings); + register_grammar wit_bindings (bindings); + register_grammar wit_tactic (tactic); + register_grammar wit_ltac (tactic); + register_grammar wit_clause_dft_concl (clause_dft_concl); + register_grammar wit_destruction_arg (destruction_arg); + () diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli new file mode 100644 index 000000000..810e1ec39 --- /dev/null +++ b/plugins/ltac/pltac.mli @@ -0,0 +1,38 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Ltac parsing entries *) + +open Loc +open Names +open Pcoq +open Libnames +open Constrexpr +open Tacexpr +open Genredexpr +open Misctypes + +val open_constr : constr_expr Gram.entry +val constr_with_bindings : constr_expr with_bindings Gram.entry +val bindings : constr_expr bindings Gram.entry +val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry +val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry +val constr_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry +val uconstr : constr_expr Gram.entry +val quantified_hypothesis : quantified_hypothesis Gram.entry +val destruction_arg : constr_expr with_bindings destruction_arg Gram.entry +val int_or_var : int or_var Gram.entry +val simple_tactic : raw_tactic_expr Gram.entry +val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry +val in_clause : Names.Id.t Loc.located Locus.clause_expr Gram.entry +val clause_dft_concl : Names.Id.t Loc.located Locus.clause_expr Gram.entry +val tactic_arg : raw_tactic_arg Gram.entry +val tactic_expr : raw_tactic_expr Gram.entry +val binder_tactic : raw_tactic_expr Gram.entry +val tactic : raw_tactic_expr Gram.entry +val tactic_eoi : raw_tactic_expr Gram.entry diff --git a/printing/pptactic.ml b/plugins/ltac/pptactic.ml index fcc30d702..dc418d530 100644 --- a/printing/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -15,16 +15,38 @@ open Constrexpr open Tacexpr open Genarg open Geninterp -open Constrarg +open Stdarg +open Tacarg open Libnames open Ppextend open Misctypes open Locus open Decl_kinds open Genredexpr +open Pputils open Ppconstr open Printer +module Tag = +struct + + let keyword = "tactic.keyword" + let primitive = "tactic.primitive" + let string = "tactic.string" + +end + +let tag t s = Pp.tag t s +let do_not_tag _ x = x +let tag_keyword = tag Tag.keyword +let tag_primitive = tag Tag.primitive +let tag_string = tag Tag.string +let tag_glob_tactic_expr = do_not_tag +let tag_glob_atomic_tactic_expr = do_not_tag +let tag_raw_tactic_expr = do_not_tag +let tag_raw_atomic_tactic_expr = do_not_tag +let tag_atomic_tactic_expr = do_not_tag + let pr_global x = Nametab.pr_global_env Id.Set.empty x type 'a grammar_tactic_prod_item_expr = @@ -62,43 +84,6 @@ type 'a extra_genarg_printer = (tolerability -> Val.t -> std_ppcmds) -> 'a -> std_ppcmds -let genarg_pprule = ref String.Map.empty - -let declare_extra_genarg_pprule wit f g h = - let s = match wit with - | ExtraArg s -> ArgT.repr s - | _ -> error - "Can declare a pretty-printing rule only for extra argument types." - in - let f prc prlc prtac x = f prc prlc prtac (out_gen (rawwit wit) x) in - let g prc prlc prtac x = g prc prlc prtac (out_gen (glbwit wit) x) in - let h prc prlc prtac x = h prc prlc prtac (out_gen (topwit wit) x) in - genarg_pprule := String.Map.add s (f,g,h) !genarg_pprule - -module Make - (Ppconstr : Ppconstrsig.Pp) - (Taggers : sig - val tag_keyword - : std_ppcmds -> std_ppcmds - val tag_primitive - : std_ppcmds -> std_ppcmds - val tag_string - : std_ppcmds -> std_ppcmds - val tag_glob_tactic_expr - : glob_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_glob_atomic_tactic_expr - : glob_atomic_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_raw_tactic_expr - : raw_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_raw_atomic_tactic_expr - : raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_atomic_tactic_expr - : atomic_tactic_expr -> std_ppcmds -> std_ppcmds - end) -= struct - - open Taggers - let keyword x = tag_keyword (str x) let primitive x = tag_primitive (str x) @@ -135,80 +120,8 @@ module Make end | _ -> default - let pr_with_occurrences pr (occs,c) = - match occs with - | AllOccurrences -> - pr c - | NoOccurrences -> - failwith "pr_with_occurrences: no occurrences" - | OnlyOccurrences nl -> - hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++ - hov 0 (prlist_with_sep spc (pr_or_var int) nl)) - | AllOccurrencesBut nl -> - hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++ - hov 0 (prlist_with_sep spc (pr_or_var int) nl)) - - exception ComplexRedFlag - - let pr_short_red_flag pr r = - if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then - raise ComplexRedFlag - else if List.is_empty r.rConst then - if r.rDelta then mt () else raise ComplexRedFlag - else (if r.rDelta then str "-" else mt ()) ++ - hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]") - - let pr_red_flag pr r = - try pr_short_red_flag pr r - with complexRedFlags -> - (if r.rBeta then pr_arg str "beta" else mt ()) ++ - (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else - (if r.rMatch then pr_arg str "match" else mt ()) ++ - (if r.rFix then pr_arg str "fix" else mt ()) ++ - (if r.rCofix then pr_arg str "cofix" else mt ())) ++ - (if r.rZeta then pr_arg str "zeta" else mt ()) ++ - (if List.is_empty r.rConst then - if r.rDelta then pr_arg str "delta" - else mt () - else - pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++ - hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) - - let pr_union pr1 pr2 = function - | Inl a -> pr1 a - | Inr b -> pr2 b - - let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) = function - | Red false -> keyword "red" - | Hnf -> keyword "hnf" - | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f) - ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o - | Cbv f -> - if f.rBeta && f.rMatch && f.rFix && f.rCofix && - f.rZeta && f.rDelta && List.is_empty f.rConst then - keyword "compute" - else - hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f) - | Lazy f -> - hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f) - | Cbn f -> - hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f) - | Unfold l -> - hov 1 (keyword "unfold" ++ spc() ++ - prlist_with_sep pr_comma (pr_with_occurrences pr_ref) l) - | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l) - | Pattern l -> - hov 1 (keyword "pattern" ++ - pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr)) l) - - | Red true -> - error "Shouldn't be accessible from user." - | ExtraRedExpr s -> - str s - | CbvVm o -> - keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o - | CbvNative o -> - keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o + let pr_with_occurrences pr c = pr_with_occurrences pr keyword c + let pr_red_expr pr c = pr_red_expr pr keyword c let pr_may_eval test prc prlc pr2 pr3 = function | ConstrEval (r,c) -> @@ -232,10 +145,6 @@ module Make let pr_arg pr x = spc () ++ pr x - let pr_or_var pr = function - | ArgArg x -> pr x - | ArgVar (_,s) -> pr_id s - let pr_and_short_name pr (c,_) = pr c let pr_or_by_notation f = function @@ -300,52 +209,6 @@ module Make let with_evars ev s = if ev then "e" ^ s else s - let hov_if_not_empty n p = if Pp.ismt p then p else hov n p - - let rec pr_raw_generic_rec prc prlc prtac prpat prref (GenArg (Rawwit wit, x)) = - match wit with - | ListArg wit -> - let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in - let ans = pr_sequence map x in - hov_if_not_empty 0 ans - | OptArg wit -> - let ans = match x with - | None -> mt () - | Some x -> pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) - in - hov_if_not_empty 0 ans - | PairArg (wit1, wit2) -> - let p, q = x in - let p = in_gen (rawwit wit1) p in - let q = in_gen (rawwit wit2) q in - hov_if_not_empty 0 (pr_sequence (pr_raw_generic_rec prc prlc prtac prpat prref) [p; q]) - | ExtraArg s -> - try pi1 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (rawwit wit) x) - with Not_found -> Genprint.generic_raw_print (in_gen (rawwit wit) x) - - - let rec pr_glb_generic_rec prc prlc prtac prpat (GenArg (Glbwit wit, x)) = - match wit with - | ListArg wit -> - let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in - let ans = pr_sequence map x in - hov_if_not_empty 0 ans - | OptArg wit -> - let ans = match x with - | None -> mt () - | Some x -> pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) - in - hov_if_not_empty 0 ans - | PairArg (wit1, wit2) -> - let p, q = x in - let p = in_gen (glbwit wit1) p in - let q = in_gen (glbwit wit2) q in - let ans = pr_sequence (pr_glb_generic_rec prc prlc prtac prpat) [p; q] in - hov_if_not_empty 0 ans - | ExtraArg s -> - try pi2 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (glbwit wit) x) - with Not_found -> Genprint.generic_glb_print (in_gen (glbwit wit) x) - let rec tacarg_using_rule_token pr_gen = function | [] -> [] | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l @@ -707,9 +570,7 @@ module Make str "=>" ++ brk (1,4) ++ pr t)) | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t - let pr_funvar = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id + let pr_funvar n = spc () ++ pr_name n let pr_let_clause k pr (id,(bl,t)) = hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++ @@ -1244,7 +1105,7 @@ module Make pr_constant = pr_or_by_notation pr_reference; pr_reference = pr_reference; pr_name = pr_lident; - pr_generic = pr_raw_generic_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference; + pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg); pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; } in @@ -1274,9 +1135,7 @@ module Make pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env)); pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); pr_name = pr_lident; - pr_generic = pr_glb_generic_rec - (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) - prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); + pr_generic = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg); pr_extend = pr_glob_extend_rec (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); @@ -1324,12 +1183,9 @@ module Make in prtac n t - let pr_raw_generic env = pr_raw_generic_rec - pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference + let pr_raw_generic = Pputils.pr_raw_generic - let pr_glb_generic env = pr_glb_generic_rec - (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) - (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) + let pr_glb_generic = Pputils.pr_glb_generic let pr_raw_extend env = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr @@ -1346,36 +1202,24 @@ module Make let pr_atomic_tactic env = pr_atomic_tactic_level env ltop -end - -module Tag = -struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["tactic"; "keyword"] - - let primitive = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["tactic"; "primitive"] - - let string = - let style = Terminal.make ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["tactic"; "string"] - -end - -include Make (Ppconstr) (struct - let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s - let do_not_tag _ x = x - let tag_keyword = tag Tag.keyword - let tag_primitive = tag Tag.primitive - let tag_string = tag Tag.string - let tag_glob_tactic_expr = do_not_tag - let tag_glob_atomic_tactic_expr = do_not_tag - let tag_raw_tactic_expr = do_not_tag - let tag_raw_atomic_tactic_expr = do_not_tag - let tag_atomic_tactic_expr = do_not_tag -end) +let declare_extra_genarg_pprule wit + (f : 'a raw_extra_genarg_printer) + (g : 'b glob_extra_genarg_printer) + (h : 'c extra_genarg_printer) = + begin match wit with + | ExtraArg s -> () + | _ -> error "Can declare a pretty-printing rule only for extra argument types." + end; + let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in + let g x = + let env = Global.env () in + g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x + in + let h x = + let env = Global.env () in + h (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) (fun _ _ -> str "<tactic>") x + in + Genprint.register_print0 wit f g h (** Registering *) @@ -1391,57 +1235,57 @@ let () = let pr_bool b = if b then str "true" else str "false" in let pr_unit _ = str "()" in let pr_string s = str "\"" ++ str s ++ str "\"" in - Genprint.register_print0 Constrarg.wit_int_or_var + Genprint.register_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int; - Genprint.register_print0 Constrarg.wit_ref + Genprint.register_print0 wit_ref pr_reference (pr_or_var (pr_located pr_global)) pr_global; - Genprint.register_print0 Constrarg.wit_ident + Genprint.register_print0 wit_ident pr_id pr_id pr_id; - Genprint.register_print0 Constrarg.wit_var + Genprint.register_print0 wit_var (pr_located pr_id) (pr_located pr_id) pr_id; Genprint.register_print0 - Constrarg.wit_intro_pattern + wit_intro_pattern (Miscprint.pr_intro_pattern pr_constr_expr) (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c)) (Miscprint.pr_intro_pattern (fun c -> pr_constr (fst (run_delayed c)))); Genprint.register_print0 - Constrarg.wit_clause_dft_concl + wit_clause_dft_concl (pr_clauses (Some true) pr_lident) (pr_clauses (Some true) pr_lident) (pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id))) ; Genprint.register_print0 - Constrarg.wit_constr + wit_constr Ppconstr.pr_constr_expr (fun (c, _) -> Printer.pr_glob_constr c) Printer.pr_constr ; Genprint.register_print0 - Constrarg.wit_uconstr + wit_uconstr Ppconstr.pr_constr_expr (fun (c,_) -> Printer.pr_glob_constr c) Printer.pr_closed_glob ; Genprint.register_print0 - Constrarg.wit_open_constr + wit_open_constr Ppconstr.pr_constr_expr (fun (c, _) -> Printer.pr_glob_constr c) Printer.pr_constr ; - Genprint.register_print0 Constrarg.wit_red_expr + Genprint.register_print0 wit_red_expr (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)) - (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) + (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_and_constr_expr pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) (pr_red_expr (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern)); - Genprint.register_print0 Constrarg.wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; - Genprint.register_print0 Constrarg.wit_bindings + Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; + Genprint.register_print0 wit_bindings (pr_bindings_no_with pr_constr_expr pr_lconstr_expr) (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) (fun it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it))); - Genprint.register_print0 Constrarg.wit_constr_with_bindings + Genprint.register_print0 wit_constr_with_bindings (pr_with_bindings pr_constr_expr pr_lconstr_expr) (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) (fun it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it))); - Genprint.register_print0 Constrarg.wit_destruction_arg + Genprint.register_print0 Tacarg.wit_destruction_arg (pr_destruction_arg pr_constr_expr pr_lconstr_expr) (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) (fun it -> pr_destruction_arg pr_constr pr_lconstr (run_delayed_destruction_arg it)); @@ -1459,21 +1303,3 @@ let () = let pr_unit _ _ _ () = str "()" in let printer _ _ prtac = prtac (0, E) in declare_extra_genarg_pprule wit_ltac printer printer pr_unit - -module Richpp = struct - - include Make (Ppconstr.Richpp) (struct - open Ppannotation - let do_not_tag _ x = x - let tag e s = Pp.tag (Pp.Tag.inj e tag) s - let tag_keyword = tag AKeyword - let tag_primitive = tag AKeyword - let tag_string = do_not_tag () - let tag_glob_tactic_expr e = tag (AGlobTacticExpr e) - let tag_glob_atomic_tactic_expr a = tag (AGlobAtomicTacticExpr a) - let tag_raw_tactic_expr e = tag (ARawTacticExpr e) - let tag_raw_atomic_tactic_expr a = tag (ARawAtomicTacticExpr a) - let tag_atomic_tactic_expr a = tag (AAtomicTacticExpr a) - end) - -end diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli new file mode 100644 index 000000000..43e22dba3 --- /dev/null +++ b/plugins/ltac/pptactic.mli @@ -0,0 +1,121 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** This module implements pretty-printers for tactic_expr syntactic + objects and their subcomponents. *) + +open Pp +open Genarg +open Geninterp +open Names +open Misctypes +open Environ +open Constrexpr +open Tacexpr +open Ppextend + +type 'a grammar_tactic_prod_item_expr = +| TacTerm of string +| TacNonTerm of Loc.t * 'a * Names.Id.t + +type 'a raw_extra_genarg_printer = + (constr_expr -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (tolerability -> raw_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a glob_extra_genarg_printer = + (glob_constr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> + (tolerability -> glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a extra_genarg_printer = + (Term.constr -> std_ppcmds) -> + (Term.constr -> std_ppcmds) -> + (tolerability -> Val.t -> std_ppcmds) -> + 'a -> std_ppcmds + +val declare_extra_genarg_pprule : + ('a, 'b, 'c) genarg_type -> + 'a raw_extra_genarg_printer -> + 'b glob_extra_genarg_printer -> + 'c extra_genarg_printer -> unit + +type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list + +type pp_tactic = { + pptac_level : int; + pptac_prods : grammar_terminals; +} + +val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit + +val pr_with_occurrences : + ('a -> std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds +val pr_red_expr : + ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> + ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds +val pr_may_eval : + ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds + +val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds +val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds + +val pr_in_clause : + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + +val pr_clauses : bool option -> + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + +val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds + +val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds + +val pr_raw_extend: env -> int -> + ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds + +val pr_glob_extend: env -> int -> + ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds + +val pr_extend : + (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds + +val pr_alias_key : Names.KerName.t -> std_ppcmds + +val pr_alias : (Val.t -> std_ppcmds) -> + int -> Names.KerName.t -> Val.t list -> std_ppcmds + +val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds + +val pr_raw_tactic : raw_tactic_expr -> std_ppcmds + +val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds + +val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds + +val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds + +val pr_hintbases : string list option -> std_ppcmds + +val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds + +val pr_bindings : + ('constr -> std_ppcmds) -> + ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds + +val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds + +val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('b, 'a) match_rule -> std_ppcmds + +val pr_value : tolerability -> Val.t -> std_ppcmds + + +val ltop : tolerability diff --git a/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 2514ededb..58123f63e 100644 --- a/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -257,7 +257,7 @@ let string_of_call ck = (Pptactic.pr_glob_tactic (Global.env ()) te) ) in - for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done; + let s = String.map (fun c -> if c = '\n' then ' ' else c) s in let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in CString.strip s diff --git a/ltac/profile_ltac.mli b/plugins/ltac/profile_ltac.mli index e5e2e4197..e5e2e4197 100644 --- a/ltac/profile_ltac.mli +++ b/plugins/ltac/profile_ltac.mli diff --git a/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.ml4 index 8cb76d81c..8cb76d81c 100644 --- a/ltac/profile_ltac_tactics.ml4 +++ b/plugins/ltac/profile_ltac_tactics.ml4 diff --git a/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 44efdd383..3c5a109c0 100644 --- a/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -36,6 +36,9 @@ open Sigma.Notations open Proofview.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration +module RelDecl = Context.Rel.Declaration + (** Typeclass-based generalized rewriting. *) (** Constants used by the tactic. *) @@ -1499,7 +1502,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul Evar.Set.fold (fun ev acc -> if not (Evd.is_defined acc ev) then - errorlabstrm "rewrite" + user_err ~hdr:"rewrite" (str "Unsolved constraint remaining: " ++ spc () ++ Evd.pr_evar_info (Evd.find acc ev)) else Evd.remove acc ev) @@ -1527,7 +1530,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul let rec insert_dependent env decl accu hyps = match hyps with | [] -> List.rev_append accu [decl] | ndecl :: rem -> - if occur_var_in_decl env (get_id ndecl) decl then + if occur_var_in_decl env (NamedDecl.get_id ndecl) decl then List.rev_append accu (decl :: hyps) else insert_dependent env decl (ndecl :: accu) rem @@ -1537,17 +1540,17 @@ let assert_replacing id newt tac = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let ctx = Environ.named_context env in - let after, before = List.split_when (Id.equal id % get_id) ctx in + let after, before = List.split_when (NamedDecl.get_id %> Id.equal id) ctx in let nc = match before with | [] -> assert false - | d :: rem -> insert_dependent env (LocalAssum (get_id d, newt)) [] after @ rem + | d :: rem -> insert_dependent env (LocalAssum (NamedDecl.get_id d, newt)) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Refine.refine ~unsafe:false { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in let map d = - let n = get_id d in + let n = NamedDecl.get_id d in if Id.equal n id then ev' else mkVar n in let (e, _) = destEvar ev in @@ -2121,9 +2124,8 @@ let setoid_proof ty fn fallback = begin try let rel, _, _ = decompose_app_rel env sigma concl in - let open Context.Rel.Declaration in let (sigma, t) = Typing.type_of env sigma rel in - let car = get_type (List.hd (fst (Reduction.dest_prod env t))) in + let car = RelDecl.get_type (List.hd (fst (Reduction.dest_prod env t))) in (try init_relation_classes () with _ -> raise Not_found); fn env sigma car rel with e -> Proofview.tclZERO e diff --git a/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 35c448351..35c448351 100644 --- a/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli diff --git a/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml new file mode 100644 index 000000000..42552c484 --- /dev/null +++ b/plugins/ltac/tacarg.ml @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Generic arguments based on Ltac. *) + +open Genarg +open Geninterp +open Tacexpr + +let make0 ?dyn name = + let wit = Genarg.make0 name in + let () = Geninterp.register_val0 wit dyn in + wit + +let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = + make0 "tactic" + +let wit_ltac = make0 ~dyn:(val_tag (topwit Stdarg.wit_unit)) "ltac" + +let wit_destruction_arg = + make0 "destruction_arg" diff --git a/plugins/ltac/tacarg.mli b/plugins/ltac/tacarg.mli new file mode 100644 index 000000000..bfa423db2 --- /dev/null +++ b/plugins/ltac/tacarg.mli @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Genarg +open Tacexpr +open Constrexpr +open Misctypes + +(** Generic arguments based on Ltac. *) + +val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Geninterp.Val.t) genarg_type + +(** [wit_ltac] is subtly different from [wit_tactic]: they only change for their + toplevel interpretation. The one of [wit_ltac] forces the tactic and + discards the result. *) +val wit_ltac : (raw_tactic_expr, glob_tactic_expr, unit) genarg_type + +val wit_destruction_arg : + (constr_expr with_bindings Tacexpr.destruction_arg, + glob_constr_and_expr with_bindings Tacexpr.destruction_arg, + delayed_open_constr_with_bindings Tacexpr.destruction_arg) genarg_type + diff --git a/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index b0a80ef73..df38a42cb 100644 --- a/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -13,7 +13,6 @@ open Pattern open Misctypes open Genarg open Stdarg -open Constrarg open Geninterp exception CannotCoerceTo of string diff --git a/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index 0b67f8726..0b67f8726 100644 --- a/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli diff --git a/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 673ac832a..cd8c9e471 100644 --- a/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -43,8 +43,8 @@ let coincide s pat off = !break let atactic n = - if n = 5 then Aentry Tactic.binder_tactic - else Aentryl (Tactic.tactic_expr, n) + if n = 5 then Aentry Pltac.binder_tactic + else Aentryl (Pltac.tactic_expr, n) type entry_name = EntryName : 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name @@ -56,9 +56,9 @@ let get_tacentry n m = && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) in - if check_lvl n then EntryName (rawwit Constrarg.wit_tactic, Aself) - else if check_lvl (n + 1) then EntryName (rawwit Constrarg.wit_tactic, Anext) - else EntryName (rawwit Constrarg.wit_tactic, atactic n) + if check_lvl n then EntryName (rawwit Tacarg.wit_tactic, Aself) + else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Anext) + else EntryName (rawwit Tacarg.wit_tactic, atactic n) let get_separator = function | None -> error "Missing separator." @@ -108,11 +108,11 @@ let interp_entry_name interp symb = let get_tactic_entry n = if Int.equal n 0 then - Tactic.simple_tactic, None + Pltac.simple_tactic, None else if Int.equal n 5 then - Tactic.binder_tactic, None + Pltac.binder_tactic, None else if 1<=n && n<5 then - Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) + Pltac.tactic_expr, Some (Extend.Level (string_of_int n)) else error ("Invalid Tactic Notation level: "^(string_of_int n)^".") @@ -163,7 +163,7 @@ let add_tactic_entry (kn, ml, tg) state = let mkact loc l = let map arg = (** HACK to handle especially the tactic(...) entry *) - let wit = Genarg.rawwit Constrarg.wit_tactic in + let wit = Genarg.rawwit Tacarg.wit_tactic in if Genarg.has_type arg wit && not ml then Tacexp (Genarg.out_gen wit arg) else @@ -218,7 +218,7 @@ let interp_prod_item = function | Some n -> (** FIXME: do better someday *) assert (String.equal s "tactic"); - begin match Constrarg.wit_tactic with + begin match Tacarg.wit_tactic with | ExtraArg tag -> ArgT.Any tag | _ -> assert false end @@ -302,9 +302,9 @@ let cons_production_parameter = function | TacTerm _ -> None | TacNonTerm (_, _, id) -> Some id -let add_glob_tactic_notation local n prods forml ids tac = +let add_glob_tactic_notation local ~level prods forml ids tac = let parule = { - tacgram_level = n; + tacgram_level = level; tacgram_prods = prods; } in let tacobj = { @@ -360,7 +360,7 @@ let extend_atomic_tactic name entries = in List.iteri add_atomic entries -let add_ml_tactic_notation name prods = +let add_ml_tactic_notation name ~level prods = let len = List.length prods in let iter i prods = let open Tacexpr in @@ -372,10 +372,12 @@ let add_ml_tactic_notation name prods = let entry = { mltac_name = name; mltac_index = len - i - 1 } in let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in let tac = TacML (Loc.ghost, entry, List.map map ids) in - add_glob_tactic_notation false 0 prods true ids tac + add_glob_tactic_notation false ~level prods true ids tac in List.iteri iter (List.rev prods); - extend_atomic_tactic name prods + (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at + tactic_expr level 0) *) + if Int.equal level 0 then extend_atomic_tactic name prods (**********************************************************************) (** Ltac quotations *) @@ -405,7 +407,7 @@ let create_ltac_quotation name cast (e, l) = in let action _ v _ _ _ loc = cast (loc, v) in let gram = (level, assoc, [Rule (rule, action)]) in - Pcoq.grammar_extend Tactic.tactic_arg None (None, [gram]) + Pcoq.grammar_extend Pltac.tactic_arg None (None, [gram]) (** Command *) @@ -425,29 +427,29 @@ let warn_unusable_identifier = let register_ltac local tacl = let map tactic_body = match tactic_body with - | TacticDefinition ((loc,id), body) -> + | Tacexpr.TacticDefinition ((loc,id), body) -> let kn = Lib.make_kn id in let id_pp = pr_id id in let () = if is_defined_tac kn then - CErrors.user_err_loc (loc, "", - str "There is already an Ltac named " ++ id_pp ++ str".") + CErrors.user_err ~loc + (str "There is already an Ltac named " ++ id_pp ++ str".") in let is_shadowed = try - match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with + match Pcoq.parse_string Pltac.tactic (Id.to_string id) with | Tacexpr.TacArg _ -> false | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) with e when CErrors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) in let () = if is_shadowed then warn_unusable_identifier id in NewTac id, body - | TacticRedefinition (ident, body) -> + | Tacexpr.TacticRedefinition (ident, body) -> let loc = loc_of_reference ident in let kn = try Nametab.locate_tactic (snd (qualid_of_reference ident)) with Not_found -> - CErrors.user_err_loc (loc, "", - str "There is no Ltac named " ++ pr_reference ident ++ str ".") + CErrors.user_err ~loc + (str "There is no Ltac named " ++ pr_reference ident ++ str ".") in UpdateTac kn, body in @@ -504,10 +506,19 @@ let print_ltacs () = | Tacexpr.TacFun (l, t) -> (l, t) | _ -> ([], body) in - let pr_ltac_fun_arg = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id - in + let pr_ltac_fun_arg n = spc () ++ pr_name n in hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) in Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) + +(** Grammar *) + +let () = + let open Metasyntax in + let entries = [ + AnyEntry Pltac.tactic_expr; + AnyEntry Pltac.binder_tactic; + AnyEntry Pltac.simple_tactic; + AnyEntry Pltac.tactic_arg; + ] in + register_grammar "tactic" entries diff --git a/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 27df819ee..069504473 100644 --- a/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -13,7 +13,7 @@ open Tacexpr (** {5 Tactic Definitions} *) -val register_ltac : locality_flag -> Vernacexpr.tacdef_body list -> unit +val register_ltac : locality_flag -> Tacexpr.tacdef_body list -> unit (** Adds new Ltac definitions to the environment. *) (** {5 Tactic Notations} *) @@ -45,7 +45,7 @@ val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type - to finding an argument by name (as in {!Genarg}) if there is none matching. *) -val add_ml_tactic_notation : ml_tactic_name -> +val add_ml_tactic_notation : ml_tactic_name -> level:int -> argument grammar_tactic_prod_item_expr list list -> unit (** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND ML-side macro. *) diff --git a/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index c709ab114..e3c2b4ad5 100644 --- a/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -65,7 +65,7 @@ let interp_ml_tactic { mltac_name = s; mltac_index = i } = let () = if Array.length tacs <= i then raise Not_found in tacs.(i) with Not_found -> - CErrors.errorlabstrm "" + CErrors.user_err (str "The tactic " ++ pr_tacname s ++ str " is not installed.") (***************************************************************************) diff --git a/ltac/tacenv.mli b/plugins/ltac/tacenv.mli index 94e14223a..94e14223a 100644 --- a/ltac/tacenv.mli +++ b/plugins/ltac/tacenv.mli diff --git a/intf/tacexpr.mli b/plugins/ltac/tacexpr.mli index 5b5957bef..e23992a80 100644 --- a/intf/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -32,15 +32,13 @@ type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) -type debug = Debug | Info | Off (* for trivial / auto / eauto ... *) - -type goal_selector = +type goal_selector = Vernacexpr.goal_selector = | SelectNth of int | SelectList of (int * int) list | SelectId of Id.t | SelectAll -type 'a core_destruction_arg = +type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg = | ElimOnConstr of 'a | ElimOnIdent of Id.t located | ElimOnAnonHyp of int @@ -48,7 +46,7 @@ type 'a core_destruction_arg = type 'a destruction_arg = clear_flag * 'a core_destruction_arg -type inversion_kind = +type inversion_kind = Misctypes.inversion_kind = | SimpleInversion | FullInversion | FullInversionClear @@ -79,12 +77,6 @@ type ('constr,'dconstr,'id) induction_clause_list = type 'a with_bindings_arg = clear_flag * 'a with_bindings -type multi = - | Precisely of int - | UpTo of int - | RepeatStar - | RepeatPlus - (* Type of patterns *) type 'a match_pattern = | Term of 'a @@ -117,18 +109,15 @@ type ml_tactic_entry = { (** Composite types *) -(** In globalize tactics, we need to keep the initial [constr_expr] to recompute - in the environment by the effective calls to Intro, Inversion, etc - The [constr_expr] field is [None] in TacDef though *) -type glob_constr_and_expr = Glob_term.glob_constr * constr_expr option +type glob_constr_and_expr = Tactypes.glob_constr_and_expr type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr -type binding_bound_vars = Id.Set.t +type binding_bound_vars = Constr_matching.binding_bound_vars type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * constr_pattern -type 'a delayed_open = 'a Pretyping.delayed_open = +type 'a delayed_open = 'a Tactypes.delayed_open = { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open @@ -293,7 +282,7 @@ constraint 'a = < > and 'a gen_tactic_fun_ast = - Id.t option list * 'a gen_tactic_expr + Name.t list * 'a gen_tactic_expr constraint 'a = < term:'t; @@ -401,3 +390,7 @@ type ltac_call_kind = | LtacConstrInterp of Glob_term.glob_constr * Pretyping.ltac_var_map type ltac_trace = (Loc.t * ltac_call_kind) list + +type tacdef_body = + | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) + | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) diff --git a/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index c5bb0ed07..3f83f104e 100644 --- a/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -23,7 +23,8 @@ open Constrexpr open Termops open Tacexpr open Genarg -open Constrarg +open Stdarg +open Tacarg open Misctypes open Locus @@ -32,11 +33,8 @@ open Locus let dloc = Loc.ghost -let error_global_not_found_loc (loc,qid) = - error_global_not_found_loc loc qid - -let error_tactic_expected loc = - user_err_loc (loc,"",str "Tactic expected.") +let error_tactic_expected ?loc = + user_err ?loc (str "Tactic expected.") (** Generic arguments *) @@ -85,7 +83,7 @@ let intern_hyp ist (loc,id as locid) = else if find_ident id ist then (dloc,id) else - Pretype_errors.error_var_not_found_loc loc id + Pretype_errors.error_var_not_found ~loc id let intern_or_var f ist = function | ArgVar locid -> ArgVar (intern_hyp ist locid) @@ -99,7 +97,7 @@ let intern_global_reference ist = function | r -> let loc,_ as lqid = qualid_of_reference r in try ArgArg (loc,locate_global_with_alias lqid) - with Not_found -> error_global_not_found_loc lqid + with Not_found -> error_global_not_found (snd lqid) let intern_ltac_variable ist = function | Ident (loc,id) -> @@ -143,7 +141,7 @@ let intern_isolated_tactic_reference strict ist r = try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) with Not_found -> (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) + error_global_not_found (snd (qualid_of_reference r)) (* Internalize an applied tactic reference *) @@ -159,7 +157,7 @@ let intern_applied_tactic_reference ist r = try intern_applied_global_tactic_reference r with Not_found -> (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) + error_global_not_found (snd (qualid_of_reference r)) (* Intern a reference parsed in a non-tactic entry *) @@ -180,7 +178,7 @@ let intern_non_tactic_reference strict ist r = TacGeneric ipat | _ -> (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) + error_global_not_found (snd (qualid_of_reference r)) let intern_message_token ist = function | (MsgString _ | MsgInt _ as x) -> x @@ -250,8 +248,8 @@ and intern_intro_pattern_action lf ist = function | IntroInjection l -> IntroInjection (List.map (intern_intro_pattern lf ist) l) | IntroWildcard | IntroRewrite _ as x -> x - | IntroApplyOn (c,pat) -> - IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat) + | IntroApplyOn ((loc,c),pat) -> + IntroApplyOn ((loc,intern_constr ist c), intern_intro_pattern lf ist pat) and intern_or_and_intro_pattern lf ist = function | IntroAndPattern l -> @@ -291,7 +289,7 @@ let intern_evaluable_global_reference ist r = with Not_found -> match r with | Ident (loc,id) when not !strict_check -> EvalVarRef id - | _ -> error_global_not_found_loc lqid + | _ -> error_global_not_found (snd lqid) let intern_evaluable_reference_or_by_notation ist = function | AN r -> intern_evaluable_global_reference ist r @@ -463,8 +461,8 @@ let rec intern_match_goal_hyps ist ?(as_type=false) lfun = function (* Utilities *) let extract_let_names lrc = let fold accu ((loc, name), _) = - if Id.Set.mem name accu then user_err_loc - (loc, "glob_tactic", str "This variable is bound several times.") + if Id.Set.mem name accu then user_err ~loc + ~hdr:"glob_tactic" (str "This variable is bound several times.") else Id.Set.add name accu in List.fold_left fold Id.Set.empty lrc @@ -641,14 +639,14 @@ and intern_tactic_as_arg loc onlytac ist a = | TacGeneric _ as a -> TacArg (loc,a) | Tacexp a -> a | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> - if onlytac then error_tactic_expected loc else TacArg (loc,a) + if onlytac then error_tactic_expected ~loc else TacArg (loc,a) and intern_tactic_or_tacarg ist = intern_tactic false ist and intern_pure_tactic ist = intern_tactic true ist and intern_tactic_fun ist (var,body) = - let lfun = List.fold_left opt_cons ist.ltacvars var in + let lfun = List.fold_left name_cons ist.ltacvars var in (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body) and intern_tacarg strict onlytac ist = function @@ -724,9 +722,7 @@ let split_ltac_fun = function | TacFun (l,t) -> (l,t) | t -> ([],t) -let pr_ltac_fun_arg = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id +let pr_ltac_fun_arg n = spc () ++ pr_name n let print_ltac id = try @@ -751,7 +747,7 @@ let print_ltac id = ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined with Not_found -> - errorlabstrm "print_ltac" + user_err ~hdr:"print_ltac" (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") (** Registering *) @@ -778,13 +774,17 @@ let intern_ident' ist id = let lf = ref Id.Set.empty in (ist, intern_ident lf ist id) +let intern_ltac ist tac = + Flags.with_option strict_check (fun () -> intern_pure_tactic ist tac) () + let () = Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); Genintern.register_intern0 wit_ref (lift intern_global_reference); + Genintern.register_intern0 wit_pre_ident (fun ist c -> (ist,c)); Genintern.register_intern0 wit_ident intern_ident'; Genintern.register_intern0 wit_var (lift intern_hyp); Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); - Genintern.register_intern0 wit_ltac (lift intern_tactic_or_tacarg); + Genintern.register_intern0 wit_ltac (lift intern_ltac); Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c)); Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); @@ -795,15 +795,17 @@ let () = Genintern.register_intern0 wit_destruction_arg (lift intern_destruction_arg); () -(***************************************************************************) -(* Backwarding recursive needs of tactic glob/interp/eval functions *) +(** Substitution for notations containing tactic-in-terms *) -let _ = - let f l = - let ltacvars = - List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l - in - Flags.with_option strict_check - (intern_pure_tactic { (make_empty_glob_sign()) with ltacvars }) +let notation_subst bindings tac = + let fold id c accu = + let loc = Glob_ops.loc_of_glob_constr (fst c) in + let c = ConstrMayEval (ConstrTerm c) in + ((loc, id), c) :: accu in - Hook.set Hints.extern_intern_tac f + let bindings = Id.Map.fold fold bindings [] in + (** This is theoretically not correct due to potential variable capture, but + Ltac has no true variables so one cannot simply substitute *) + TacLetIn (false, bindings, tac) + +let () = Genintern.register_ntn_subst0 wit_tactic notation_subst diff --git a/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index 71ca354fa..71ca354fa 100644 --- a/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli diff --git a/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index aa45f1ccf..155cb31d8 100644 --- a/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -31,7 +31,7 @@ open Tacexpr open Genarg open Geninterp open Stdarg -open Constrarg +open Tacarg open Printer open Pretyping open Misctypes @@ -120,7 +120,7 @@ let combine_appl appl1 appl2 = (* Values for interpretation *) type tacvalue = | VFun of appl*ltac_trace * value Id.Map.t * - Id.t option list * glob_tactic_expr + Name.t list * glob_tactic_expr | VRec of value Id.Map.t ref * glob_tactic_expr let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = @@ -168,7 +168,7 @@ module Value = struct let pr_v = Pptactic.pr_value Pptactic.ltop v in let Val.Dyn (tag, _) = v in let tag = Val.pr tag in - errorlabstrm "" (str "Type error: value " ++ pr_v ++ str " is a " ++ tag + user_err (str "Type error: value " ++ pr_v ++ str " is a " ++ tag ++ str " while type " ++ Val.pr wit ++ str " was expected.") let unbox wit v ans = match ans with @@ -315,8 +315,8 @@ let append_trace trace v = (* Dynamically check that an argument is a tactic *) let coerce_to_tactic loc id v = let v = Value.normalize v in - let fail () = user_err_loc - (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") + let fail () = user_err ~loc + (str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") in let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then @@ -371,7 +371,7 @@ let debugging_exception_step ist signal_anomaly e pp = pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) let error_ltac_variable loc id env v s = - user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ + user_err ~loc (str "Ltac variable " ++ pr_id id ++ strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ strbrk "which cannot be coerced to " ++ str s ++ str".") @@ -388,8 +388,6 @@ let interp_ident ist env sigma id = try try_interp_ltac_var (coerce_var_to_ident false env) ist (Some (env,sigma)) (dloc,id) with Not_found -> id -let pf_interp_ident id gl = interp_ident id (pf_env gl) (project gl) - (* Interprets an optional identifier, bound or fresh *) let interp_name ist env sigma = function | Anonymous -> Anonymous @@ -406,8 +404,8 @@ let interp_intro_pattern_naming_var loc ist env sigma id = let interp_int ist locid = try try_interp_ltac_var coerce_to_int ist None locid with Not_found -> - user_err_loc(fst locid,"interp_int", - str "Unbound variable " ++ pr_id (snd locid) ++ str".") + user_err ~loc:(fst locid) ~hdr:"interp_int" + (str "Unbound variable " ++ pr_id (snd locid) ++ str".") let interp_int_or_var ist = function | ArgVar locid -> interp_int ist locid @@ -429,7 +427,7 @@ let interp_hyp ist env sigma (loc,id as locid) = with Not_found -> (* Then look if bound in the proof context at calling time *) if is_variable env id then id - else Loc.raise loc (Logic.RefinerError (Logic.NoSuchHyp id)) + else Loc.raise ~loc (Logic.RefinerError (Logic.NoSuchHyp id)) let interp_hyp_list_as_list ist env sigma (loc,id as x) = try coerce_to_hyp_list env (Id.Map.find id ist.lfun) @@ -451,7 +449,7 @@ let interp_reference ist env sigma = function with Not_found -> try VarRef (get_id (Environ.lookup_named id env)) - with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) + with Not_found -> error_global_not_found ~loc (qualid_of_ident id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in @@ -467,14 +465,14 @@ let interp_evaluable ist env sigma = function with Not_found -> match r with | EvalConstRef _ -> r - | _ -> error_global_not_found_loc loc (qualid_of_ident id) + | _ -> error_global_not_found ~loc (qualid_of_ident id) end | ArgArg (r,None) -> r | ArgVar (loc, id) -> try try_interp_ltac_var (coerce_to_evaluable_ref env) ist (Some (env,sigma)) (loc, id) with Not_found -> try try_interp_evaluable env (loc, id) - with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) + with Not_found -> error_global_not_found ~loc (qualid_of_ident id) (* Interprets an hypothesis name *) let interp_occurrences ist occs = @@ -522,7 +520,7 @@ let rec intropattern_ids (loc,pat) = match pat with List.flatten (List.map intropattern_ids (List.flatten ll)) | IntroAction (IntroInjection l) -> List.flatten (List.map intropattern_ids l) - | IntroAction (IntroApplyOn (c,pat)) -> intropattern_ids pat + | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids pat | IntroNaming (IntroAnonymous | IntroFresh _) | IntroAction (IntroWildcard | IntroRewrite _) | IntroForthcoming _ -> [] @@ -696,9 +694,6 @@ let interp_typed_pattern ist env sigma (_,c,_) = pattern_of_constr env sigma c (* Interprets a constr expression *) -let pf_interp_constr ist gl = - interp_constr ist (pf_env gl) (project gl) - let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = let try_expand_ltac_var sigma x = try match dest_fun x with @@ -720,10 +715,6 @@ let interp_constr_list ist env sigma c = let interp_open_constr_list = interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr -(* Interprets a type expression *) -let pf_interp_type ist env sigma = - interp_type ist env sigma - (* Interprets a reduction expression *) let interp_unfold ist env sigma (occs,qid) = (interp_occurrences ist occs,interp_evaluable ist env sigma qid) @@ -748,7 +739,7 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = Inr (pattern_of_constr env sigma c) in (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) with Not_found -> - error_global_not_found_loc loc (qualid_of_ident id)) + error_global_not_found ~loc (qualid_of_ident id)) | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p @@ -804,8 +795,8 @@ let interp_may_eval f ist env sigma = function !evdref , c with | Not_found -> - user_err_loc (loc, "interp_may_eval", - str "Unbound context identifier" ++ pr_id s ++ str".")) + user_err ~loc ~hdr:"interp_may_eval" + (str "Unbound context identifier" ++ pr_id s ++ str".")) | ConstrTypeOf c -> let (sigma,c_interp) = f ist env sigma c in Typing.type_of ~refresh:true env sigma c_interp @@ -922,14 +913,14 @@ and interp_intro_pattern_action ist env sigma = function | IntroInjection l -> let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in sigma, IntroInjection l - | IntroApplyOn (c,ipat) -> + | IntroApplyOn ((loc,c),ipat) -> let c = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_open_constr ist env sigma c in Sigma.Unsafe.of_pair (c, sigma) } in let sigma,ipat = interp_intro_pattern ist env sigma ipat in - sigma, IntroApplyOn (c,ipat) + sigma, IntroApplyOn ((loc,c),ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x and interp_or_and_intro_pattern ist env sigma = function @@ -957,7 +948,7 @@ let interp_or_and_intro_pattern_option ist env sigma = function (match coerce_to_intro_pattern env (Id.Map.find id ist.lfun) with | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l) | _ -> - user_err_loc (loc,"", str "Cannot coerce to a disjunctive/conjunctive pattern.")) + user_err ~loc (str "Cannot coerce to a disjunctive/conjunctive pattern.")) | Some (ArgArg (loc,l)) -> let sigma,l = interp_or_and_intro_pattern ist env sigma l in sigma, Some (loc,l) @@ -1044,8 +1035,8 @@ let interp_destruction_arg ist gl arg = } | keep,ElimOnAnonHyp n as x -> x | keep,ElimOnIdent (loc,id) -> - let error () = user_err_loc (loc, "", - strbrk "Cannot coerce " ++ pr_id id ++ + let error () = user_err ~loc + (strbrk "Cannot coerce " ++ pr_id id ++ strbrk " neither to a quantified hypothesis nor to a term.") in let try_cast_id id' = @@ -1055,7 +1046,7 @@ let interp_destruction_arg ist gl arg = (keep, ElimOnConstr { delayed = begin fun env sigma -> try Sigma.here (constr_of_id env id', NoBindings) sigma with Not_found -> - user_err_loc (loc, "interp_destruction_arg", + user_err ~loc ~hdr:"interp_destruction_arg" ( pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") end }) in @@ -1096,8 +1087,8 @@ let head_with_value (lvar,lval) = | ([],[]) -> (lacc,[],[]) | (vr::tvr,ve::tve) -> (match vr with - | None -> head_with_value_rec lacc (tvr,tve) - | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) + | Anonymous -> head_with_value_rec lacc (tvr,tve) + | Name v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) | (vr,[]) -> (lacc,vr,[]) | ([],ve) -> (lacc,[],ve) in @@ -1123,7 +1114,7 @@ let read_pattern lfun ist env sigma = function (* Reads the hypotheses of a Match Context rule *) let cons_and_check_name id l = if Id.List.mem id l then - user_err_loc (dloc,"read_match_goal_hyps", + user_err ~hdr:"read_match_goal_hyps" ( str "Hypothesis pattern-matching variable " ++ pr_id id ++ str " used twice in the same pattern.") else id::l @@ -1223,7 +1214,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with end | TacAbstract (tac,ido) -> Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT - (Option.map (pf_interp_ident ist gl) ido) (interp_tactic ist tac) + (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac) end } | TacThen (t1,t) -> Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) @@ -1431,7 +1422,14 @@ and tactic_of_value ist vle = extra = TacStore.set ist.extra f_trace []; } in let tac = name_if_glob appl (eval_tactic ist t) in Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) - | (VFun _|VRec _) -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") + | VFun (_, _, _,vars,_) -> + let numargs = List.length vars in + Tacticals.New.tclZEROMSG + (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++ + Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++ + Pp.str (String.plural numargs "variable") ++ Pp.str " " ++ + pr_enum pr_name vars ++ Pp.str ".") + | VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") else if has_type vle (topwit wit_tactic) then let tac = out_gen (topwit wit_tactic) vle in tactic_of_value ist tac @@ -1709,7 +1707,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = - let (sigma,c_interp) = pf_interp_type ist env sigma c in + let (sigma,c_interp) = interp_type ist env sigma c in sigma , (interp_ident ist env sigma id,n,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) @@ -1724,7 +1722,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = pf_env gl in let f sigma (id,c) = - let (sigma,c_interp) = pf_interp_type ist env sigma c in + let (sigma,c_interp) = interp_type ist env sigma c in sigma , (interp_ident ist env sigma id,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) @@ -1766,7 +1764,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in if Locusops.is_nowhere clp then (* We try to fully-typecheck the term *) - let (sigma,c_interp) = pf_interp_constr ist gl c in + let (sigma,c_interp) = interp_constr ist env sigma c in let let_tac b na c cl eqpat = let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in @@ -1879,7 +1877,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let (sigma, c) = interp_constr ist env sigma c in Sigma.Unsafe.of_pair (c, sigma) with e when to_catch e (* Hack *) -> - errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") + user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") end } in Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) end } @@ -1914,7 +1912,7 @@ and interp_atomic ist tac : unit Proofview.tactic = match c with | None -> sigma , None | Some c -> - let (sigma,c_interp) = pf_interp_constr ist gl c in + let (sigma,c_interp) = interp_constr ist env sigma c in sigma , Some c_interp in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in @@ -1981,7 +1979,6 @@ let interp_tac_gen lfun avoid_ids debug t = end } let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t -let _ = Proof_global.set_interp_tac interp (* Used to hide interpretation for pretty-print, now just launch tactics *) (* [global] means that [t] should be internalized outside of goals. *) @@ -2033,9 +2030,6 @@ let () = let () = declare_uniform wit_string -let () = - declare_uniform wit_pre_ident - let lift f = (); fun ist x -> Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in @@ -2063,9 +2057,13 @@ let interp_destruction_arg' ist c = Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (interp_destruction_arg ist gl c) end } +let interp_pre_ident ist env sigma s = + s |> Id.of_string |> interp_ident ist env sigma |> Id.to_string + let () = register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); register_interp0 wit_ref (lift interp_reference); + register_interp0 wit_pre_ident (lift interp_pre_ident); register_interp0 wit_ident (lift interp_ident); register_interp0 wit_var (lift interp_hyp); register_interp0 wit_intro_pattern (lifts interp_intro_pattern); @@ -2129,8 +2127,8 @@ let lift_constr_tac_to_ml_tac vars tac = let env = Proofview.Goal.env gl in let sigma = project gl in let map = function - | None -> None - | Some id -> + | Anonymous -> None + | Name id -> let c = Id.Map.find id ist.lfun in try Some (coerce_to_closed_constr env c) with CannotCoerceTo ty -> diff --git a/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index 6f64981ef..adbd1d32b 100644 --- a/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -115,7 +115,7 @@ val error_ltac_variable : Loc.t -> Id.t -> (** Transforms a constr-expecting tactic into a tactic finding its arguments in the Ltac environment according to the given names. *) -val lift_constr_tac_to_ml_tac : Id.t option list -> +val lift_constr_tac_to_ml_tac : Name.t list -> (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic val default_ist : unit -> Geninterp.interp_sign diff --git a/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index cce4382c2..fe3a9f3b2 100644 --- a/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -10,7 +10,8 @@ open Util open Tacexpr open Mod_subst open Genarg -open Constrarg +open Stdarg +open Tacarg open Misctypes open Globnames open Term @@ -50,8 +51,8 @@ let rec subst_intro_pattern subst = function | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x and subst_intro_pattern_action subst = function - | IntroApplyOn (t,pat) -> - IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat) + | IntroApplyOn ((loc,t),pat) -> + IntroApplyOn ((loc,subst_glob_constr subst t),subst_intro_pattern subst pat) | IntroOrAndPattern l -> IntroOrAndPattern (subst_intro_or_and_pattern subst l) | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l) @@ -290,6 +291,7 @@ and subst_genarg subst (GenArg (Glbwit wit, x)) = let () = Genintern.register_subst0 wit_int_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; + Genintern.register_subst0 wit_pre_ident (fun _ v -> v); Genintern.register_subst0 wit_ident (fun _ v -> v); Genintern.register_subst0 wit_var (fun _ v -> v); Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); diff --git a/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli index c1bf27257..c1bf27257 100644 --- a/ltac/tacsubst.mli +++ b/plugins/ltac/tacsubst.mli diff --git a/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 5cbddc7f6..5cbddc7f6 100644 --- a/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml diff --git a/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index 520fb41ef..520fb41ef 100644 --- a/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli diff --git a/tactics/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index 004492e78..ef45ee47e 100644 --- a/tactics/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -13,6 +13,8 @@ open Names open Tacexpr open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + (** [t] is the type of matching successes. It ultimately contains a {!Tacexpr.glob_tactic_expr} representing the left-hand side of the corresponding matching rule, a matching substitution to be @@ -103,7 +105,7 @@ let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = (merged, Id.Map.merge merge lcm lm) let matching_error = - CErrors.UserError ("tactic matching" , Pp.str "No matching clauses for match.") + CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") let imatching_error = (matching_error, Exninfo.null) @@ -280,9 +282,9 @@ module PatternMatching (E:StaticEnvironment) = struct the name of the matched hypothesis. *) let hyp_match_type hypname pat hyps = pick hyps >>= fun decl -> - let id = get_id decl in + let id = NamedDecl.get_id decl in let refresh = is_local_def decl in - pattern_match_term refresh pat (get_type decl) () <*> + pattern_match_term refresh pat (NamedDecl.get_type decl) () <*> put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> return id @@ -319,7 +321,7 @@ module PatternMatching (E:StaticEnvironment) = struct (* spiwack: alternatively it is possible to return the list with the matched hypothesis removed directly in [hyp_match]. *) - let select_matched_hyp decl = Id.equal (get_id decl) matched_hyp in + let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in let hyps = CList.remove_first select_matched_hyp hyps in hyp_pattern_list_match pats hyps lhs | [] -> return lhs diff --git a/tactics/tactic_matching.mli b/plugins/ltac/tactic_matching.mli index 090207bcc..090207bcc 100644 --- a/tactics/tactic_matching.mli +++ b/plugins/ltac/tactic_matching.mli diff --git a/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml index a5ba3b837..a5ba3b837 100644 --- a/ltac/tactic_option.ml +++ b/plugins/ltac/tactic_option.ml diff --git a/ltac/tactic_option.mli b/plugins/ltac/tactic_option.mli index ed759a76d..ed759a76d 100644 --- a/ltac/tactic_option.mli +++ b/plugins/ltac/tactic_option.mli diff --git a/ltac/tauto.ml b/plugins/ltac/tauto.ml index 756958c2f..fb05fd7d0 100644 --- a/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -259,7 +259,7 @@ let with_flags flags _ ist = let register_tauto_tactic tac name0 args = let ids = List.map (fun id -> Id.of_string id) args in - let ids = List.map (fun id -> Some id) ids in + let ids = List.map (fun id -> Name id) ids in let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in let entry = { mltac_name = name; mltac_index = 0 } in let () = Tacenv.register_ml_tactic name [| tac |] in diff --git a/plugins/extraction/Extraction.v b/plugins/ltac/tauto.mli index e69de29bb..e69de29bb 100644 --- a/plugins/extraction/Extraction.v +++ b/plugins/ltac/tauto.mli diff --git a/plugins/ltac/vo.itarget b/plugins/ltac/vo.itarget index 4eff76566..a28fb770b 100644 --- a/plugins/ltac/vo.itarget +++ b/plugins/ltac/vo.itarget @@ -1 +1 @@ -LtacDummy.vo +Ltac.vo diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 2352d78d6..30e475b71 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -18,7 +18,7 @@ Require Import Refl. Require Import Raxioms RIneq Rpow_def DiscrR. Require Import QArith. Require Import Qfield. - +Require Import Qreals. Require Setoid. (*Declare ML Module "micromega_plugin".*) @@ -38,15 +38,8 @@ Proof. exact Rplus_opp_r. Qed. -Add Ring Rring : Rsrt. Open Scope R_scope. -Lemma Rmult_neutral : forall x:R , 0 * x = 0. -Proof. - intro ; ring. -Qed. - - Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt. Proof. constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)). @@ -59,142 +52,41 @@ Proof. apply (Rlt_irrefl m) ; auto. apply Rnot_le_lt. auto with real. destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto. - intros. - rewrite <- (Rmult_neutral m). - apply (Rmult_lt_compat_r) ; auto. -Qed. - -Definition IQR := fun x : Q => (IZR (Qnum x) * / IZR (' Qden x))%R. - - -Lemma Rinv_elim : forall x y z, - y <> 0 -> (z * y = x <-> x * / y = z). -Proof. - intros. - split ; intros. - subst. - rewrite Rmult_assoc. - rewrite Rinv_r; auto. - ring. - subst. - rewrite Rmult_assoc. - rewrite (Rmult_comm (/ y)). - rewrite Rinv_r ; auto. - ring. -Qed. - -Ltac INR_nat_of_P := - match goal with - | H : context[INR (Pos.to_nat ?X)] |- _ => - revert H ; - let HH := fresh in - assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) - | |- context[INR (Pos.to_nat ?X)] => - let HH := fresh in - assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) - end. - -Ltac add_eq expr val := set (temp := expr) ; - generalize (eq_refl temp) ; - unfold temp at 1 ; generalize temp ; intro val ; clear temp. - -Ltac Rinv_elim := - match goal with - | |- context[?x * / ?y] => - let z := fresh "v" in - add_eq (x * / y) z ; - let H := fresh in intro H ; rewrite <- Rinv_elim in H - end. - -Lemma Rlt_neq : forall r , 0 < r -> r <> 0. -Proof. - red. intros. - subst. - apply (Rlt_irrefl 0 H). + now apply Rmult_lt_0_compat. Qed. +Notation IQR := Q2R (only parsing). Lemma Rinv_1 : forall x, x * / 1 = x. Proof. intro. - Rinv_elim. - subst ; ring. - apply R1_neq_R0. + rewrite Rinv_1. + apply Rmult_1_r. Qed. -Lemma Qeq_true : forall x y, - Qeq_bool x y = true -> - IQR x = IQR y. +Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y. Proof. - unfold IQR. - simpl. - intros. - apply Qeq_bool_eq in H. - unfold Qeq in H. - assert (IZR (Qnum x * ' Qden y) = IZR (Qnum y * ' Qden x))%Z. - rewrite H. reflexivity. - repeat rewrite mult_IZR in H0. - simpl in H0. - revert H0. - repeat INR_nat_of_P. intros. - apply Rinv_elim in H2 ; [| apply Rlt_neq ; auto]. - rewrite <- H2. - field. - split ; apply Rlt_neq ; auto. + now apply Qeq_eqR, Qeq_bool_eq. Qed. Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y. Proof. intros. - apply Qeq_bool_neq in H. - intro. apply H. clear H. - unfold Qeq,IQR in *. - simpl in *. - revert H0. - repeat Rinv_elim. - intros. - subst. - assert (IZR (Qnum x * ' Qden y)%Z = IZR (Qnum y * ' Qden x)%Z). - repeat rewrite mult_IZR. - simpl. - rewrite <- H0. rewrite <- H. - ring. - apply eq_IZR ; auto. - INR_nat_of_P; intros; apply Rlt_neq ; auto. - INR_nat_of_P; intros ; apply Rlt_neq ; auto. + apply Qeq_bool_neq in H. + contradict H. + now apply eqR_Qeq. Qed. - - Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y. Proof. intros. - apply Qle_bool_imp_le in H. - unfold Qle in H. - unfold IQR. - simpl in *. - apply IZR_le in H. - repeat rewrite mult_IZR in H. - simpl in H. - repeat INR_nat_of_P; intros. - assert (Hr := Rlt_neq r H). - assert (Hr0 := Rlt_neq r0 H0). - replace (IZR (Qnum x) * / r) with ((IZR (Qnum x) * r0) * (/r * /r0)). - replace (IZR (Qnum y) * / r0) with ((IZR (Qnum y) * r) * (/r * /r0)). - apply Rmult_le_compat_r ; auto. - apply Rmult_le_pos. - unfold Rle. left. apply Rinv_0_lt_compat ; auto. - unfold Rle. left. apply Rinv_0_lt_compat ; auto. - field ; intuition. - field ; intuition. + now apply Qle_Rle, Qle_bool_imp_le. Qed. - - Lemma IQR_0 : IQR 0 = 0. Proof. - compute. apply Rinv_1. + apply Rmult_0_l. Qed. Lemma IQR_1 : IQR 1 = 1. @@ -202,160 +94,6 @@ Proof. compute. apply Rinv_1. Qed. -Lemma IQR_plus : forall x y, IQR (x + y) = IQR x + IQR y. -Proof. - intros. - unfold IQR. - simpl in *. - rewrite plus_IZR in *. - rewrite mult_IZR in *. - simpl. - rewrite Pos2Nat.inj_mul. - rewrite mult_INR. - rewrite mult_IZR. - simpl. - repeat INR_nat_of_P. - intros. field. - split ; apply Rlt_neq ; auto. -Qed. - -Lemma IQR_opp : forall x, IQR (- x) = - IQR x. -Proof. - intros. - unfold IQR. - simpl. - rewrite opp_IZR. - ring. -Qed. - -Lemma IQR_minus : forall x y, IQR (x - y) = IQR x - IQR y. -Proof. - intros. - unfold Qminus. - rewrite IQR_plus. - rewrite IQR_opp. - ring. -Qed. - - -Lemma IQR_mult : forall x y, IQR (x * y) = IQR x * IQR y. -Proof. - unfold IQR ; intros. - simpl. - repeat rewrite mult_IZR. - rewrite Pos2Nat.inj_mul. - rewrite mult_INR. - repeat INR_nat_of_P. - intros. field ; split ; apply Rlt_neq ; auto. -Qed. - -Lemma IQR_inv_lt : forall x, (0 < x)%Q -> - IQR (/ x) = / IQR x. -Proof. - unfold IQR ; simpl. - intros. - unfold Qlt in H. - revert H. - simpl. - intros. - unfold Qinv. - destruct x. - destruct Qnum ; simpl in *. - exfalso. auto with zarith. - clear H. - repeat INR_nat_of_P. - intros. - assert (HH := Rlt_neq _ H). - assert (HH0 := Rlt_neq _ H0). - rewrite Rinv_mult_distr ; auto. - rewrite Rinv_involutive ; auto. - ring. - apply Rinv_0_lt_compat in H0. - apply Rlt_neq ; auto. - simpl in H. - exfalso. - rewrite Pos.mul_comm in H. - compute in H. - discriminate. -Qed. - -Lemma Qinv_opp : forall x, (- (/ x) = / ( -x))%Q. -Proof. - destruct x ; destruct Qnum ; reflexivity. -Qed. - -Lemma Qopp_involutive_strong : forall x, (- - x = x)%Q. -Proof. - intros. - destruct x. - unfold Qopp. - simpl. - rewrite Z.opp_involutive. - reflexivity. -Qed. - -Lemma Ropp_0 : forall r , - r = 0 -> r = 0. -Proof. - intros. - rewrite <- (Ropp_involutive r). - apply Ropp_eq_0_compat ; auto. -Qed. - -Lemma IQR_x_0 : forall x, IQR x = 0 -> x == 0%Q. -Proof. - destruct x ; simpl. - unfold IQR. - simpl. - INR_nat_of_P. - intros. - apply Rmult_integral in H0. - destruct H0. - apply eq_IZR_R0 in H0. - subst. - reflexivity. - exfalso. - apply Rinv_0_lt_compat in H. - rewrite <- H0 in H. - apply Rlt_irrefl in H. auto. -Qed. - - -Lemma IQR_inv_gt : forall x, (0 > x)%Q -> - IQR (/ x) = / IQR x. -Proof. - intros. - rewrite <- (Qopp_involutive_strong x). - rewrite <- Qinv_opp. - rewrite IQR_opp. - rewrite IQR_inv_lt. - repeat rewrite IQR_opp. - rewrite Ropp_inv_permute. - auto. - intro. - apply Ropp_0 in H0. - apply IQR_x_0 in H0. - rewrite H0 in H. - compute in H. discriminate. - unfold Qlt in *. - destruct x ; simpl in *. - auto with zarith. -Qed. - -Lemma IQR_inv : forall x, ~ x == 0 -> - IQR (/ x) = / IQR x. -Proof. - intros. - assert ( 0 > x \/ 0 < x)%Q. - destruct x ; unfold Qlt, Qeq in * ; simpl in *. - rewrite Z.mul_1_r in *. - destruct Qnum ; simpl in * ; intuition auto. - right. reflexivity. - left ; reflexivity. - destruct H0. - apply IQR_inv_gt ; auto. - apply IQR_inv_lt ; auto. -Qed. - Lemma IQR_inv_ext : forall x, IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x). Proof. @@ -366,18 +104,13 @@ Proof. destruct x ; simpl. unfold Qeq in H. simpl in H. - replace Qnum with 0%Z. - compute. rewrite Rinv_1. - reflexivity. - rewrite <- H. ring. + rewrite Zmult_1_r in H. + rewrite H. + apply Rmult_0_l. intros. - apply IQR_inv. - intro. - rewrite <- Qeq_bool_iff in H0. - congruence. + now apply Q2R_inv, Qeq_bool_neq. Qed. - Notation to_nat := N.to_nat. Lemma QSORaddon : @@ -391,10 +124,10 @@ Proof. constructor ; intros ; try reflexivity. apply IQR_0. apply IQR_1. - apply IQR_plus. - apply IQR_minus. - apply IQR_mult. - apply IQR_opp. + apply Q2R_plus. + apply Q2R_minus. + apply Q2R_mult. + apply Q2R_opp. apply Qeq_true ; auto. apply R_power_theory. apply Qeq_false. @@ -453,13 +186,13 @@ Proof. apply IQR_1. reflexivity. unfold IQR. simpl. rewrite Rinv_1. reflexivity. - apply IQR_plus. - apply IQR_minus. - apply IQR_mult. + apply Q2R_plus. + apply Q2R_minus. + apply Q2R_mult. rewrite <- IHc. apply IQR_inv_ext. rewrite <- IHc. - apply IQR_opp. + apply Q2R_opp. Qed. Require Import EnvRing. diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index e4b58a56f..6051cb3d3 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -364,6 +364,7 @@ struct [["Coq";"Reals" ; "Rdefinitions"]; ["Coq";"Reals" ; "Rpow_def"] ; ["Coq";"Reals" ; "Raxioms"] ; + ["Coq";"QArith"; "Qreals"] ; ] let z_modules = [["Coq";"ZArith";"BinInt"]] @@ -383,7 +384,6 @@ struct let coq_and = lazy (init_constant "and") let coq_or = lazy (init_constant "or") let coq_not = lazy (init_constant "not") - let coq_not_gl_ref = (Nametab.locate ( Libnames.qualid_of_string "Coq.Init.Logic.not")) let coq_iff = lazy (init_constant "iff") let coq_True = lazy (init_constant "True") @@ -480,7 +480,7 @@ struct let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") let coq_IZR = lazy (r_constant "IZR") - let coq_IQR = lazy (constant "IQR") + let coq_IQR = lazy (r_constant "Q2R") let coq_PEX = lazy (constant "PEX" ) diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 027f690fc..ccb6daa11 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -16,7 +16,9 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open Constrarg +open Ltac_plugin +open Stdarg +open Tacarg DECLARE PLUGIN "micromega_plugin" diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4 index 5f906a8da..635237d33 100644 --- a/plugins/nsatz/g_nsatz.ml4 +++ b/plugins/nsatz/g_nsatz.ml4 @@ -1,5 +1,3 @@ -DECLARE PLUGIN "nsatz_plugin" - (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) @@ -10,6 +8,9 @@ DECLARE PLUGIN "nsatz_plugin" (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin +open Names + DECLARE PLUGIN "nsatz_plugin" TACTIC EXTEND nsatz_compute diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index d625e3076..1afc6500b 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -30,6 +30,7 @@ open Misctypes open Proofview.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration module OmegaSolver = Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -1697,8 +1698,8 @@ let destructure_hyps = let rec loop = function | [] -> (Tacticals.New.tclTHEN nat_inject coq_omega) | decl::lit -> - let (i,_,t) = to_tuple decl in - begin try match destructurate_prop t with + let i = NamedDecl.get_id decl in + begin try match destructurate_prop (NamedDecl.get_type decl) with | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> @@ -1808,13 +1809,13 @@ let destructure_hyps = match destructurate_type (pf_nf typ) with | Kapp(Nat,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) - decl)) + (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) + decl)) (loop lit)) | Kapp(Z,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) - decl)) + (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) + decl)) (loop lit)) | _ -> loop lit end diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index 5647fbf9f..6b711a176 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -17,9 +17,10 @@ DECLARE PLUGIN "omega_plugin" +open Ltac_plugin open Names open Coq_omega -open Constrarg +open Stdarg let eval_tactic name = let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index fd87d5b7d..f2c021f59 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -8,12 +8,14 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Names open Misctypes open Tacexpr open Geninterp open Quote -open Constrarg +open Stdarg +open Tacarg DECLARE PLUGIN "quote_plugin" diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index b3ea4335f..6405c8ceb 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -183,7 +183,7 @@ type inversion_scheme = { let i_can't_do_that () = error "Quote: not a simple fixpoint" -let decomp_term c = kind_of_term (strip_outer_cast c) +let decomp_term c = kind_of_term (Termops.strip_outer_cast c) (*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ... ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 830dc54dd..9a54ad778 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -10,9 +10,10 @@ DECLARE PLUGIN "romega_plugin" +open Ltac_plugin open Names open Refl_omega -open Constrarg +open Stdarg let eval_tactic name = let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4 index d27b04834..7e58ef9a3 100644 --- a/plugins/rtauto/g_rtauto.ml4 +++ b/plugins/rtauto/g_rtauto.ml4 @@ -8,6 +8,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin + DECLARE PLUGIN "rtauto_plugin" TACTIC EXTEND rtauto diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 8b9261113..1ad4d622b 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -505,12 +505,12 @@ let pp_mapint map = pp_form obj ++ str " => " ++ pp_list (fun (i,f) -> pp_form f) l ++ cut ()) ) map; - str "{ " ++ vb 0 ++ (!pp) ++ str " }" ++ close () + str "{ " ++ hv 0 (!pp ++ str " }") let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2 let pp_gl gl= cut () ++ - str "{ " ++ vb 0 ++ + str "{ " ++ hv 0 ( begin match gl.abs with None -> str "" @@ -520,7 +520,7 @@ let pp_gl gl= cut () ++ str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++ str "arrows=" ++ pp_mapint gl.right ++ cut () ++ str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ - str "goal =" ++ pp_form gl.gl ++ str " }" ++ close () + str "goal =" ++ pp_form gl.gl ++ str " }") let pp = function diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 4ed907951..35d6768c1 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -8,6 +8,7 @@ module Search = Explore.Make(Proof_search) +open Ltac_plugin open CErrors open Util open Term @@ -263,7 +264,7 @@ let rtauto_tac gls= let _= if Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) gl != InProp - then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in + then user_err ~hdr:"rtauto" (Pp.str "goal should be in Prop") in let glf=make_form gamma gls gl in let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in let formula= @@ -282,7 +283,7 @@ let rtauto_tac gls= let prf = try project (search_fun (init_state [] formula)) with Not_found -> - errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in + user_err ~hdr:"rtauto" (Pp.str "rtauto couldn't find any proof") in let search_end_time = System.get_time () in let _ = if !verbose then begin diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v index 293722125..facd2e062 100644 --- a/plugins/setoid_ring/RealField.v +++ b/plugins/setoid_ring/RealField.v @@ -59,11 +59,12 @@ Notation Rset := (Eqsth R). Notation Rext := (Eq_ext Rplus Rmult Ropp). Lemma Rlt_0_2 : 0 < 2. +Proof. apply Rlt_trans with (0 + 1). apply Rlt_n_Sn. rewrite Rplus_comm. apply Rplus_lt_compat_l. - replace 1 with (0 + 1). + replace R1 with (0 + 1). apply Rlt_n_Sn. apply Rplus_0_l. Qed. @@ -126,9 +127,17 @@ Ltac Rpow_tac t := | _ => constr:(N.of_nat t) end. -Add Field RField : Rfield - (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). - - - +Ltac IZR_tac t := + match t with + | R0 => constr:(0%Z) + | R1 => constr:(1%Z) + | IZR ?u => + match isZcst u with + | true => u + | _ => constr:(InitialRing.NotConstant) + end + | _ => constr:(InitialRing.NotConstant) + end. +Add Field RField : Rfield + (completeness Zeq_bool_complete, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]). diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 216eb8b37..707ff79a6 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Pp open Util open Libnames @@ -15,9 +16,9 @@ open Printer open Newring_ast open Newring open Stdarg -open Constrarg +open Tacarg open Pcoq.Constr -open Pcoq.Tactic +open Pltac DECLARE PLUGIN "newring_plugin" diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 90f5f8e63..87ee66660 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open Pp open CErrors open Util @@ -79,7 +80,7 @@ let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = try String.Map.find map !protect_maps with Not_found -> - errorlabstrm"lookup_map"(str"map "++qs map++str"not found") + user_err ~hdr:"lookup_map" (str"map "++qs map++str"not found") let protect_red map env sigma c = kl (create_clos_infos all env) @@ -122,10 +123,10 @@ let closed_term_ast l = mltac_index = 0; } in let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in - TacFun([Some(Id.of_string"t")], + TacFun([Name(Id.of_string"t")], TacML(Loc.ghost,tacname, - [TacGeneric (Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); - TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l)])) + [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); + TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)])) (* let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" *) @@ -205,7 +206,7 @@ let exec_tactic env evd n f args = let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in - let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in + let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (** Evaluate the whole result *) let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in @@ -322,14 +323,16 @@ let _ = add_map "ring" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); pol_cst "Pphi_pow", - (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); + (function -1|8|9|10|13|15|17->Eval|11|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) + pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot)]) (****************************************************************************) (* Ring database *) @@ -348,13 +351,13 @@ let find_ring_structure env sigma l = let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then - errorlabstrm "ring" + user_err ~hdr:"ring" (str"arguments of ring_simplify do not have all the same type") in List.iter check cl'; (try ring_for_carrier ty with Not_found -> - errorlabstrm "ring" + user_err ~hdr:"ring" (str"cannot find a declared ring structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false @@ -722,8 +725,8 @@ let ltac_ring_structure e = let pow_tac = tacarg e.ring_pow_tac in let lemma1 = carg e.ring_lemma1 in let lemma2 = carg e.ring_lemma2 in - let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in - let posttac = tacarg (TacFun([None],e.ring_post_tac)) in + let pretac = tacarg (TacFun([Anonymous],e.ring_pre_tac)) in + let posttac = tacarg (TacFun([Anonymous],e.ring_post_tac)) in [req;sth;ext;morph;th;cst_tac;pow_tac; lemma1;lemma2;pretac;posttac] @@ -755,12 +758,14 @@ let _ = add_map "field" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); (* display_linear: evaluate polynomials and coef operations, protect field operations and make recursive call on the var map *) my_reference "display_linear", (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); my_reference "display_pow_linear", - (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot); + (function -1|9|10|11|14|16|18|19->Eval|12|17->Rec|_->Prot); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); @@ -768,19 +773,20 @@ let _ = add_map "field" (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); + pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot); (* FEeval: evaluate morphism, protect field operations and make recursive call on the var map *) - my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; + my_reference "FEeval", (function -1|10|12|15->Eval|14->Rec|_->Prot)]);; let _ = add_map "field_cond" (map_without_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); - (* PCond: evaluate morphism and denum list, protect ring + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); + (* PCond: evaluate denum list, protect ring operations and make recursive call on the var map *) - my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);; -(* (function -1|9|11->Eval|10->Rec|_->Prot)]);;*) + my_reference "PCond", (function -1|11|14->Eval|9|13->Rec|_->Prot)]);; let _ = Redexpr.declare_reduction "simpl_field_expr" @@ -828,13 +834,13 @@ let find_field_structure env sigma l = let check c = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then - errorlabstrm "field" + user_err ~hdr:"field" (str"arguments of field_simplify do not have all the same type") in List.iter check cl'; (try field_for_carrier ty with Not_found -> - errorlabstrm "field" + user_err ~hdr:"field" (str"cannot find a declared field structure over"++ spc()++str"\""++pr_constr ty++str"\"")) | [] -> assert false @@ -994,8 +1000,8 @@ let ltac_field_structure e = let field_simpl_eq_ok = carg e.field_simpl_eq_ok in let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in let cond_ok = carg e.field_cond in - let pretac = tacarg (TacFun([None],e.field_pre_tac)) in - let posttac = tacarg (TacFun([None],e.field_post_tac)) in + let pretac = tacarg (TacFun([Anonymous],e.field_pre_tac)) in + let posttac = tacarg (TacFun([Anonymous],e.field_post_tac)) in [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; field_simpl_eq_in_ok;cond_ok;pretac;posttac] diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index d21223d43..03c4ae47d 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -15,11 +15,13 @@ let frozen_lexer = CLexer.freeze () ;; (*i camlp4use: "pa_extend.cmo" i*) (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Names open Pp open Pcoq open Genarg -open Constrarg +open Stdarg +open Tacarg open Term open Vars open Topconstr @@ -41,7 +43,7 @@ open Proofview.Notations open Tacinterp open Pretyping open Constr -open Tactic +open Pltac open Extraargs open Ppconstr open Printer @@ -61,8 +63,8 @@ DECLARE PLUGIN "ssrmatching_plugin" type loc = Loc.t let dummy_loc = Loc.ghost -let errorstrm = CErrors.errorlabstrm "ssrmatching" -let loc_error loc msg = CErrors.user_err_loc (loc, msg, str msg) +let errorstrm = CErrors.user_err ~hdr:"ssrmatching" +let loc_error loc msg = CErrors.user_err ~loc ~hdr:msg (str msg) let ppnl = Feedback.msg_info (* 0 cost pp function. Active only if env variable SSRDEBUG is set *) @@ -1410,7 +1412,7 @@ let () = let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in let () = Tacenv.register_ml_tactic name [|mltac|] in let tac = - TacFun ([Some (Id.of_string "pattern")], + TacFun ([Name (Id.of_string "pattern")], TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in let obj () = Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index e18d19ced..ed8cc6ab0 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -52,8 +52,8 @@ let interp_ascii_string dloc s = if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] then int_of_string s else - user_err_loc (dloc,"interp_ascii_string", - str "Expects a single character or a three-digits ascii code.") in + user_err ~loc:dloc ~hdr:"interp_ascii_string" + (str "Expects a single character or a three-digits ascii code.") in interp_ascii dloc p let uninterp_ascii r = diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index a9eb126b4..ab262fea7 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -47,8 +47,8 @@ let nat_of_int dloc n = mk_nat ref_O n end else - user_err_loc (dloc, "nat_of_int", - str "Cannot interpret a negative number as a number of type nat") + user_err ~hdr:"nat_of_int" + (str "Cannot interpret a negative number as a number of type nat") (************************************************************************) (* Printing via scopes *) diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index f65f9b791..a25ddb062 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -100,7 +100,7 @@ let int31_of_pos_bigint dloc n = GApp (dloc, ref_construct, List.rev (args 31 n)) let error_negative dloc = - CErrors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.") + CErrors.user_err ~loc:dloc ~hdr:"interp_int31" (Pp.str "int31 are only non-negative numbers.") let interp_int31 dloc n = if is_pos_or_zero n then @@ -189,7 +189,7 @@ let bigN_of_pos_bigint dloc n = GApp (dloc, ref_constructor, args) let bigN_error_negative dloc = - CErrors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") + CErrors.user_err ~loc:dloc ~hdr:"interp_bigN" (Pp.str "bigN are only non-negative numbers.") let interp_bigN dloc n = if is_pos_or_zero n then diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 3ae2d45f3..8f065f528 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -9,6 +9,8 @@ open Util open Names open Globnames +open Glob_term +open Bigint (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "r_syntax_plugin" @@ -17,95 +19,105 @@ let () = Mltop.add_known_module __coq_plugin_name exception Non_closed_number (**********************************************************************) -(* Parsing R via scopes *) +(* Parsing positive via scopes *) (**********************************************************************) -open Glob_term -open Bigint +let binnums = ["Coq";"Numbers";"BinNums"] let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"] -let make_path dir id = Libnames.make_path dir (Id.of_string id) +let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) + +let positive_path = make_path binnums "positive" + +(* TODO: temporary hack *) +let make_kn dir id = Globnames.encode_mind dir id + +let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive") +let glob_positive = IndRef (positive_kn,0) +let path_of_xI = ((positive_kn,0),1) +let path_of_xO = ((positive_kn,0),2) +let path_of_xH = ((positive_kn,0),3) +let glob_xI = ConstructRef path_of_xI +let glob_xO = ConstructRef path_of_xO +let glob_xH = ConstructRef path_of_xH + +let pos_of_bignat dloc x = + let ref_xI = GRef (dloc, glob_xI, None) in + let ref_xH = GRef (dloc, glob_xH, None) in + let ref_xO = GRef (dloc, glob_xO, None) in + let rec pos_of x = + match div2_with_rest x with + | (q,false) -> GApp (dloc, ref_xO,[pos_of q]) + | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q]) + | (q,true) -> ref_xH + in + pos_of x + +(**********************************************************************) +(* Printing positive via scopes *) +(**********************************************************************) + +let rec bignat_of_pos = function + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) + | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one + | _ -> raise Non_closed_number + +(**********************************************************************) +(* Parsing Z via scopes *) +(**********************************************************************) +let z_path = make_path binnums "Z" +let z_kn = make_kn (make_dir binnums) (Id.of_string "Z") +let glob_z = IndRef (z_kn,0) +let path_of_ZERO = ((z_kn,0),1) +let path_of_POS = ((z_kn,0),2) +let path_of_NEG = ((z_kn,0),3) +let glob_ZERO = ConstructRef path_of_ZERO +let glob_POS = ConstructRef path_of_POS +let glob_NEG = ConstructRef path_of_NEG + +let z_of_int dloc n = + if not (Bigint.equal n zero) then + let sgn, n = + if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in + GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n]) + else + GRef (dloc, glob_ZERO, None) + +(**********************************************************************) +(* Printing Z via scopes *) +(**********************************************************************) + +let bigint_of_z = function + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) + | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero + | _ -> raise Non_closed_number + +(**********************************************************************) +(* Parsing R via scopes *) +(**********************************************************************) + +let rdefinitions = ["Coq";"Reals";"Rdefinitions"] let r_path = make_path rdefinitions "R" (* TODO: temporary hack *) let make_path dir id = Globnames.encode_con dir (Id.of_string id) -let r_kn = make_path rdefinitions "R" -let glob_R = ConstRef r_kn -let glob_R1 = ConstRef (make_path rdefinitions "R1") -let glob_R0 = ConstRef (make_path rdefinitions "R0") -let glob_Ropp = ConstRef (make_path rdefinitions "Ropp") -let glob_Rplus = ConstRef (make_path rdefinitions "Rplus") -let glob_Rmult = ConstRef (make_path rdefinitions "Rmult") - -let two = mult_2 one -let three = add_1 two -let four = mult_2 two - -(* Unary representation of strictly positive numbers *) -let rec small_r dloc n = - if equal one n then GRef (dloc, glob_R1, None) - else GApp(dloc,GRef (dloc,glob_Rplus, None), - [GRef (dloc, glob_R1, None);small_r dloc (sub_1 n)]) - -let r_of_posint dloc n = - let r1 = GRef (dloc, glob_R1, None) in - let r2 = small_r dloc two in - let rec r_of_pos n = - if less_than n four then small_r dloc n - else - let (q,r) = div2_with_rest n in - let b = GApp(dloc,GRef(dloc,glob_Rmult,None),[r2;r_of_pos q]) in - if r then GApp(dloc,GRef(dloc,glob_Rplus,None),[r1;b]) else b in - if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0,None) +let glob_IZR = ConstRef (make_path (make_dir rdefinitions) "IZR") let r_of_int dloc z = - if is_strictly_neg z then - GApp (dloc, GRef(dloc,glob_Ropp,None), [r_of_posint dloc (neg z)]) - else - r_of_posint dloc z + GApp (dloc, GRef(dloc,glob_IZR,None), [z_of_int dloc z]) (**********************************************************************) (* Printing R via scopes *) (**********************************************************************) -let bignat_of_r = -(* for numbers > 1 *) -let rec bignat_of_pos = function - (* 1+1 *) - | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)]) - when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two - (* 1+(1+1) *) - | GApp (_,GRef (_,p1,_), [GRef (_,o1,_); - GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])]) - when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus && - Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three - (* (1+1)*b *) - | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult -> - if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; - mult_2 (bignat_of_pos b) - (* 1+(1+1)*b *) - | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])]) - when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1 -> - if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; - add_1 (mult_2 (bignat_of_pos b)) - | _ -> raise Non_closed_number -in -let bignat_of_r = function - | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero - | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one - | r -> bignat_of_pos r -in -bignat_of_r - let bigint_of_r = function - | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp -> - let n = bignat_of_r a in - if Bigint.equal n zero then raise Non_closed_number; - neg n - | a -> bignat_of_r a + | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_IZR -> + bigint_of_z a + | _ -> raise Non_closed_number let uninterp_r p = try @@ -113,12 +125,9 @@ let uninterp_r p = with Non_closed_number -> None -let mkGRef gr = GRef (Loc.ghost,gr,None) - let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int - (List.map mkGRef - [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1], + ([GRef (Loc.ghost,glob_IZR,None)], uninterp_r, false) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index 60803a369..b7b5fb8a5 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -57,8 +57,8 @@ let pos_of_bignat dloc x = pos_of x let error_non_positive dloc = - user_err_loc (dloc, "interp_positive", - str "Only strictly positive numbers in type \"positive\".") + user_err ~loc:dloc ~hdr:"interp_positive" + (str "Only strictly positive numbers in type \"positive\".") let interp_positive dloc n = if is_strictly_pos n then pos_of_bignat dloc n @@ -113,7 +113,7 @@ let n_of_binnat dloc pos_or_neg n = GRef (dloc, glob_N0, None) let error_negative dloc = - user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".") + user_err ~loc:dloc ~hdr:"interp_N" (str "No negative numbers in type \"N\".") let n_of_int dloc n = if is_pos_or_zero n then n_of_binnat dloc true n diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index e18aece09..1bd03491a 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -13,6 +13,8 @@ open Term open Environ open Util open Libobject + +module NamedDecl = Context.Named.Declaration (*i*) let name_table = @@ -48,7 +50,7 @@ let discharge_rename_args = function (try let vars,_,_ = section_segment_of_reference c in let c' = pop_global_reference c in - let var_names = List.map (fun (id, _,_,_) -> Name id) vars in + let var_names = List.map (fst %> NamedDecl.get_id %> Name.mk_name) vars in let names' = var_names @ names in Some (ReqGlobal (c', names), (c', names')) with Not_found -> Some req) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index ef3e53bf1..63c2dde18 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -32,6 +32,9 @@ open Evd open Sigma.Notations open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (* Pattern-matching errors *) type pattern_matching_error = @@ -45,22 +48,22 @@ type pattern_matching_error = exception PatternMatchingError of env * evar_map * pattern_matching_error -let raise_pattern_matching_error (loc,env,sigma,te) = - Loc.raise loc (PatternMatchingError(env,sigma,te)) +let raise_pattern_matching_error ?loc (env,sigma,te) = + Loc.raise ?loc (PatternMatchingError(env,sigma,te)) -let error_bad_pattern_loc loc env sigma cstr ind = - raise_pattern_matching_error - (loc, env, sigma, BadPattern (cstr,ind)) +let error_bad_pattern ?loc env sigma cstr ind = + raise_pattern_matching_error ?loc + (env, sigma, BadPattern (cstr,ind)) -let error_bad_constructor_loc loc env cstr ind = - raise_pattern_matching_error - (loc, env, Evd.empty, BadConstructor (cstr,ind)) +let error_bad_constructor ?loc env cstr ind = + raise_pattern_matching_error ?loc + (env, Evd.empty, BadConstructor (cstr,ind)) -let error_wrong_numarg_constructor_loc loc env c n = - raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargConstructor(c,n)) +let error_wrong_numarg_constructor ?loc env c n = + raise_pattern_matching_error ?loc (env, Evd.empty, WrongNumargConstructor(c,n)) -let error_wrong_numarg_inductive_loc loc env c n = - raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargInductive(c,n)) +let error_wrong_numarg_inductive ?loc env c n = + raise_pattern_matching_error ?loc (env, Evd.empty, WrongNumargInductive(c,n)) let list_try_compile f l = let rec aux errors = function @@ -272,9 +275,9 @@ let rec find_row_ind = function let inductive_template evdref env tmloc ind = let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in let arsign = inductive_alldecls_env env indu in - let hole_source = match tmloc with - | Some loc -> fun i -> (loc, Evar_kinds.TomatchTypeParameter (ind,i)) - | None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in + let hole_source i = match tmloc with + | Some loc -> (loc, Evar_kinds.TomatchTypeParameter (ind,i)) + | None -> (Loc.ghost, Evar_kinds.TomatchTypeParameter (ind,i)) in let (_,evarl,_) = List.fold_right (fun decl (subst,evarl,n) -> @@ -481,32 +484,31 @@ let check_and_adjust_constructor env ind cstrs = function let args' = adjust_local_defs loc (args, List.rev ci.cs_args) in PatCstr (loc, cstr, args', alias) with NotAdjustable -> - error_wrong_numarg_constructor_loc loc env cstr nb_args_constr + error_wrong_numarg_constructor ~loc env cstr nb_args_constr else (* Try to insert a coercion *) try Coercion.inh_pattern_coerce_to loc env pat ind' ind with Not_found -> - error_bad_constructor_loc loc env cstr ind + error_bad_constructor ~loc env cstr ind let check_all_variables env sigma typ mat = List.iter (fun eqn -> match current_pattern eqn with | PatVar (_,id) -> () | PatCstr (loc,cstr_sp,_,_) -> - error_bad_pattern_loc loc env sigma cstr_sp typ) + error_bad_pattern ~loc env sigma cstr_sp typ) mat let check_unused_pattern env eqn = if not !(eqn.used) then - raise_pattern_matching_error - (eqn.eqn_loc, env, Evd.empty, UnusedClause eqn.patterns) + raise_pattern_matching_error ~loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns) let set_used_pattern eqn = eqn.used := true let extract_rhs pb = match pb.mat with - | [] -> errorlabstrm "build_leaf" (msg_may_need_inversion()) + | [] -> user_err ~hdr:"build_leaf" (msg_may_need_inversion()) | eqn::_ -> set_used_pattern eqn; eqn.rhs @@ -607,7 +609,7 @@ let relocate_index_tomatch n1 n2 = NonDepAlias :: genrec depth rest | Abstract (i,d) :: rest -> let i = relocate_rel n1 n2 depth i in - Abstract (i, map_constr (relocate_index n1 n2 depth) d) + Abstract (i, RelDecl.map_constr (relocate_index n1 n2 depth) d) :: genrec (depth+1) rest in genrec 0 @@ -640,7 +642,7 @@ let replace_tomatch n c = | NonDepAlias :: rest -> NonDepAlias :: replrec depth rest | Abstract (i,d) :: rest -> - Abstract (i, map_constr (replace_term n c depth) d) + Abstract (i, RelDecl.map_constr (replace_term n c depth) d) :: replrec (depth+1) rest in replrec 0 @@ -665,7 +667,7 @@ let rec liftn_tomatch_stack n depth = function NonDepAlias :: liftn_tomatch_stack n depth rest | Abstract (i,d)::rest -> let i = if i<depth then i else i+n in - Abstract (i, map_constr (liftn n depth) d) + Abstract (i, RelDecl.map_constr (liftn n depth) d) ::(liftn_tomatch_stack n (depth+1) rest) let lift_tomatch_stack n = liftn_tomatch_stack n 1 @@ -733,7 +735,7 @@ let get_names env sign eqns = (* We now replace the names y1 .. yn y by the actual names *) (* xi1 .. xin xi to be found in the i-th clause of the matrix *) -let recover_initial_subpattern_names = List.map2 set_name +let recover_initial_subpattern_names = List.map2 RelDecl.set_name let recover_and_adjust_alias_names names sign = let rec aux = function @@ -758,11 +760,11 @@ let push_rels_eqn_with_names sign eqn = push_rels_eqn sign eqn let push_generalized_decl_eqn env n decl eqn = - match get_name decl with + match RelDecl.get_name decl with | Anonymous -> push_rels_eqn [decl] eqn | Name _ -> - push_rels_eqn [set_name (get_name (Environ.lookup_rel n eqn.rhs.rhs_env)) decl] eqn + push_rels_eqn [RelDecl.set_name (RelDecl.get_name (Environ.lookup_rel n eqn.rhs.rhs_env)) decl] eqn let drop_alias_eqn eqn = { eqn with alias_stack = List.tl eqn.alias_stack } @@ -770,7 +772,7 @@ let drop_alias_eqn eqn = let push_alias_eqn alias eqn = let aliasname = List.hd eqn.alias_stack in let eqn = drop_alias_eqn eqn in - let alias = set_name aliasname alias in + let alias = RelDecl.set_name aliasname alias in push_rels_eqn [alias] eqn (**********************************************************************) @@ -1199,7 +1201,7 @@ let rec generalize_problem names pb = function | LocalDef (Anonymous,_,_) -> pb', deps | _ -> (* for better rendering *) - let d = map_type (whd_betaiota !(pb.evdref)) d in + let d = RelDecl.map_type (whd_betaiota !(pb.evdref)) d in let tomatch = lift_tomatch_stack 1 pb'.tomatch in let tomatch = relocate_index_tomatch (i+1) 1 tomatch in { pb' with @@ -1227,7 +1229,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* that had matched constructor C *) let cs_args = const_info.cs_args in let names,aliasname = get_names pb.env cs_args eqns in - let typs = List.map2 set_name names cs_args + let typs = List.map2 RelDecl.set_name names cs_args in (* We build the matrix obtained by expanding the matching on *) @@ -1277,7 +1279,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let typs' = List.map2 (fun (tm, (tmtyp,_), decl) deps -> - let na = get_name decl in + let na = RelDecl.get_name decl in let na = match curname, na with | Name _, Anonymous -> curname | Name _, Name _ -> na @@ -1309,8 +1311,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let submat = adjust_impossible_cases pb pred tomatch submat in let () = match submat with | [] -> - raise_pattern_matching_error - (Loc.ghost, pb.env, Evd.empty, NonExhaustive (complete_history history)) + raise_pattern_matching_error (pb.env, Evd.empty, NonExhaustive (complete_history history)) | _ -> () in @@ -1662,8 +1663,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = List.map (fun a -> not (isRel a) || dependent a u || Int.Set.mem (destRel a) depvl) inst in let named_filter = - let open Context.Named.Declaration in - List.map (fun d -> dependent (mkVar (get_id d)) u) + List.map (fun d -> dependent (mkVar (NamedDecl.get_id d)) u) (named_context extenv) in let filter = Filter.make (rel_filter @ named_filter) in let candidates = u :: List.map mkRel vl in @@ -1759,7 +1759,7 @@ let build_inversion_problem loc env sigma tms t = let sub_tms = List.map2 (fun deps (tm, (tmtyp,_), decl) -> - let na = if List.is_empty deps then Anonymous else force_name (get_name decl) in + let na = if List.is_empty deps then Anonymous else force_name (RelDecl.get_name decl) in Pushed (true,((tm,tmtyp),deps,na))) dep_sign decls in let subst = List.map (fun (na,t) -> (na,lift n t)) subst in @@ -1822,7 +1822,7 @@ let build_initial_predicate arsign pred = let rec buildrec n pred tmnames = function | [] -> List.rev tmnames,pred | (decl::realdecls)::lnames -> - let na = get_name decl in + let na = RelDecl.get_name decl in let n' = n + List.length realdecls in buildrec (n'+1) pred (force_name na::tmnames) lnames | _ -> assert false @@ -1838,8 +1838,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = | None -> [LocalAssum (na, lift n typ)] | Some b -> [LocalDef (na, lift n b, lift n typ)]) | Some (loc,_,_) -> - user_err_loc (loc,"", - str"Unexpected type annotation for a term of non inductive type.")) + user_err ~loc + (str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in let ((ind,u),_) = dest_ind_family indf' in @@ -1849,13 +1849,13 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = match t with | Some (loc,ind',realnal) -> if not (eq_ind ind ind') then - user_err_loc (loc,"",str "Wrong inductive type."); + user_err ~loc (str "Wrong inductive type."); if not (Int.equal nrealargs_ctxt (List.length realnal)) then anomaly (Pp.str "Ill-formed 'in' clause in cases"); List.rev realnal | None -> List.make nrealargs_ctxt Anonymous in LocalAssum (na, build_dependent_inductive env0 indf') - ::(List.map2 set_name realnal arsign) in + ::(List.map2 RelDecl.set_name realnal arsign) in let rec buildrec n = function | [],[] -> [] | (_,tm)::ltm, (_,x)::tmsign -> @@ -2048,11 +2048,11 @@ let constr_of_pat env evdref arsign pat avoid = let cind = inductive_of_constructor cstr in let IndType (indf, _) = try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty) - with Not_found -> error_case_not_inductive env + with Not_found -> error_case_not_inductive env !evdref {uj_val = ty; uj_type = Typing.unsafe_type_of env !evdref ty} in let (ind,u), params = dest_ind_family indf in - if not (eq_ind ind cind) then error_bad_constructor_loc l env cstr ind; + if not (eq_ind ind cind) then error_bad_constructor ~loc:l env cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in @@ -2060,7 +2060,7 @@ let constr_of_pat env evdref arsign pat avoid = let patargs, args, sign, env, n, m, avoid = List.fold_right2 (fun decl ua (patargs, args, sign, env, n, m, avoid) -> - let t = get_type decl in + let t = RelDecl.get_type decl in let pat', sign', arg', typ', argtypargs, n', avoid = let liftt = liftn (List.length sign) (succ (List.length args)) t in typ env (substl args liftt, []) ua avoid @@ -2100,8 +2100,8 @@ let constr_of_pat env evdref arsign pat avoid = (* Mark the equality as a hole *) pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in - let pat', sign, patc, patty, args, z, avoid = typ env (get_type (List.hd arsign), List.tl arsign) pat avoid in - pat', (sign, patc, (get_type (List.hd arsign), args), pat'), avoid + let pat', sign, patc, patty, args, z, avoid = typ env (RelDecl.get_type (List.hd arsign), List.tl arsign) pat avoid in + pat', (sign, patc, (RelDecl.get_type (List.hd arsign), args), pat'), avoid (* shadows functional version *) @@ -2132,7 +2132,7 @@ let vars_of_ctx ctx = (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), [hole; GVar (Loc.ghost, prev)])) :: vars | _ -> - match get_name decl with + match RelDecl.get_name decl with Anonymous -> invalid_arg "vars_of_ctx" | Name n -> n, GVar (Loc.ghost, n) :: vars) ctx (Id.of_string "vars_of_ctx_error", []) @@ -2309,7 +2309,7 @@ let abstract_tomatch env tomatchs tycon = let build_dependent_signature env evdref avoid tomatchs arsign = let avoid = ref avoid in let arsign = List.rev arsign in - let allnames = List.rev_map (List.map get_name) arsign in + let allnames = List.rev_map (List.map RelDecl.get_name) arsign in let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in let eqs, neqs, refls, slift, arsign' = List.fold_left2 @@ -2326,14 +2326,14 @@ let build_dependent_signature env evdref avoid tomatchs arsign = as much as possible *) let argsign = List.tl arsign in (* arguments in inverse application order *) let app_decl = List.hd arsign in (* The matched argument *) - let appn = get_name app_decl in - let appt = get_type app_decl in + let appn = RelDecl.get_name app_decl in + let appt = RelDecl.get_type app_decl in let argsign = List.rev argsign in (* arguments in application order *) let env', nargeqs, argeqs, refl_args, slift, argsign' = List.fold_left2 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl -> - let name = get_name decl in - let t = get_type decl in + let name = RelDecl.get_name decl in + let t = RelDecl.get_type decl in let argt = Retyping.get_type_of env !evdref arg in let eq, refl_arg = if Reductionops.is_conv env !evdref argt t then @@ -2351,7 +2351,7 @@ let build_dependent_signature env evdref avoid tomatchs arsign = let previd, id = let name = match kind_of_term arg with - Rel n -> get_name (lookup_rel n env) + Rel n -> RelDecl.get_name (lookup_rel n env) | _ -> name in make_prime avoid name @@ -2360,7 +2360,7 @@ let build_dependent_signature env evdref avoid tomatchs arsign = (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs, refl_arg :: refl_args, pred slift, - set_name (Name id) decl :: argsign')) + RelDecl.set_name (Name id) decl :: argsign')) (env, neqs, [], [], slift, []) args argsign in let eq = mk_JMeq evdref @@ -2375,13 +2375,13 @@ let build_dependent_signature env evdref avoid tomatchs arsign = succ nargeqs, refl_eq :: refl_args, pred slift, - ((set_name (Name id) app_decl :: argsign') :: arsigns)) + ((RelDecl.set_name (Name id) app_decl :: argsign') :: arsigns)) | _ -> (* Non dependent inductive or not inductive, just use a regular equality *) let decl = match arsign with [x] -> x | _ -> assert(false) in - let name = get_name decl in + let name = RelDecl.get_name decl in let previd, id = make_prime avoid name in - let arsign' = set_name (Name id) decl in + let arsign' = RelDecl.set_name (Name id) decl in let tomatch_ty = type_of_tomatch ty in let eq = mk_eq evdref (lift nar tomatch_ty) diff --git a/pretyping/cases.mli b/pretyping/cases.mli index ee4148de6..d8fad1687 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -28,9 +28,9 @@ type pattern_matching_error = exception PatternMatchingError of env * evar_map * pattern_matching_error -val error_wrong_numarg_constructor_loc : Loc.t -> env -> constructor -> int -> 'a +val error_wrong_numarg_constructor : ?loc:Loc.t -> env -> constructor -> int -> 'a -val error_wrong_numarg_inductive_loc : Loc.t -> env -> inductive -> int -> 'a +val error_wrong_numarg_inductive : ?loc:Loc.t -> env -> inductive -> int -> 'a val irrefutable : env -> cases_pattern -> bool diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 4f265e76c..30d100af9 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -538,7 +538,7 @@ let inheritance_graph () = let coercion_of_reference r = let ref = Nametab.global r in if not (coercion_exists ref) then - errorlabstrm "try_add_coercion" + user_err ~hdr:"try_add_coercion" (Nametab.pr_global_env Id.Set.empty ref ++ str" is not a coercion."); ref diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 913e80f39..2b860ae9c 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -153,7 +153,6 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) and coerce' env x y : (Term.constr -> Term.constr) option = let subco () = subset_coerce env evdref x y in let dest_prod c = - let open Context.Rel.Declaration in match Reductionops.splay_prod_n env ( !evdref) 1 c with | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na,t), c | _ -> raise NoSubtacCoercion @@ -412,7 +411,7 @@ let inh_tosort_force loc env evd j = let j2 = on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env j2) with Not_found | NoCoercion -> - error_not_a_type_loc loc env evd j + error_not_a_type ~loc env evd j let inh_coerce_to_sort loc env evd j = let typ = whd_all env evd j.uj_type in @@ -506,16 +505,16 @@ let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t = else raise NoSubtacCoercion with | NoSubtacCoercion when not resolve_tc || not !use_typeclasses_for_conversion -> - error_actual_type_loc loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj t e | NoSubtacCoercion -> let evd' = saturate_evd env evd in try if evd' == evd then - error_actual_type_loc loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj t e else inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (_evd,_error) -> - error_actual_type_loc loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj t e in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 886a98263..5ec44a68d 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -45,6 +45,7 @@ open Context.Rel.Declaration *) +type binding_bound_vars = Id.Set.t type bound_ident_map = Id.t Id.Map.t exception PatternMatchingFailure diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli index 8d8166f22..ee6c5141b 100644 --- a/pretyping/constr_matching.mli +++ b/pretyping/constr_matching.mli @@ -13,6 +13,8 @@ open Term open Environ open Pattern +type binding_bound_vars = Id.Set.t + (** [PatternMatchingFailure] is the exception raised when pattern matching fails *) exception PatternMatchingFailure @@ -41,7 +43,7 @@ val matches_head : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map variables or metavariables have the same name, the metavariable, or else the rightmost bound variable, takes precedence *) val extended_matches : - env -> Evd.evar_map -> Tacexpr.binding_bound_vars * constr_pattern -> + env -> Evd.evar_map -> binding_bound_vars * constr_pattern -> constr -> bound_ident_map * extended_patvar_map (** [is_matching pat c] just tells if [c] matches against [pat] *) @@ -75,7 +77,7 @@ val match_appsubterm : env -> Evd.evar_map -> constr_pattern -> constr -> matchi (** [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *) val match_subterm_gen : env -> Evd.evar_map -> bool (** true = with app context *) -> - Tacexpr.binding_bound_vars * constr_pattern -> constr -> + binding_bound_vars * constr_pattern -> constr -> matching_result IStream.t (** [is_matching_appsubterm pat c] tells if a subterm of [c] matches diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 85125a502..cad5551c1 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -67,15 +67,15 @@ let isomorphic_to_tuple lc = Int.equal (Array.length lc) 1 let encode_bool r = let (x,lc) = encode_inductive r in if not (has_two_constructors lc) then - user_err_loc (loc_of_reference r,"encode_if", - str "This type has not exactly two constructors."); + user_err ~loc:(loc_of_reference r) ~hdr:"encode_if" + (str "This type has not exactly two constructors."); x let encode_tuple r = let (x,lc) = encode_inductive r in if not (isomorphic_to_tuple lc) then - user_err_loc (loc_of_reference r,"encode_tuple", - str "This type cannot be seen as a tuple type."); + user_err ~loc:(loc_of_reference r) ~hdr:"encode_tuple" + (str "This type cannot be seen as a tuple type."); x module PrintingInductiveMake = diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 9fd55a488..88ea08c84 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -24,7 +24,10 @@ open Globnames open Evd open Pretype_errors open Sigma.Notations -open Context.Rel.Declaration +open Context.Named.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration type unify_fun = transparent_state -> env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result @@ -53,14 +56,13 @@ let eval_flexible_term ts env evd c = else None | Rel n -> (try match lookup_rel n env with - | LocalAssum _ -> None - | LocalDef (_,v,_) -> Some (lift n v) + | RelDecl.LocalAssum _ -> None + | RelDecl.LocalDef (_,v,_) -> Some (lift n v) with Not_found -> None) | Var id -> (try if is_transparent_variable ts id then - let open Context.Named.Declaration in - lookup_named id env |> get_value + env |> lookup_named id |> NamedDecl.get_value else None with Not_found -> None) | LetIn (_,b,_,c) -> Some (subst1 b c) @@ -389,7 +391,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty assert (match sk with [] -> true | _ -> false); let (na,c1,c'1) = destLambda term in let c = nf_evar evd c1 in - let env' = push_rel (LocalAssum (na,c)) env in + let env' = push_rel (RelDecl.LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in let out2 = whd_nored_state evd @@ -399,14 +401,16 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else evar_eqappr_x ts env' evd CONV out2 out1 in let rigids env evd sk term sk' term' = - let b,univs = Universes.eq_constr_universes term term' in - if b then + let univs = Universes.eq_constr_universes term term' in + match univs with + | Some univs -> ise_and evd [(fun i -> let cstrs = Universes.to_constraints (Evd.universes i) univs in try Success (Evd.add_constraints i cstrs) with Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk sk')] - else UnifFailure (evd,NotSameHead) + | None -> + UnifFailure (evd,NotSameHead) in let flex_maybeflex on_left ev ((termF,skF as apprF),cstsF) ((termM, skM as apprM),cstsM) vM = let switch f a b = if on_left then f a b else f b a in @@ -496,8 +500,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* Evar must be undefined since we have flushed evars *) let () = if !debug_unification then let open Pp in - Feedback.msg_notice (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ()) - ++ fnl ()) in + Feedback.msg_notice (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ())) in match (flex_kind_of_term (fst ts) env evd term1 sk1, flex_kind_of_term (fst ts) env evd term2 sk2) with | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) -> @@ -597,7 +600,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let b = nf_evar i b1 in let t = nf_evar i t1 in let na = Nameops.name_max na1 na2 in - evar_conv_x ts (push_rel (LocalDef (na,b,t)) env) i pbty c'1 c'2); + evar_conv_x ts (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] and f2 i = let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) @@ -648,14 +651,16 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty allow this identification (first-order unification of universes). Otherwise fallback to unfolding. *) - let b,univs = Universes.eq_constr_universes term1 term2 in - if b then + let univs = Universes.eq_constr_universes term1 term2 in + match univs with + | Some univs -> ise_and i [(fun i -> try Success (Evd.add_universe_constraints i univs) with UniversesDiffer -> UnifFailure (i,NotSameHead) | Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] - else UnifFailure (i,NotSameHead) + | None -> + UnifFailure (i,NotSameHead) and f2 i = (try if not (snd ts) then raise Not_found @@ -712,7 +717,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> let c = nf_evar i c1 in let na = Nameops.name_max na1 na2 in - evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i CONV c'1 c'2)] + evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2)] | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 @@ -771,7 +776,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> let c = nf_evar i c1 in let na = Nameops.name_max n1 n2 in - evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i pbty c'1 c'2)] + evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> if Int.equal x1 x2 then @@ -948,7 +953,6 @@ let choose_less_dependent_instance evk evd term args = | [] -> None | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd) -open Context.Named.Declaration let apply_on_subterm env evdref f c t = let rec applyrec (env,(k,c) as acc) t = (* By using eq_constr, we make an approximation, for instance, we *) @@ -979,14 +983,16 @@ let filter_possible_projections c ty ctxt args = List.map_i (fun i decl -> let () = assert (i < len) in let a = Array.unsafe_get args i in - (match decl with LocalAssum _ -> false | LocalDef (_,c,_) -> not (isRel c || isVar c)) || + (match decl with + | NamedDecl.LocalAssum _ -> false + | NamedDecl.LocalDef (_,c,_) -> not (isRel c || isVar c)) || a == c || (* Here we make an approximation, for instance, we could also be *) (* interested in finding a term u convertible to c such that a occurs *) (* in u *) isRel a && Int.Set.mem (destRel a) fv1 || isVar a && Id.Set.mem (destVar a) fv2 || - Id.Set.mem (get_id decl) tyvars) + Id.Set.mem (NamedDecl.get_id decl) tyvars) 0 ctxt let solve_evars = ref (fun _ -> failwith "solve_evars not installed") @@ -1017,10 +1023,10 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let env_evar = evar_filtered_env evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in - let instance = List.map mkVar (List.map get_id ctxt) in + let instance = List.map mkVar (List.map NamedDecl.get_id ctxt) in let rec make_subst = function - | decl'::ctxt', c::l, occs::occsl when isVarId (get_id decl') c -> + | decl'::ctxt', c::l, occs::occsl when isVarId (NamedDecl.get_id decl') c -> begin match occs with | Some _ -> error "Cannot force abstraction on identity instance." @@ -1028,7 +1034,8 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = make_subst (ctxt',l,occsl) end | decl'::ctxt', c::l, occs::occsl -> - let (id,_,t) = to_tuple decl' in + let id = NamedDecl.get_id decl' in + let t = NamedDecl.get_type decl' in let evs = ref [] in let ty = Retyping.get_type_of env_rhs evd c in let filter' = filter_possible_projections c ty ctxt args in @@ -1121,6 +1128,10 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let t2 = apprec_nohdbeta ts env evd (whd_head_evar evd t2) in let (term1,l1 as appr1) = try destApp t1 with DestKO -> (t1, [||]) in let (term2,l2 as appr2) = try destApp t2 with DestKO -> (t2, [||]) in + let () = if !debug_unification then + let open Pp in + Feedback.msg_notice (v 0 (str "Heuristic:" ++ spc () ++ print_constr t1 + ++ cut () ++ print_constr t2 ++ cut ())) in let app_empty = Array.is_empty l1 && Array.is_empty l2 in match kind_of_term term1, kind_of_term term2 with | Evar (evk1,args1), (Rel _|Var _) when app_empty @@ -1176,8 +1187,8 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = evar_conv_x ts env evd pbty t1 t2 let error_cannot_unify env evd pb ?reason t1 t2 = - Pretype_errors.error_cannot_unify_loc - (loc_of_conv_pb evd pb) env + Pretype_errors.error_cannot_unify + ~loc:(loc_of_conv_pb evd pb) env evd ?reason (t1, t2) let check_problems_are_solved env evd = diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index f9ab75cea..06f619410 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -19,21 +19,21 @@ open Evarutil open Pretype_errors open Sigma.Notations +module RelDecl = Context.Rel.Declaration + let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in (Sigma.to_evar_map evd, evk) let env_nf_evar sigma env = - let open Context.Rel.Declaration in process_rel_context - (fun d e -> push_rel (map_constr (nf_evar sigma) d) e) env + (fun d e -> push_rel (RelDecl.map_constr (nf_evar sigma) d) e) env let env_nf_betaiotaevar sigma env = - let open Context.Rel.Declaration in process_rel_context (fun d e -> - push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env + push_rel (RelDecl.map_constr (Reductionops.nf_betaiota sigma) d) e) env (****************************************) (* Operations on value/type constraints *) @@ -135,7 +135,7 @@ let define_pure_evar_as_lambda env evd evk = let evd1,(na,dom,rng) = match kind_of_term typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ - | _ -> error_not_product_loc Loc.ghost env evd typ in + | _ -> error_not_product env evd typ in let avoid = ids_of_named_context (evar_context evi) in let id = next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in @@ -191,7 +191,7 @@ let split_tycon loc env evd tycon = | App (c,args) when isEvar c -> let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in real_split evd' (mkApp (lam,args)) - | _ -> error_not_product_loc loc env evd c + | _ -> error_not_product ~loc env evd c in match tycon with | None -> evd,(Anonymous,None,None) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4fd030845..92662f07d 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -177,7 +177,7 @@ type 'a update = | NoUpdate open Context.Named.Declaration -let inst_of_vars sign = Array.map_of_list (mkVar % get_id) sign +let inst_of_vars sign = Array.map_of_list (get_id %> mkVar) sign let restrict_evar_key evd evk filter candidates = match filter, candidates with @@ -646,13 +646,13 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env in - let evd,b_in_sign = match d with - | LocalAssum _ -> evd,None + let evd,d' = match d with + | LocalAssum _ -> evd, Context.Named.Declaration.LocalAssum (id,t_in_sign) | LocalDef (_,b,_) -> let evd,b = define_evar_from_virtual_equation define_fun env evd src b t_in_sign sign filter inst_in_env in - evd,Some b in - (push_named_context_val (Context.Named.Declaration.of_tuple (id,b_in_sign,t_in_sign)) sign, Filter.extend 1 filter, + evd, Context.Named.Declaration.LocalDef (id,b,t_in_sign) in + (push_named_context_val d' sign, Filter.extend 1 filter, (mkRel 1)::(List.map (lift 1) inst_in_env), (mkRel 1)::(List.map (lift 1) inst_in_sign), push_rel d env,evd,id::avoid)) diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 4caa1e992..4b9cf415f 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -16,6 +16,8 @@ open Nameops open Termops open Pretype_errors +module NamedDecl = Context.Named.Declaration + (** Processing occurrences *) type occurrence_error = @@ -35,7 +37,7 @@ let explain_occurrence_error = function | IncorrectInValueOccurrence id -> explain_incorrect_in_value_occurrence id let error_occurrences_error e = - errorlabstrm "" (explain_occurrence_error e) + user_err (explain_occurrence_error e) let error_invalid_occurrence occ = error_occurrences_error (InvalidOccurrence occ) @@ -61,7 +63,7 @@ let proceed_with_occurrences f occs x = let map_named_declaration_with_hyploc f hyploc acc decl = let open Context.Named.Declaration in - let f = f (Some (get_id decl, hyploc)) in + let f = f (Some (NamedDecl.get_id decl, hyploc)) in match decl,hyploc with | LocalAssum (id,_), InHypValueOnly -> error_occurrences_error (IncorrectInValueOccurrence id) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 39aeb41f7..9cf91a947 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -55,7 +55,7 @@ let is_private mib = let check_privacy_block mib = if is_private mib then - errorlabstrm ""(str"case analysis on a private inductive type") + user_err (str"case analysis on a private inductive type") (**********************************************************************) (* Building case analysis schemes *) @@ -594,7 +594,7 @@ let lookup_eliminator ind_sp s = (* using short name (e.g. for "eq_rec") *) try Nametab.locate (qualid_of_ident id) with Not_found -> - errorlabstrm "default_elim" + user_err ~hdr:"default_elim" (strbrk "Cannot find the elimination combinator " ++ pr_id id ++ strbrk ", the elimination of the inductive definition " ++ pr_global_env Id.Set.empty (IndRef ind_sp) ++ diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 214e19fec..ac6d775e3 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -24,14 +24,14 @@ open Context.Rel.Declaration let type_of_inductive env (ind,u) = let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in - Typeops.check_hyps_inclusion env (mkInd ind) mib.mind_hyps; + Typeops.check_hyps_inclusion env mkInd ind mib.mind_hyps; Inductive.type_of_inductive env (specif,u) (* Return type as quoted by the user *) let type_of_constructor env (cstr,u) = let (mib,_ as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - Typeops.check_hyps_inclusion env (mkConstruct cstr) mib.mind_hyps; + Typeops.check_hyps_inclusion env mkConstruct cstr mib.mind_hyps; Inductive.type_of_constructor (cstr,u) specif (* Return constructor types in user form *) @@ -355,7 +355,7 @@ let make_case_or_project env indf ci pred c branches = let mib, _ = Inductive.lookup_mind_specif env ind in if (* dependent *) not (noccurn 1 t) && not (has_dependent_elim mib) then - errorlabstrm "make_case_or_project" + user_err ~hdr:"make_case_or_project" Pp.(str"Dependent case analysis not allowed" ++ str" on inductive type " ++ Names.MutInd.print (fst ind)) in @@ -615,7 +615,7 @@ let type_of_projection_knowing_arg env sigma p c ty = raise (Invalid_argument "type_of_projection_knowing_arg_type: not an inductive type") in let (_,u), pars = dest_ind_family pars in - substl (c :: List.rev pars) (Typeops.type_of_projection env (p,u)) + substl (c :: List.rev pars) (Typeops.type_of_projection_constant env (p,u)) (***********************************************) (* Guard condition *) diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 0dd64697c..1e5f12b20 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -20,6 +20,8 @@ open Nativecode open Nativevalues open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (** This module implements normalization by evaluation to OCaml code *) exception Find_at of int @@ -122,7 +124,7 @@ let build_case_type dep p realargs c = (* TODO move this function *) let type_of_rel env n = - lookup_rel n env |> get_type |> lift n + env |> lookup_rel n |> RelDecl.get_type |> lift n let type_of_prop = mkSort type1_sort @@ -133,7 +135,7 @@ let type_of_sort s = let type_of_var env id = let open Context.Named.Declaration in - try lookup_named id env |> get_type + try env |> lookup_named id |> get_type with Not_found -> anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound") diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 2090aad8a..977d3dae1 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -204,7 +204,7 @@ let error_instantiate_pattern id l = | [_] -> "is" | _ -> "are" in - errorlabstrm "" (str "Cannot substitute the term bound to " ++ pr_id id + user_err (str "Cannot substitute the term bound to " ++ pr_id id ++ strbrk " in pattern because the term refers to " ++ pr_enum pr_id l ++ strbrk " which " ++ str is ++ strbrk " not bound in the pattern.") @@ -315,7 +315,7 @@ let rec subst_pattern subst pat = let mkPLambda na b = PLambda(na,PMeta None,b) let rev_it_mkPLambda = List.fold_right mkPLambda -let err loc pp = user_err_loc (loc,"pattern_of_glob_constr", pp) +let err ?loc pp = user_err ?loc ~hdr:"pattern_of_glob_constr" pp let warn_cast_in_pattern = CWarnings.create ~name:"cast-in-pattern" ~category:"automation" @@ -387,7 +387,7 @@ let rec pat_of_raw metas vars = function rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p)) | (None | Some (GHole _)), _ -> PMeta None | Some p, None -> - user_err_loc (loc,"",strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") + user_err ~loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") in let info = { cip_style = sty; @@ -400,14 +400,14 @@ let rec pat_of_raw metas vars = function one non-trivial branch. These facts are used in [Constrextern]. *) PCase (info, pred, pat_of_raw metas vars c, brs) - | r -> err (loc_of_glob_constr r) (Pp.str "Non supported pattern.") + | r -> err ~loc:(loc_of_glob_constr r) (Pp.str "Non supported pattern.") and pats_of_glob_branches loc metas vars ind brs = let get_arg = function | PatVar(_,na) -> name_iter (fun n -> metas := n::!metas) na; na - | PatCstr(loc,_,_,_) -> err loc (Pp.str "Non supported pattern.") + | PatCstr(loc,_,_,_) -> err ~loc (Pp.str "Non supported pattern.") in let rec get_pat indexes = function | [] -> false, [] @@ -416,10 +416,10 @@ and pats_of_glob_branches loc metas vars ind brs = let () = match ind with | Some sp when eq_ind sp indsp -> () | _ -> - err loc (Pp.str "All constructors must be in the same inductive type.") + err ~loc (Pp.str "All constructors must be in the same inductive type.") in if Int.Set.mem (j-1) indexes then - err loc + err ~loc (str "No unique branch for " ++ int j ++ str"-th constructor."); let lna = List.map get_arg lv in let vars' = List.rev lna @ vars in @@ -427,7 +427,7 @@ and pats_of_glob_branches loc metas vars ind brs = let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in ext, ((j-1, tags, pat) :: pats) - | (loc,_,_,_) :: _ -> err loc (Pp.str "Non supported pattern.") + | (loc,_,_,_) :: _ -> err ~loc (Pp.str "Non supported pattern.") in get_pat Int.Set.empty brs diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 00b6100c0..5b0958695 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -64,43 +64,42 @@ let precatchable_exception = function | Nametab.GlobalizationError _ -> true | _ -> false -let raise_pretype_error (loc,env,sigma,te) = - Loc.raise loc (PretypeError(env,sigma,te)) +let raise_pretype_error ?loc (env,sigma,te) = + Loc.raise ?loc (PretypeError(env,sigma,te)) -let raise_located_type_error (loc,env,sigma,te) = - Loc.raise loc (PretypeError(env,sigma,TypingError te)) +let raise_type_error ?loc (env,sigma,te) = + Loc.raise ?loc (PretypeError(env,sigma,TypingError te)) - -let error_actual_type_loc loc env sigma {uj_val=c;uj_type=actty} expty reason = +let error_actual_type ?loc env sigma {uj_val=c;uj_type=actty} expty reason = let j = {uj_val=c;uj_type=actty} in - raise_pretype_error - (loc, env, sigma, ActualTypeNotCoercible (j, expty, reason)) + raise_pretype_error ?loc + (env, sigma, ActualTypeNotCoercible (j, expty, reason)) -let error_cant_apply_not_functional_loc loc env sigma rator randl = - raise_located_type_error - (loc, env, sigma, CantApplyNonFunctional (rator, Array.of_list randl)) +let error_cant_apply_not_functional ?loc env sigma rator randl = + raise_type_error ?loc + (env, sigma, CantApplyNonFunctional (rator, Array.of_list randl)) -let error_cant_apply_bad_type_loc loc env sigma (n,c,t) rator randl = - raise_located_type_error - (loc, env, sigma, +let error_cant_apply_bad_type ?loc env sigma (n,c,t) rator randl = + raise_type_error ?loc + (env, sigma, CantApplyBadType ((n,c,t), rator, Array.of_list randl)) -let error_ill_formed_branch_loc loc env sigma c i actty expty = - raise_located_type_error - (loc, env, sigma, IllFormedBranch (c, i, actty, expty)) +let error_ill_formed_branch ?loc env sigma c i actty expty = + raise_type_error + ?loc (env, sigma, IllFormedBranch (c, i, actty, expty)) -let error_number_branches_loc loc env sigma cj expn = - raise_located_type_error (loc, env, sigma, NumberBranches (cj, expn)) +let error_number_branches ?loc env sigma cj expn = + raise_type_error ?loc (env, sigma, NumberBranches (cj, expn)) -let error_case_not_inductive_loc loc env sigma cj = - raise_located_type_error (loc, env, sigma, CaseNotInductive cj) +let error_case_not_inductive ?loc env sigma cj = + raise_type_error ?loc (env, sigma, CaseNotInductive cj) -let error_ill_typed_rec_body_loc loc env sigma i na jl tys = - raise_located_type_error - (loc, env, sigma, IllTypedRecBody (i, na, jl, tys)) +let error_ill_typed_rec_body ?loc env sigma i na jl tys = + raise_type_error ?loc + (env, sigma, IllTypedRecBody (i, na, jl, tys)) -let error_not_a_type_loc loc env sigma j = - raise_located_type_error (loc, env, sigma, NotAType j) +let error_not_a_type ?loc env sigma j = + raise_type_error ?loc (env, sigma, NotAType j) (*s Implicit arguments synthesis errors. It is hard to find a precise location. *) @@ -108,15 +107,12 @@ let error_not_a_type_loc loc env sigma j = let error_occur_check env sigma ev c = raise (PretypeError (env, sigma, UnifOccurCheck (ev,c))) -let error_unsolvable_implicit loc env sigma evk explain = - Loc.raise loc +let error_unsolvable_implicit ?loc env sigma evk explain = + Loc.raise ?loc (PretypeError (env, sigma, UnsolvableImplicit (evk, explain))) -let error_cannot_unify_loc loc env sigma ?reason (m,n) = - Loc.raise loc (PretypeError (env, sigma,CannotUnify (m,n,reason))) - -let error_cannot_unify env sigma ?reason (m,n) = - raise (PretypeError (env, sigma,CannotUnify (m,n,reason))) +let error_cannot_unify ?loc env sigma ?reason (m,n) = + Loc.raise ?loc (PretypeError (env, sigma,CannotUnify (m,n,reason))) let error_cannot_unify_local env sigma (m,n,sn) = raise (PretypeError (env, sigma,CannotUnifyLocal (m,n,sn))) @@ -140,21 +136,21 @@ let error_non_linear_unification env sigma hdmeta t = (*s Ml Case errors *) -let error_cant_find_case_type_loc loc env sigma expr = - raise_pretype_error (loc, env, sigma, CantFindCaseType expr) +let error_cant_find_case_type ?loc env sigma expr = + raise_pretype_error ?loc (env, sigma, CantFindCaseType expr) (*s Pretyping errors *) -let error_unexpected_type_loc loc env sigma actty expty = - raise_pretype_error (loc, env, sigma, UnexpectedType (actty, expty)) +let error_unexpected_type ?loc env sigma actty expty = + raise_pretype_error ?loc (env, sigma, UnexpectedType (actty, expty)) -let error_not_product_loc loc env sigma c = - raise_pretype_error (loc, env, sigma, NotProduct c) +let error_not_product ?loc env sigma c = + raise_pretype_error ?loc (env, sigma, NotProduct c) (*s Error in conversion from AST to glob_constr *) -let error_var_not_found_loc loc s = - raise_pretype_error (loc, empty_env, Evd.empty, VarNotFound s) +let error_var_not_found ?loc s = + raise_pretype_error ?loc (empty_env, Evd.empty, VarNotFound s) (*s Typeclass errors *) @@ -166,7 +162,7 @@ let unsatisfiable_constraints env evd ev comp = | Some ev -> let loc, kind = Evd.evar_source ev evd in let err = UnsatisfiableConstraints (Some (ev, kind), comp) in - Loc.raise loc (PretypeError (env,evd,err)) + Loc.raise ~loc (PretypeError (env,evd,err)) let unsatisfiable_exception exn = match exn with diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 880f48e5f..73f81923f 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -64,35 +64,35 @@ exception PretypeError of env * Evd.evar_map * pretype_error val precatchable_exception : exn -> bool (** Raising errors *) -val error_actual_type_loc : - Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> +val error_actual_type : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> unification_error -> 'b -val error_cant_apply_not_functional_loc : - Loc.t -> env -> Evd.evar_map -> +val error_cant_apply_not_functional : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> unsafe_judgment list -> 'b -val error_cant_apply_bad_type_loc : - Loc.t -> env -> Evd.evar_map -> int * constr * constr -> +val error_cant_apply_bad_type : + ?loc:Loc.t -> env -> Evd.evar_map -> int * constr * constr -> unsafe_judgment -> unsafe_judgment list -> 'b -val error_case_not_inductive_loc : - Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b +val error_case_not_inductive : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b -val error_ill_formed_branch_loc : - Loc.t -> env -> Evd.evar_map -> +val error_ill_formed_branch : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> pconstructor -> constr -> constr -> 'b -val error_number_branches_loc : - Loc.t -> env -> Evd.evar_map -> +val error_number_branches : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> int -> 'b -val error_ill_typed_rec_body_loc : - Loc.t -> env -> Evd.evar_map -> +val error_ill_typed_rec_body : + ?loc:Loc.t -> env -> Evd.evar_map -> int -> Name.t array -> unsafe_judgment array -> types array -> 'b -val error_not_a_type_loc : - Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b +val error_not_a_type : + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b @@ -101,15 +101,12 @@ val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b val error_unsolvable_implicit : - Loc.t -> env -> Evd.evar_map -> existential_key -> + ?loc:Loc.t -> env -> Evd.evar_map -> existential_key -> Evd.unsolvability_explanation option -> 'b -val error_cannot_unify_loc : Loc.t -> env -> Evd.evar_map -> +val error_cannot_unify : ?loc:Loc.t -> env -> Evd.evar_map -> ?reason:unification_error -> constr * constr -> 'b -val error_cannot_unify : env -> Evd.evar_map -> ?reason:unification_error -> - constr * constr -> 'b - val error_cannot_unify_local : env -> Evd.evar_map -> constr * constr * constr -> 'b val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map -> @@ -126,20 +123,20 @@ val error_non_linear_unification : env -> Evd.evar_map -> (** {6 Ml Case errors } *) -val error_cant_find_case_type_loc : - Loc.t -> env -> Evd.evar_map -> constr -> 'b +val error_cant_find_case_type : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b (** {6 Pretyping errors } *) -val error_unexpected_type_loc : - Loc.t -> env -> Evd.evar_map -> constr -> constr -> 'b +val error_unexpected_type : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> constr -> 'b -val error_not_product_loc : - Loc.t -> env -> Evd.evar_map -> constr -> 'b +val error_not_product : + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b (** {6 Error in conversion from AST to glob_constr } *) -val error_var_not_found_loc : Loc.t -> Id.t -> 'b +val error_var_not_found : ?loc:Loc.t -> Id.t -> 'b (** {6 Typeclass errors } *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 4b6d10c64..f92110ea5 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -43,8 +43,10 @@ open Glob_ops open Evarconv open Pattern open Misctypes +open Tactypes open Sigma.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration type typing_constraint = OfType of types | IsType | WithoutTypeConstraint type var_map = constr_under_binders Id.Map.t @@ -58,8 +60,6 @@ type ltac_var_map = { } type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * constr -type 'a delayed_open = - { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } (************************************************************************) (* This concerns Cases *) @@ -104,7 +104,7 @@ let lookup_named id env = lookup_named id env.env let e_new_evar env evdref ?src ?naming typ = let subst2 subst vsubst c = csubst_subst subst (replace_vars vsubst c) in let open Context.Named.Declaration in - let inst_vars = List.map (fun d -> mkVar (get_id d)) (named_context env.env) in + let inst_vars = List.map (get_id %> mkVar) (named_context env.env) in let inst_rels = List.rev (rel_list 0 (nb_rel env.env)) in let (subst, vsubst, _, nc) = Lazy.force env.extra in let typ' = subst2 subst vsubst typ in @@ -160,7 +160,7 @@ let search_guard loc env possible_indexes fixdefs = with TypeError _ -> ()) (List.combinations possible_indexes); let errmsg = "Cannot guess decreasing argument of fix." in - user_err_loc (loc,"search_guard", Pp.str errmsg) + user_err ~loc ~hdr:"search_guard" (Pp.str errmsg) with Found indexes -> indexes) (* To force universe name declaration before use *) @@ -188,7 +188,7 @@ let _ = (** Miscellaneous interpretation functions *) let interp_universe_level_name evd (loc,s) = - let names, _ = Universes.global_universe_names () in + let names, _ = Global.global_universe_names () in if CString.string_contains s "." then match List.rev (CString.split '.' s) with | [] -> anomaly (str"Invalid universe name " ++ str s) @@ -211,8 +211,8 @@ let interp_universe_level_name evd (loc,s) = with Not_found -> if not (is_strict_universe_declarations ()) then new_univ_level_variable ~loc ~name:s univ_rigid evd - else user_err_loc (loc, "interp_universe_level_name", - Pp.(str "Undeclared universe: " ++ str s)) + else user_err ~loc ~hdr:"interp_universe_level_name" + (Pp.(str "Undeclared universe: " ++ str s)) let interp_universe ?loc evd = function | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in @@ -307,7 +307,7 @@ let check_extra_evars_are_solved env current_sigma pending = match k with | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () | _ -> - error_unsolvable_implicit loc env current_sigma evk None) pending + error_unsolvable_implicit ~loc env current_sigma evk None) pending (* [check_evars] fails if some unresolved evar remains *) @@ -322,7 +322,7 @@ let check_evars env initial_sigma sigma c = let (loc,k) = evar_source evk sigma in match k with | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () - | _ -> Pretype_errors.error_unsolvable_implicit loc env sigma evk None) + | _ -> Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None) | _ -> Constr.iter proc_rec c in proc_rec c @@ -365,9 +365,9 @@ let check_instance loc subst = function | [] -> () | (id,_) :: _ -> if List.mem_assoc id subst then - user_err_loc (loc,"",pr_id id ++ str "appears more than once.") + user_err ~loc (pr_id id ++ str "appears more than once.") else - user_err_loc (loc,"",str "No such variable in the signature of the existential variable: " ++ pr_id id ++ str ".") + user_err ~loc (str "No such variable in the signature of the existential variable: " ++ pr_id id ++ str ".") (* used to enforce a name in Lambda when the type constraints itself is named, hence possibly dependent *) @@ -382,7 +382,7 @@ let ltac_interp_name { ltac_idents ; ltac_genargs } = function try Name (Id.Map.find id ltac_idents) with Not_found -> if Id.Map.mem id ltac_genargs then - errorlabstrm "" (str"Ltac variable"++spc()++ pr_id id ++ + user_err (str"Ltac variable"++spc()++ pr_id id ++ spc()++str"is not bound to an identifier."++spc()++ str"It cannot be used in a binder.") else n @@ -404,14 +404,14 @@ let invert_ltac_bound_name lvar env id0 id = let id' = Id.Map.find id lvar.ltac_idents in try mkRel (pi1 (lookup_rel_id id' (rel_context env))) with Not_found -> - errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++ + user_err (str "Ltac variable " ++ pr_id id0 ++ str " depends on pattern variable name " ++ pr_id id ++ str " which is not bound in current context.") let protected_get_type_of env sigma c = try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c with Retyping.RetypeError _ -> - errorlabstrm "" + user_err (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.") @@ -447,16 +447,16 @@ let pretype_id pretype k0 loc env evdref lvar id = (* and build a nice error message *) if Id.Map.mem id lvar.ltac_genargs then begin let Geninterp.Val.Dyn (typ, _) = Id.Map.find id lvar.ltac_genargs in - user_err_loc (loc,"", - str "Variable " ++ pr_id id ++ str " should be bound to a term but is \ + user_err ~loc + (str "Variable " ++ pr_id id ++ str " should be bound to a term but is \ bound to a " ++ Geninterp.Val.pr typ ++ str ".") end; (* Check if [id] is a section or goal variable *) try - { uj_val = mkVar id; uj_type = (get_type (lookup_named id env)) } + { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id env) } with Not_found -> (* [id] not found, standard error message *) - error_var_not_found_loc loc id + error_var_not_found ~loc id let evar_kind_of_term sigma c = kind_of_term (whd_evar sigma c) @@ -479,16 +479,16 @@ let pretype_global loc rigid env evd gr us = let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in let len = Array.length arr in if len != List.length l then - user_err_loc (loc, "pretype", - str "Universe instance should have length " ++ int len) + user_err ~loc ~hdr:"pretype" + (str "Universe instance should have length " ++ int len) else let evd, l' = List.fold_left (fun (evd, univs) l -> let evd, l = interp_universe_level_name loc evd l in (evd, l :: univs)) (evd, []) l in if List.exists (fun l -> Univ.Level.is_prop l) l' then - user_err_loc (loc, "pretype", - str "Universe instances cannot contain Prop, polymorphic" ++ + user_err ~loc ~hdr:"pretype" + (str "Universe instances cannot contain Prop, polymorphic" ++ str " universe instances must be greater or equal to Set."); evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) in @@ -498,12 +498,12 @@ let pretype_ref loc evdref env ref us = match ref with | VarRef id -> (* Section variable *) - (try make_judge (mkVar id) (get_type (lookup_named id env)) + (try make_judge (mkVar id) (NamedDecl.get_type (lookup_named id env)) with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal variables *) - Pretype_errors.error_var_not_found_loc loc id) + Pretype_errors.error_var_not_found ~loc id) | ref -> let evd, c = pretype_global loc univ_flexible env !evdref ref us in let () = evdref := evd in @@ -559,7 +559,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let evk = try Evd.evar_key id !evdref with Not_found -> - user_err_loc (loc,"",str "Unknown existential variable.") in + user_err ~loc (str "Unknown existential variable.") in let hyps = evar_filtered_context (Evd.find !evdref evk) in let args = pretype_instance k0 resolve_tc env evdref lvar loc hyps evk inst in let c = mkEvar (evk, args) in @@ -742,9 +742,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | _ -> let hj = pretype empty_tycon env evdref lvar c in - error_cant_apply_not_functional_loc - (Loc.merge floc argloc) env.ExtraEnv.env !evdref - resj [hj] + error_cant_apply_not_functional + ~loc:(Loc.merge floc argloc) env.ExtraEnv.env !evdref + resj [hj] in let resj = apply_rec env 1 fj candargs args in let resj = @@ -837,15 +837,15 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre try find_rectype env.ExtraEnv.env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj + error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 1) then - user_err_loc (loc,"",str "Destructing let is only for inductive types" ++ + user_err ~loc (str "Destructing let is only for inductive types" ++ str " with one constructor."); let cs = cstrs.(0) in if not (Int.equal (List.length nal) cs.cs_nargs) then - user_err_loc (loc,"", str "Destructing let on this type expects " ++ + user_err ~loc:loc (str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables."); let fsign, record = match get_projections env.ExtraEnv.env indf with @@ -911,7 +911,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre if noccur_between 1 cs.cs_nargs ccl then lift (- cs.cs_nargs) ccl else - error_cant_find_case_type_loc loc env.ExtraEnv.env !evdref + error_cant_find_case_type ~loc env.ExtraEnv.env !evdref cj.uj_val in (* let ccl = refresh_universes ccl in *) let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in @@ -927,11 +927,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre try find_rectype env.ExtraEnv.env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env.ExtraEnv.env !evdref cj in + error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 2) then - user_err_loc (loc,"", - str "If is only for inductive types with two constructors."); + user_err ~loc + (str "If is only for inductive types with two constructors."); let arsgn = let arsgn,_ = get_arity env.ExtraEnv.env indf in @@ -1013,9 +1013,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let (evd,b) = Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval + error_actual_type ~loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) - else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ + else user_err ~loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> let cj = pretype empty_tycon env evdref lvar c in @@ -1024,7 +1024,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type_loc loc env.ExtraEnv.env !evdref cj tval + error_actual_type ~loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) end | _ -> @@ -1036,8 +1036,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = let f decl (subst,update) = - let id = get_id decl in - let t = replace_vars subst (get_type decl) in + let id = NamedDecl.get_id decl in + let t = replace_vars subst (NamedDecl.get_type decl) in let c, update = try let c = List.assoc id update in @@ -1049,10 +1049,10 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = if is_conv env.ExtraEnv.env !evdref t t' then mkRel n, update else raise Not_found with Not_found -> try - let t' = lookup_named id env |> get_type in + let t' = env |> lookup_named id |> NamedDecl.get_type in if is_conv env.ExtraEnv.env !evdref t t' then mkVar id, update else raise Not_found with Not_found -> - user_err_loc (loc,"",str "Cannot interpret " ++ + user_err ~loc (str "Cannot interpret " ++ pr_existential_key !evdref evk ++ str " in current context: no binding for " ++ pr_id id ++ str ".") in ((id,c)::subst, update) in @@ -1090,8 +1090,8 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function | Some v -> if e_cumul env.ExtraEnv.env evdref v tj.utj_val then tj else - error_unexpected_type_loc - (loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v + error_unexpected_type + ~loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v let ise_pretype_gen flags env sigma lvar kind c = let env = make_env env in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 0f3f7c3c9..2c6aa7a21 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -57,9 +57,6 @@ type inference_flags = { expand_evars : bool } -type 'a delayed_open = - { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } - val default_inference_flags : bool -> inference_flags val no_classes_no_fail_inference_flags : inference_flags @@ -122,7 +119,7 @@ val understand_judgment_tcc : env -> evar_map ref -> val type_uconstr : ?flags:inference_flags -> ?expected_type:typing_constraint -> - Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open + Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr Tactypes.delayed_open (** Trying to solve remaining evars and remaining conversion problems possibly using type classes, heuristics, external tactic solver diff --git a/pretyping/program.ml b/pretyping/program.ml index 62aedcfbf..4b6137b53 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -19,7 +19,7 @@ let find_reference locstr dir s = let sp = Libnames.make_path dp (Id.of_string s) in try Nametab.global_of_path sp with Not_found -> - user_err_loc (Loc.ghost, "", str "Library " ++ Libnames.pr_dirpath dp ++ + user_err (str "Library " ++ Libnames.pr_dirpath dp ++ str " has to be required first.") let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 284af0cb1..cda052b79 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -291,7 +291,7 @@ let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) (*s High-level declaration of a canonical structure *) let error_not_structure ref = - errorlabstrm "object_declare" + user_err ~hdr:"object_declare" (Nameops.pr_id (basename_of_global ref) ++ str" is not a structure object.") let check_and_decompose_canonical_structure ref = diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 297f0a1a8..1fdbbb412 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -681,13 +681,17 @@ let magicaly_constant_of_fixbody env reference bd = function match constant_opt_value_in env (cst,u) with | None -> bd | Some t -> - let b, csts = Universes.eq_constr_universes t bd in - let subst = Universes.Constraints.fold (fun (l,d,r) acc -> - Univ.LMap.add (Option.get (Universe.level l)) (Option.get (Universe.level r)) acc) - csts Univ.LMap.empty - in - let inst = Instance.subst_fn (fun u -> Univ.LMap.find u subst) u in - if b then mkConstU (cst,inst) else bd + let csts = Universes.eq_constr_universes t bd in + begin match csts with + | Some csts -> + let subst = Universes.Constraints.fold (fun (l,d,r) acc -> + Univ.LMap.add (Option.get (Universe.level l)) (Option.get (Universe.level r)) acc) + csts Univ.LMap.empty + in + let inst = Instance.subst_fn (fun u -> Univ.LMap.find u subst) u in + mkConstU (cst,inst) + | None -> bd + end with | Not_found -> bd @@ -1230,7 +1234,7 @@ let pb_equal = function | Reduction.CONV -> Reduction.CONV let report_anomaly _ = - let e = UserError ("", Pp.str "Conversion test raised an anomaly") in + let e = UserError (None, Pp.str "Conversion test raised an anomaly") in let e = CErrors.push e in iraise e diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 98b36fb92..5b67af3e7 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -20,6 +20,9 @@ open Termops open Arguments_renaming open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + type retype_error = | NotASort | NotAnArity @@ -78,8 +81,7 @@ let sort_of_atomic_type env sigma ft args = in concl_of_arity env 0 ft (Array.to_list args) let type_of_var env id = - let open Context.Named.Declaration in - try get_type (lookup_named id env) + try NamedDecl.get_type (lookup_named id env) with Not_found -> retype_error (BadVariable id) let decomp_sort env sigma t = @@ -94,7 +96,7 @@ let retype ?(polyprop=true) sigma = (try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus with Not_found -> retype_error (BadMeta n)) | Rel n -> - let ty = get_type (lookup_rel n env) in + let ty = RelDecl.get_type (lookup_rel n env) in lift n ty | Var id -> type_of_var env id | Const cst -> rename_type_of_constant env cst @@ -239,7 +241,7 @@ let sorts_of_context env evc ctxt = | [] -> env,[] | d :: ctxt -> let env,sorts = aux ctxt in - let s = get_sort_of env evc (get_type d) in + let s = get_sort_of env evc (RelDecl.get_type d) in (push_rel d env,s::sorts) in snd (aux ctxt) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 820a81b5d..7da738508 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -25,6 +25,9 @@ open Patternops open Locus open Sigma.Notations +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (* Errors *) type reduction_tactic_error = @@ -38,7 +41,7 @@ exception Elimconst exception Redelimination let error_not_evaluable r = - errorlabstrm "error_not_evaluable" + user_err ~hdr:"error_not_evaluable" (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r ++ spc () ++ str "to an evaluable reference.") @@ -54,13 +57,12 @@ let is_evaluable env = function | EvalVarRef id -> is_evaluable_var env id let value_of_evaluable_ref env evref u = - let open Context.Named.Declaration in match evref with | EvalConstRef con -> (try constant_value_in env (con,u) with NotEvaluableConst IsProj -> raise (Invalid_argument "value_of_evaluable_ref")) - | EvalVarRef id -> lookup_named id env |> get_value |> Option.get + | EvalVarRef id -> env |> lookup_named id |> NamedDecl.get_value |> Option.get let evaluable_of_global_reference env = function | ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst @@ -112,22 +114,18 @@ let unsafe_reference_opt_value env sigma eval = | Declarations.Def c -> Some (Mod_subst.force_constr c) | _ -> None) | EvalVar id -> - let open Context.Named.Declaration in - lookup_named id env |> get_value + env |> lookup_named id |> NamedDecl.get_value | EvalRel n -> - let open Context.Rel.Declaration in - lookup_rel n env |> map_value (lift n) |> get_value + env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value | EvalEvar ev -> Evd.existential_opt_value sigma ev let reference_opt_value env sigma eval u = match eval with | EvalConst cst -> constant_opt_value_in env (cst,u) | EvalVar id -> - let open Context.Named.Declaration in - lookup_named id env |> get_value + env |> lookup_named id |> NamedDecl.get_value | EvalRel n -> - let open Context.Rel.Declaration in - lookup_rel n env |> map_value (lift n) |> get_value + env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value | EvalEvar ev -> Evd.existential_opt_value sigma ev exception NotEvaluable @@ -541,11 +539,9 @@ let match_eval_ref_value env sigma constr = | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> Some (constant_value_in env (sp, u)) | Var id when is_evaluable env (EvalVarRef id) -> - let open Context.Named.Declaration in - lookup_named id env |> get_value + env |> lookup_named id |> NamedDecl.get_value | Rel n -> - let open Context.Rel.Declaration in - lookup_rel n env |> map_value (lift n) |> get_value + env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value | Evar ev -> Evd.existential_opt_value sigma ev | _ -> None @@ -993,7 +989,7 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> incr pos; if ok then begin if Option.has_some nested then - errorlabstrm "" (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (!pos-1) ++ str "."); + user_err (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (!pos-1) ++ str "."); (* Skip inner occurrences for stable counting of occurrences *) if locs != [] then ignore (traverse_below (Some (!pos-1)) envc t); @@ -1159,13 +1155,13 @@ let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> let check_privacy env ind = let spec = Inductive.lookup_mind_specif env (fst ind) in if Inductive.is_private spec then - errorlabstrm "" (str "case analysis on a private type.") + user_err (str "case analysis on a private type.") else ind let check_not_primitive_record env ind = let spec = Inductive.lookup_mind_specif env (fst ind) in if Inductive.is_primitive_record spec then - errorlabstrm "" (str "case analysis on a primitive record type: " ++ + user_err (str "case analysis on a primitive record type: " ++ str "use projections or let instead.") else ind @@ -1182,14 +1178,14 @@ let reduce_to_ind_gen allow_product env sigma t = if allow_product then elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) else - errorlabstrm "" (str"Not an inductive definition.") + user_err (str"Not an inductive definition.") | _ -> (* Last chance: we allow to bypass the Opaque flag (as it was partially the case between V5.10 and V8.1 *) let t' = whd_all env sigma t in match kind_of_term (fst (decompose_app t')) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) - | _ -> errorlabstrm "" (str"Not an inductive product.") + | _ -> user_err (str"Not an inductive product.") in elimrec env t [] @@ -1239,7 +1235,7 @@ let one_step_reduce env sigma c = applist (redrec (c,[])) let error_cannot_recognize ref = - errorlabstrm "" + user_err (str "Cannot recognize a statement based on " ++ Nametab.pr_global_env Id.Set.empty ref ++ str".") diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index b8da6b685..01f3620f1 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -17,6 +17,9 @@ open Util open Typeclasses_errors open Libobject open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration (*i*) let typeclasses_unique_solutions = ref false @@ -181,7 +184,7 @@ let subst_class (subst,cl) = let do_subst_con c = Mod_subst.subst_constant subst c and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in - let do_subst_ctx = List.smartmap (map_constr do_subst) in + let do_subst_ctx = List.smartmap (RelDecl.map_constr do_subst) in let do_subst_context (grs,ctx) = List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, do_subst_ctx ctx in @@ -197,19 +200,16 @@ let subst_class (subst,cl) = let discharge_class (_,cl) = let repl = Lib.replacement_context () in let rel_of_variable_context ctx = List.fold_right - ( fun (n,_,b,t) (ctx', subst) -> - let decl = match b with - | None -> LocalAssum (Name n, substn_vars 1 subst t) - | Some b -> LocalDef (Name n, substn_vars 1 subst b, substn_vars 1 subst t) - in - (decl :: ctx', n :: subst) + ( fun (decl,_) (ctx', subst) -> + let decl' = decl |> NamedDecl.map_constr (substn_vars 1 subst) |> NamedDecl.to_rel_decl in + (decl' :: ctx', NamedDecl.get_id decl :: subst) ) ctx ([], []) in let discharge_rel_context subst n rel = let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in let ctx, _ = List.fold_right (fun decl (ctx, k) -> - map_constr (substn_vars k subst) decl :: ctx, succ k + RelDecl.map_constr (substn_vars k subst) decl :: ctx, succ k ) rel ([], n) in ctx @@ -222,7 +222,7 @@ let discharge_class (_,cl) = let discharge_context ctx' subst (grs, ctx) = let grs' = let newgrs = List.map (fun decl -> - match decl |> get_type |> class_of_constr with + match decl |> RelDecl.get_type |> class_of_constr with | None -> None | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) ctx' diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 9e9997f73..e79e3d46f 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -132,7 +132,7 @@ let check_type_fixpoint loc env evdref lna lar vdefj = for i = 0 to lt-1 do if not (Evarconv.e_cumul env evdref (vdefj.(i)).uj_type (lift lt lar.(i))) then - Pretype_errors.error_ill_typed_rec_body_loc loc env !evdref + Pretype_errors.error_ill_typed_rec_body ~loc env !evdref i lna vdefj lar done diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 259318693..a91c30df6 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -29,7 +29,9 @@ open Locus open Locusops open Find_subterm open Sigma.Notations -open Context.Named.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration let keyed_unification = ref (false) let _ = Goptions.declare_bool_option { @@ -78,9 +80,8 @@ let occur_meta_evd sigma mv c = let abstract_scheme env evd c l lname_typ = List.fold_left2 (fun (t,evd) (locc,a) decl -> - let open Context.Rel.Declaration in - let na = get_name decl in - let ta = get_type decl in + let na = RelDecl.get_name decl in + let ta = RelDecl.get_type decl in let na = match kind_of_term a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... @@ -557,19 +558,22 @@ let force_eqs c = c Universes.Constraints.empty let constr_cmp pb sigma flags t u = - let b, cstrs = + let cstrs = if pb == Reduction.CONV then Universes.eq_constr_universes t u else Universes.leq_constr_universes t u in - if b then - try Evd.add_universe_constraints sigma cstrs, b + match cstrs with + | Some cstrs -> + begin try Evd.add_universe_constraints sigma cstrs, true with Univ.UniverseInconsistency _ -> sigma, false | Evd.UniversesDiffer -> if is_rigid_head flags t then - try Evd.add_universe_constraints sigma (force_eqs cstrs), b + try Evd.add_universe_constraints sigma (force_eqs cstrs), true with Univ.UniverseInconsistency _ -> sigma, false else sigma, false - else sigma, b + end + | None -> + sigma, false let do_reduce ts (env, nb) sigma c = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state @@ -1478,10 +1482,10 @@ let indirectly_dependent c d decls = it is needed otherwise, as e.g. when abstracting over "2" in "forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious way to see that the second hypothesis depends indirectly over 2 *) - List.exists (fun d' -> dependent_in_decl (mkVar (get_id d')) d) decls + List.exists (fun d' -> dependent_in_decl (mkVar (NamedDecl.get_id d')) d) decls let indirect_dependency d decls = - decls |> List.filter (fun d' -> dependent_in_decl (mkVar (get_id d')) d) |> List.hd |> get_id + decls |> List.filter (fun d' -> dependent_in_decl (mkVar (NamedDecl.get_id d')) d) |> List.hd |> NamedDecl.get_id let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = let current_sigma = Sigma.to_evar_map current_sigma in @@ -1592,7 +1596,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else if mem_named_context_val x (named_context_val env) then - errorlabstrm "Unification.make_abstraction_core" + user_err ~hdr:"Unification.make_abstraction_core" (str "The variable " ++ Nameops.pr_id x ++ str " is already declared.") else x @@ -1600,7 +1604,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let likefirst = clause_with_generic_occurrences occs in let mkvarid () = mkVar id in let compute_dependency _ d (sign,depdecls) = - let hyp = get_id d in + let hyp = NamedDecl.get_id d in match occurrences_of_hyp hyp occs with | NoOccurrences, InHyp -> (push_named_context_val d sign,depdecls) @@ -1630,7 +1634,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = replace_term_occ_modulo occ test mkvarid concl in let lastlhyp = - if List.is_empty depdecls then None else Some (get_id (List.last depdecls)) in + if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in let res = match out test with | None -> None | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma)) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index e281f22df..75159bf8b 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -17,6 +17,9 @@ open Reduction open Vm open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (*******************************************) (* Calcul de la forme normal d'un terme *) (*******************************************) @@ -207,12 +210,11 @@ and constr_type_of_idkey env (idkey : Vars.id_key) stk = in nf_univ_args ~nb_univs mk env stk | VarKey id -> - let open Context.Named.Declaration in - let ty = get_type (lookup_named id env) in + let ty = NamedDecl.get_type (lookup_named id env) in nf_stk env (mkVar id) ty stk | RelKey i -> let n = (nb_rel env - i) in - let ty = get_type (lookup_rel n env) in + let ty = RelDecl.get_type (lookup_rel n env) in nf_stk env (mkRel n) (lift n ty) stk and nf_stk ?from:(from=0) env c t stk = diff --git a/printing/genprint.ml b/printing/genprint.ml index 0ec35e07b..6505a8f82 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -9,15 +9,17 @@ open Pp open Genarg -type ('raw, 'glb, 'top) printer = { - raw : 'raw -> std_ppcmds; - glb : 'glb -> std_ppcmds; - top : 'top -> std_ppcmds; +type 'a printer = 'a -> std_ppcmds + +type ('raw, 'glb, 'top) genprinter = { + raw : 'raw printer; + glb : 'glb printer; + top : 'top printer; } module PrintObj = struct - type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) printer + type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) genprinter let name = "printer" let default wit = match wit with | ExtraArg tag -> diff --git a/printing/genprint.mli b/printing/genprint.mli index 6e6626f2f..5381fc5bd 100644 --- a/printing/genprint.mli +++ b/printing/genprint.mli @@ -11,6 +11,8 @@ open Pp open Genarg +type 'a printer = 'a -> std_ppcmds + val raw_print : ('raw, 'glb, 'top) genarg_type -> 'raw -> std_ppcmds (** Printer for raw level generic arguments. *) @@ -20,9 +22,9 @@ val glb_print : ('raw, 'glb, 'top) genarg_type -> 'glb -> std_ppcmds val top_print : ('raw, 'glb, 'top) genarg_type -> 'top -> std_ppcmds (** Printer for top level generic arguments. *) -val generic_raw_print : rlevel generic_argument -> std_ppcmds -val generic_glb_print : glevel generic_argument -> std_ppcmds -val generic_top_print : tlevel generic_argument -> std_ppcmds +val generic_raw_print : rlevel generic_argument printer +val generic_glb_print : glevel generic_argument printer +val generic_top_print : tlevel generic_argument printer val register_print0 : ('raw, 'glb, 'top) genarg_type -> - ('raw -> std_ppcmds) -> ('glb -> std_ppcmds) -> ('top -> std_ppcmds) -> unit + 'raw printer -> 'glb printer -> 'top printer -> unit diff --git a/printing/miscprint.ml b/printing/miscprint.ml index 7b2c5695f..360843711 100644 --- a/printing/miscprint.ml +++ b/printing/miscprint.ml @@ -28,7 +28,7 @@ and pr_intro_pattern_action prc = function | IntroInjection pl -> str "[=" ++ hv 0 (prlist_with_sep spc (pr_intro_pattern prc) pl) ++ str "]" - | IntroApplyOn (c,pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c + | IntroApplyOn ((_,c),pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c | IntroRewrite true -> str "->" | IntroRewrite false -> str "<-" diff --git a/printing/ppannotation.ml b/printing/ppannotation.ml deleted file mode 100644 index 511f93569..000000000 --- a/printing/ppannotation.ml +++ /dev/null @@ -1,39 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Ppextend -open Constrexpr -open Vernacexpr -open Tacexpr - -type t = - | AKeyword - | AUnparsing of unparsing - | AConstrExpr of constr_expr - | AVernac of vernac_expr - | AGlobTacticExpr of glob_tactic_expr - | AGlobAtomicTacticExpr of glob_atomic_tactic_expr - | ARawTacticExpr of raw_tactic_expr - | ARawAtomicTacticExpr of raw_atomic_tactic_expr - | AAtomicTacticExpr of atomic_tactic_expr - -let tag_of_annotation = function - | AKeyword -> "keyword" - | AUnparsing _ -> "unparsing" - | AConstrExpr _ -> "constr_expr" - | AVernac _ -> "vernac_expr" - | AGlobTacticExpr _ -> "glob_tactic_expr" - | AGlobAtomicTacticExpr _ -> "glob_atomic_tactic_expr" - | ARawTacticExpr _ -> "raw_tactic_expr" - | ARawAtomicTacticExpr _ -> "raw_atomic_tactic_expr" - | AAtomicTacticExpr _ -> "atomic_tactic_expr" - -let attributes_of_annotation a = - [] - -let tag = Pp.Tag.create "ppannotation" diff --git a/printing/ppannotation.mli b/printing/ppannotation.mli deleted file mode 100644 index a0fef1a75..000000000 --- a/printing/ppannotation.mli +++ /dev/null @@ -1,32 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** This module defines the annotations that are attached to - semi-structured pretty-printing of Coq syntactic objects. *) - -open Ppextend -open Constrexpr -open Vernacexpr -open Tacexpr - -type t = - | AKeyword - | AUnparsing of unparsing - | AConstrExpr of constr_expr - | AVernac of vernac_expr - | AGlobTacticExpr of glob_tactic_expr - | AGlobAtomicTacticExpr of glob_atomic_tactic_expr - | ARawTacticExpr of raw_tactic_expr - | ARawAtomicTacticExpr of raw_atomic_tactic_expr - | AAtomicTacticExpr of atomic_tactic_expr - -val tag_of_annotation : t -> string - -val attributes_of_annotation : t -> (string * string) list - -val tag : t Pp.Tag.key diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 80ddd669f..d92d83275 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -21,18 +21,31 @@ open Decl_kinds open Misctypes (*i*) -module Make (Taggers : sig - val tag_keyword : std_ppcmds -> std_ppcmds - val tag_evar : std_ppcmds -> std_ppcmds - val tag_type : std_ppcmds -> std_ppcmds - val tag_path : std_ppcmds -> std_ppcmds - val tag_ref : std_ppcmds -> std_ppcmds - val tag_var : std_ppcmds -> std_ppcmds - val tag_constr_expr : constr_expr -> std_ppcmds -> std_ppcmds - val tag_unparsing : unparsing -> std_ppcmds -> std_ppcmds -end) = struct - - open Taggers +module Tag = +struct + let keyword = "constr.keyword" + let evar = "constr.evar" + let univ = "constr.type" + let notation = "constr.notation" + let variable = "constr.variable" + let reference = "constr.reference" + let path = "constr.path" + +end + +let do_not_tag _ x = x +let tag t s = Pp.tag t s +let tag_keyword = tag Tag.keyword +let tag_evar = tag Tag.evar +let tag_type = tag Tag.univ +let tag_unparsing = function +| UnpTerminal s -> tag Tag.notation +| _ -> do_not_tag () +let tag_constr_expr = do_not_tag +let tag_path = tag Tag.path +let tag_ref = tag Tag.reference +let tag_var = tag Tag.variable + let keyword s = tag_keyword (str s) let sep_v = fun _ -> str"," ++ spc() @@ -764,86 +777,3 @@ end) = struct let pr_binders = pr_undelimited_binders spc (pr ltop) -end - -module Tag = -struct - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["constr"; "keyword"] - - let evar = - let style = Terminal.make ~fg_color:`LIGHT_BLUE () in - Ppstyle.make ~style ["constr"; "evar"] - - let univ = - let style = Terminal.make ~bold:true ~fg_color:`YELLOW () in - Ppstyle.make ~style ["constr"; "type"] - - let notation = - let style = Terminal.make ~fg_color:`WHITE () in - Ppstyle.make ~style ["constr"; "notation"] - - let variable = - Ppstyle.make ["constr"; "variable"] - - let reference = - let style = Terminal.make ~fg_color:`LIGHT_GREEN () in - Ppstyle.make ~style ["constr"; "reference"] - - let path = - let style = Terminal.make ~fg_color:`LIGHT_MAGENTA () in - Ppstyle.make ~style ["constr"; "path"] - -end - -let do_not_tag _ x = x - -let split_token tag s = - let len = String.length s in - let rec parse_string off i = - if Int.equal i len then - if Int.equal off i then mt () else tag (str (String.sub s off (i - off))) - else if s.[i] == ' ' then - if Int.equal off i then parse_space 1 (succ i) - else tag (str (String.sub s off (i - off))) ++ parse_space 1 (succ i) - else parse_string off (succ i) - and parse_space spc i = - if Int.equal i len then str (String.make spc ' ') - else if s.[i] == ' ' then parse_space (succ spc) (succ i) - else str (String.make spc ' ') ++ parse_string i (succ i) - in - parse_string 0 0 - -(** Instantiating Make with tagging functions that only add style - information. *) -include Make (struct - let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s - let tag_keyword = tag Tag.keyword - let tag_evar = tag Tag.evar - let tag_type = tag Tag.univ - let tag_unparsing = function - | UnpTerminal s -> fun _ -> split_token (fun pp -> tag Tag.notation pp) s - | _ -> do_not_tag () - let tag_constr_expr = do_not_tag - let tag_path = tag Tag.path - let tag_ref = tag Tag.reference - let tag_var = tag Tag.variable -end) - -module Richpp = struct - - include Make (struct - open Ppannotation - let tag_keyword = Pp.tag (Pp.Tag.inj AKeyword tag) - let tag_type = Pp.tag (Pp.Tag.inj AKeyword tag) - let tag_evar = do_not_tag () - let tag_unparsing unp = Pp.tag (Pp.Tag.inj (AUnparsing unp) tag) - let tag_constr_expr e = Pp.tag (Pp.Tag.inj (AConstrExpr e) tag) - let tag_path = do_not_tag () - let tag_ref = do_not_tag () - let tag_var = do_not_tag () - end) - -end - diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 0241633c6..a0106837a 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -11,11 +11,85 @@ (** The default pretty-printers produce {!Pp.std_ppcmds} that are interpreted as raw strings. *) -include Ppconstrsig.Pp +open Loc +open Pp +open Libnames +open Constrexpr +open Names +open Misctypes -(** The rich pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as annotated strings. The annotations can be - retrieved using {!RichPp.rich_pp}. Their definitions are - located in {!Ppannotation.t}. *) +val extract_lam_binders : + constr_expr -> local_binder list * constr_expr +val extract_prod_binders : + constr_expr -> local_binder list * constr_expr +val split_fix : + int -> constr_expr -> constr_expr -> + local_binder list * constr_expr * constr_expr -module Richpp : Ppconstrsig.Pp +val prec_less : int -> int * Ppextend.parenRelation -> bool + +val pr_tight_coma : unit -> std_ppcmds + +val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds + +val pr_lident : Id.t located -> std_ppcmds +val pr_lname : Name.t located -> std_ppcmds + +val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds +val pr_com_at : int -> std_ppcmds +val pr_sep_com : + (unit -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + constr_expr -> std_ppcmds + +val pr_id : Id.t -> std_ppcmds +val pr_name : Name.t -> std_ppcmds +val pr_qualid : qualid -> std_ppcmds +val pr_patvar : patvar -> std_ppcmds + +val pr_glob_level : glob_level -> std_ppcmds +val pr_glob_sort : glob_sort -> std_ppcmds +val pr_guard_annot : (constr_expr -> std_ppcmds) -> + local_binder list -> + ('a * Names.Id.t) option * recursion_order_expr -> + std_ppcmds + +val pr_record_body : (reference * constr_expr) list -> std_ppcmds +val pr_binders : local_binder list -> std_ppcmds +val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds +val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds +val pr_constr_expr : constr_expr -> std_ppcmds +val pr_lconstr_expr : constr_expr -> std_ppcmds +val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds + +type term_pr = { + pr_constr_expr : constr_expr -> std_ppcmds; + pr_lconstr_expr : constr_expr -> std_ppcmds; + pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; + pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds +} + +val set_term_pr : term_pr -> unit +val default_term_pr : term_pr + +(* The modular constr printer. + [modular_constr_pr pr s p t] prints the head of the term [t] and calls + [pr] on its subterms. + [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers + and [ltop] for "lconstr" printers (spiwack: we might need more + specification here). + We can make a new modular constr printer by overriding certain branches, + for instance if we want to build a printer which prints "Prop" as "Omega" + instead we can proceed as follows: + let my_modular_constr_pr pr s p = function + | CSort (_,GProp Null) -> str "Omega" + | t -> modular_constr_pr pr s p t + Which has the same type. We can turn a modular printer into a printer by + taking its fixpoint. *) + +type precedence +val lsimpleconstr : precedence +val ltop : precedence +val modular_constr_pr : + ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) -> + (unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli deleted file mode 100644 index 3de0d805c..000000000 --- a/printing/ppconstrsig.mli +++ /dev/null @@ -1,95 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Loc -open Pp -open Libnames -open Constrexpr -open Names -open Misctypes - -module type Pp = sig - - val extract_lam_binders : - constr_expr -> local_binder list * constr_expr - val extract_prod_binders : - constr_expr -> local_binder list * constr_expr - val split_fix : - int -> constr_expr -> constr_expr -> - local_binder list * constr_expr * constr_expr - - val prec_less : int -> int * Ppextend.parenRelation -> bool - - val pr_tight_coma : unit -> std_ppcmds - - val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds - - val pr_lident : Id.t located -> std_ppcmds - val pr_lname : Name.t located -> std_ppcmds - - val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds - val pr_com_at : int -> std_ppcmds - val pr_sep_com : - (unit -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - constr_expr -> std_ppcmds - - val pr_id : Id.t -> std_ppcmds - val pr_name : Name.t -> std_ppcmds - val pr_qualid : qualid -> std_ppcmds - val pr_patvar : patvar -> std_ppcmds - - val pr_glob_level : glob_level -> std_ppcmds - val pr_glob_sort : glob_sort -> std_ppcmds - val pr_guard_annot : (constr_expr -> std_ppcmds) -> - local_binder list -> - ('a * Names.Id.t) option * recursion_order_expr -> - std_ppcmds - - val pr_record_body : (reference * constr_expr) list -> std_ppcmds - val pr_binders : local_binder list -> std_ppcmds - val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds - val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds - val pr_constr_expr : constr_expr -> std_ppcmds - val pr_lconstr_expr : constr_expr -> std_ppcmds - val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds - - type term_pr = { - pr_constr_expr : constr_expr -> std_ppcmds; - pr_lconstr_expr : constr_expr -> std_ppcmds; - pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds; - pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds - } - - val set_term_pr : term_pr -> unit - val default_term_pr : term_pr - -(** The modular constr printer. - [modular_constr_pr pr s p t] prints the head of the term [t] and calls - [pr] on its subterms. - [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers - and [ltop] for "lconstr" printers (spiwack: we might need more - specification here). - We can make a new modular constr printer by overriding certain branches, - for instance if we want to build a printer which prints "Prop" as "Omega" - instead we can proceed as follows: - let my_modular_constr_pr pr s p = function - | CSort (_,GProp Null) -> str "Omega" - | t -> modular_constr_pr pr s p t - Which has the same type. We can turn a modular printer into a printer by - taking its fixpoint. *) - - type precedence - val lsimpleconstr : precedence - val ltop : precedence - val modular_constr_pr : - ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) -> - (unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds - -end - diff --git a/printing/pptactic.mli b/printing/pptactic.mli deleted file mode 100644 index 86e3ea548..000000000 --- a/printing/pptactic.mli +++ /dev/null @@ -1,67 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** This module implements pretty-printers for tactic_expr syntactic - objects and their subcomponents. *) - -open Pp -open Genarg -open Geninterp -open Names -open Constrexpr -open Tacexpr -open Ppextend - -type 'a grammar_tactic_prod_item_expr = -| TacTerm of string -| TacNonTerm of Loc.t * 'a * Names.Id.t - -type 'a raw_extra_genarg_printer = - (constr_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - -type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> std_ppcmds) -> - (glob_constr_and_expr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - 'a -> std_ppcmds - -type 'a extra_genarg_printer = - (Term.constr -> std_ppcmds) -> - (Term.constr -> std_ppcmds) -> - (tolerability -> Val.t -> std_ppcmds) -> - 'a -> std_ppcmds - -val declare_extra_genarg_pprule : - ('a, 'b, 'c) genarg_type -> - 'a raw_extra_genarg_printer -> - 'b glob_extra_genarg_printer -> - 'c extra_genarg_printer -> unit - -type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list - -type pp_tactic = { - pptac_level : int; - pptac_prods : grammar_terminals; -} - -val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit - -(** The default pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as raw strings. *) -include Pptacticsig.Pp - -(** The rich pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as annotated strings. The annotations can be - retrieved using {!RichPp.rich_pp}. Their definitions are - located in {!Ppannotation.t}. *) -module Richpp : Pptacticsig.Pp - -val ltop : tolerability diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli deleted file mode 100644 index 665e055f2..000000000 --- a/printing/pptacticsig.mli +++ /dev/null @@ -1,83 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Pp -open Genarg -open Geninterp -open Tacexpr -open Ppextend -open Environ -open Misctypes - -module type Pp = sig - - val pr_with_occurrences : - ('a -> std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds - val pr_red_expr : - ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> - ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds - val pr_may_eval : - ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds - - val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds - val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds - val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds - - val pr_in_clause : - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - - val pr_clauses : bool option -> - ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - - val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds - - val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds - - val pr_raw_extend: env -> int -> - ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds - - val pr_glob_extend: env -> int -> - ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds - - val pr_extend : - (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds - - val pr_alias_key : Names.KerName.t -> std_ppcmds - - val pr_alias : (Val.t -> std_ppcmds) -> - int -> Names.KerName.t -> Val.t list -> std_ppcmds - - val pr_alias_key : Names.KerName.t -> std_ppcmds - - val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds - - val pr_raw_tactic : raw_tactic_expr -> std_ppcmds - - val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds - - val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds - - val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds - - val pr_hintbases : string list option -> std_ppcmds - - val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds - - val pr_bindings : - ('constr -> std_ppcmds) -> - ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds - - val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds - - val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('b, 'a) match_rule -> std_ppcmds - - val pr_value : tolerability -> Val.t -> std_ppcmds - -end diff --git a/printing/pputils.ml b/printing/pputils.ml index 50ce56fb0..50630fb9b 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -6,7 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Util open Pp +open Genarg +open Nameops +open Misctypes +open Locus +open Genredexpr let pr_located pr (loc, x) = if !Flags.beautify && loc <> Loc.ghost then @@ -17,3 +23,130 @@ let pr_located pr (loc, x) = let after = Pp.comment (CLexer.extract_comments e) in before ++ x ++ after else pr x + +let pr_or_var pr = function + | ArgArg x -> pr x + | ArgVar (_,s) -> pr_id s + +let pr_with_occurrences pr keyword (occs,c) = + match occs with + | AllOccurrences -> + pr c + | NoOccurrences -> + failwith "pr_with_occurrences: no occurrences" + | OnlyOccurrences nl -> + hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++ + hov 0 (prlist_with_sep spc (pr_or_var int) nl)) + | AllOccurrencesBut nl -> + hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++ + hov 0 (prlist_with_sep spc (pr_or_var int) nl)) + +exception ComplexRedFlag + +let pr_short_red_flag pr r = + if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then + raise ComplexRedFlag + else if List.is_empty r.rConst then + if r.rDelta then mt () else raise ComplexRedFlag + else (if r.rDelta then str "-" else mt ()) ++ + hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]") + +let pr_red_flag pr r = + try pr_short_red_flag pr r + with complexRedFlags -> + (if r.rBeta then pr_arg str "beta" else mt ()) ++ + (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else + (if r.rMatch then pr_arg str "match" else mt ()) ++ + (if r.rFix then pr_arg str "fix" else mt ()) ++ + (if r.rCofix then pr_arg str "cofix" else mt ())) ++ + (if r.rZeta then pr_arg str "zeta" else mt ()) ++ + (if List.is_empty r.rConst then + if r.rDelta then pr_arg str "delta" + else mt () + else + pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++ + hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) + +let pr_union pr1 pr2 = function + | Inl a -> pr1 a + | Inr b -> pr2 b + +let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function + | Red false -> keyword "red" + | Hnf -> keyword "hnf" + | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f) + ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + | Cbv f -> + if f.rBeta && f.rMatch && f.rFix && f.rCofix && + f.rZeta && f.rDelta && List.is_empty f.rConst then + keyword "compute" + else + hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f) + | Lazy f -> + hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f) + | Cbn f -> + hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f) + | Unfold l -> + hov 1 (keyword "unfold" ++ spc() ++ + prlist_with_sep pr_comma (pr_with_occurrences pr_ref keyword) l) + | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l) + | Pattern l -> + hov 1 (keyword "pattern" ++ + pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr keyword)) l) + + | Red true -> + CErrors.error "Shouldn't be accessible from user." + | ExtraRedExpr s -> + str s + | CbvVm o -> + keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + | CbvNative o -> + keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + +let pr_or_by_notation f = function + | AN v -> f v + | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + +let hov_if_not_empty n p = if Pp.ismt p then p else hov n p + +let rec pr_raw_generic env (GenArg (Rawwit wit, x)) = + match wit with + | ListArg wit -> + let map x = pr_raw_generic env (in_gen (rawwit wit) x) in + let ans = pr_sequence map x in + hov_if_not_empty 0 ans + | OptArg wit -> + let ans = match x with + | None -> mt () + | Some x -> pr_raw_generic env (in_gen (rawwit wit) x) + in + hov_if_not_empty 0 ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = in_gen (rawwit wit1) p in + let q = in_gen (rawwit wit2) q in + hov_if_not_empty 0 (pr_sequence (pr_raw_generic env) [p; q]) + | ExtraArg s -> + Genprint.generic_raw_print (in_gen (rawwit wit) x) + + +let rec pr_glb_generic env (GenArg (Glbwit wit, x)) = + match wit with + | ListArg wit -> + let map x = pr_glb_generic env (in_gen (glbwit wit) x) in + let ans = pr_sequence map x in + hov_if_not_empty 0 ans + | OptArg wit -> + let ans = match x with + | None -> mt () + | Some x -> pr_glb_generic env (in_gen (glbwit wit) x) + in + hov_if_not_empty 0 ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = in_gen (glbwit wit1) p in + let q = in_gen (glbwit wit2) q in + let ans = pr_sequence (pr_glb_generic env) [p; q] in + hov_if_not_empty 0 ans + | ExtraArg s -> + Genprint.generic_glb_print (in_gen (glbwit wit) x) diff --git a/printing/pputils.mli b/printing/pputils.mli index a0f2c7728..b236fed70 100644 --- a/printing/pputils.mli +++ b/printing/pputils.mli @@ -7,7 +7,25 @@ (************************************************************************) open Pp +open Genarg +open Misctypes +open Locus +open Genredexpr val pr_located : ('a -> std_ppcmds) -> 'a Loc.located -> std_ppcmds (** Prints an object surrounded by its commented location *) +val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds +val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds +val pr_with_occurrences : + ('a -> std_ppcmds) -> (string -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds + +val pr_short_red_flag : ('a -> std_ppcmds) -> 'a glob_red_flag -> std_ppcmds +val pr_red_flag : ('a -> std_ppcmds) -> 'a glob_red_flag -> std_ppcmds +val pr_red_expr : + ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> + (string -> std_ppcmds) -> + ('a,'b,'c) red_expr_gen -> std_ppcmds + +val pr_raw_generic : Environ.env -> rlevel generic_argument -> std_ppcmds +val pr_glb_generic : Environ.env -> glevel generic_argument -> std_ppcmds diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 5d6d36d56..78ef4d4ba 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -19,18 +19,11 @@ open Constrexpr open Constrexpr_ops open Decl_kinds -module Make - (Ppconstr : Ppconstrsig.Pp) - (Pptactic : Pptacticsig.Pp) - (Taggers : sig - val tag_keyword : std_ppcmds -> std_ppcmds - val tag_vernac : vernac_expr -> std_ppcmds -> std_ppcmds - end) -= struct - - open Taggers open Ppconstr - open Pptactic + + let do_not_tag _ x = x + let tag_keyword = do_not_tag () + let tag_vernac = do_not_tag let keyword s = tag_keyword (str s) @@ -67,7 +60,7 @@ module Make | (loc,Name id) -> pr_lident (loc,id) | lna -> pr_located pr_name lna - let pr_smart_global = pr_or_by_notation pr_reference + let pr_smart_global = Pputils.pr_or_by_notation pr_reference let pr_ltac_ref = Libnames.pr_reference @@ -81,7 +74,7 @@ module Make | VernacEndSubproof -> str"" | _ -> str"." - let pr_gen t = pr_raw_generic (Global.env ()) t + let pr_gen t = Pputils.pr_raw_generic (Global.env ()) t let sep = fun _ -> spc() let sep_v2 = fun _ -> str"," ++ spc() @@ -198,7 +191,7 @@ module Make | HintsExtern (n,c,tac) -> let pat = match c with None -> mt () | Some pat -> pr_pat pat in keyword "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++ - spc() ++ pr_raw_tactic tac + spc() ++ Pputils.pr_raw_generic (Global.env ()) tac in hov 2 (keyword "Hint "++ pph ++ opth) @@ -528,7 +521,7 @@ module Make let pr_using e = str (Proof_using.to_string e) let rec pr_vernac_body v = - let return = Taggers.tag_vernac v in + let return = tag_vernac v in match v with | VernacPolymorphic (poly, v) -> let s = if poly then keyword "Polymorphic" else keyword "Monomorphic" in @@ -706,7 +699,7 @@ module Make | None -> mt() | Some r -> keyword "Eval" ++ spc() ++ - pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) r ++ + pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ keyword " in" ++ spc() in let pr_def_body = function @@ -1153,7 +1146,7 @@ module Make let pr_mayeval r c = match r with | Some r0 -> hov 2 (keyword "Eval" ++ spc() ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r0 ++ + pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ spc() ++ keyword "in" ++ spc () ++ pr_lconstr c) | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c) in @@ -1164,7 +1157,7 @@ module Make | VernacDeclareReduction (s,r) -> return ( keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r + pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r ) | VernacPrint p -> return (pr_printable p) @@ -1205,12 +1198,12 @@ module Make return (keyword "Proof " ++ spc () ++ keyword "using" ++ spc() ++ pr_using e) | VernacProof (Some te, None) -> - return (keyword "Proof with" ++ spc() ++ pr_raw_tactic te) + return (keyword "Proof with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te) | VernacProof (Some te, Some e) -> return ( keyword "Proof" ++ spc () ++ keyword "using" ++ spc() ++ pr_using e ++ spc() ++ - keyword "with" ++ spc() ++pr_raw_tactic te + keyword "with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te ) | VernacProofMode s -> return (keyword "Proof Mode" ++ str s) @@ -1246,24 +1239,3 @@ module Make let pr_vernac v = try pr_vernac_body v ++ sep_end v with e -> CErrors.print e - -end - -include Make (Ppconstr) (Pptactic) (struct - let do_not_tag _ x = x - let tag_keyword = do_not_tag () - let tag_vernac = do_not_tag -end) - -module Richpp = struct - - include Make - (Ppconstr.Richpp) - (Pptactic.Richpp) - (struct - open Ppannotation - let tag_keyword s = Pp.tag (Pp.Tag.inj AKeyword tag) s - let tag_vernac v s = Pp.tag (Pp.Tag.inj (AVernac v) tag) s - end) - -end diff --git a/printing/ppvernac.mli b/printing/ppvernac.mli index d3d4a5ceb..836b05e0e 100644 --- a/printing/ppvernac.mli +++ b/printing/ppvernac.mli @@ -9,12 +9,11 @@ (** This module implements pretty-printers for vernac_expr syntactic objects and their subcomponents. *) -(** The default pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as raw strings. *) -include Ppvernacsig.Pp +(** Prints a fixpoint body *) +val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds -(** The rich pretty-printers produce {!Pp.std_ppcmds} that are - interpreted as annotated strings. The annotations can be - retrieved using {!RichPp.rich_pp}. Their definitions are - located in {!Ppannotation.t}. *) -module Richpp : Ppvernacsig.Pp +(** Prints a vernac expression *) +val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds + +(** Prints a vernac expression and closes it with a dot. *) +val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds diff --git a/printing/prettyp.ml b/printing/prettyp.ml index e117f1dcb..8fabb7053 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -27,6 +27,10 @@ open Recordops open Misctypes open Printer open Printmod +open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration type object_pr = { print_inductive : mutual_inductive -> std_ppcmds; @@ -132,7 +136,6 @@ let print_renames_list prefix l = let need_expansion impl ref = let typ = Global.type_of_global_unsafe ref in let ctx = prod_assum typ in - let open Context.Rel.Declaration in let nprods = List.count is_local_assum ctx in not (List.is_empty impl) && List.length impl >= nprods && let _,lastimpl = List.chop nprods impl in @@ -170,9 +173,8 @@ type opacity = | TransparentMaybeOpacified of Conv_oracle.level let opacity env = - let open Context.Named.Declaration in function - | VarRef v when is_local_def (Environ.lookup_named v env) -> + | VarRef v when NamedDecl.is_local_def (Environ.lookup_named v env) -> Some(TransparentMaybeOpacified (Conv_oracle.get_strategy (Environ.oracle env) (VarKey v))) | ConstRef cst -> @@ -700,7 +702,7 @@ let read_sec_context r = let dir = try Nametab.locate_section qid with Not_found -> - user_err_loc (loc,"read_sec_context", str "Unknown section.") in + user_err ~loc ~hdr:"read_sec_context" (str "Unknown section.") in let rec get_cxt in_cxt = function | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest -> if DirPath.equal dir dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest @@ -733,11 +735,10 @@ let print_any_name = function try (* Var locale de but, pas var de section... donc pas d'implicits *) let dir,str = repr_qualid qid in if not (DirPath.is_empty dir) then raise Not_found; - let open Context.Named.Declaration in - str |> Global.lookup_named |> set_id str |> print_named_decl + str |> Global.lookup_named |> NamedDecl.set_id str |> print_named_decl with Not_found -> - errorlabstrm - "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") + user_err + ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") let print_name = function | ByNotation (loc,ntn,sc) -> @@ -762,8 +763,7 @@ let print_opaque_name qid = let ty = Universes.unsafe_type_of_global gr in print_typed_value (mkConstruct cstr, ty) | VarRef id -> - let open Context.Named.Declaration in - lookup_named id env |> set_id id |> print_named_decl + env |> lookup_named id |> NamedDecl.set_id id |> print_named_decl let print_about_any loc k = match k with @@ -831,7 +831,7 @@ let index_of_class cl = try fst (class_info cl) with Not_found -> - errorlabstrm "index_of_class" + user_err ~hdr:"index_of_class" (pr_class cl ++ spc() ++ str "not a defined class.") let print_path_between cls clt = @@ -841,7 +841,7 @@ let print_path_between cls clt = try lookup_path_between_class (i,j) with Not_found -> - errorlabstrm "index_cl_of_id" + user_err ~hdr:"index_cl_of_id" (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt ++ str ".") in diff --git a/printing/printer.ml b/printing/printer.ml index 04337f6be..5e7e9ce54 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -22,6 +22,10 @@ open Constrextern open Ppconstr open Declarations +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration +module CompactedDecl = Context.Compacted.Declaration + let emacs_str s = if !Flags.print_emacs then s else "" let delayed_emacs_cmd s = @@ -248,31 +252,30 @@ let pr_pattern t = pr_pattern_env (Global.env()) empty_names_context t*) (**********************************************************************) (* Contexts and declarations *) -let pr_var_decl_skel pr_id env sigma (id,c,typ) = - let pbody = match c with - | None -> (mt ()) - | Some c -> - (* Force evaluation *) - let pb = pr_lconstr_env env sigma c in - let pb = if isCast c then surround pb else pb in - (str" := " ++ pb ++ cut () ) in +let pr_compacted_decl env sigma decl = + let ids, pbody, typ = match decl with + | CompactedDecl.LocalAssum (ids, typ) -> + ids, mt (), typ + | CompactedDecl.LocalDef (ids,c,typ) -> + (* Force evaluation *) + let pb = pr_lconstr_env env sigma c in + let pb = if isCast c then surround pb else pb in + ids, (str" := " ++ pb ++ cut ()), typ + in + let pids = prlist_with_sep pr_comma pr_id ids in let pt = pr_ltype_env env sigma typ in let ptyp = (str" : " ++ pt) in - (pr_id id ++ hov 0 (pbody ++ ptyp)) - -let pr_var_decl env sigma d = - pr_var_decl_skel pr_id env sigma (Context.Named.Declaration.to_tuple d) + hov 0 (pids ++ pbody ++ ptyp) -let pr_var_list_decl env sigma (l,c,typ) = - hov 0 (pr_var_decl_skel (fun ids -> prlist_with_sep pr_comma pr_id ids) env sigma (l,c,typ)) +let pr_named_decl env sigma decl = + decl |> CompactedDecl.of_named_decl |> pr_compacted_decl env sigma let pr_rel_decl env sigma decl = - let open Context.Rel.Declaration in - let na = get_name decl in - let typ = get_type decl in + let na = RelDecl.get_name decl in + let typ = RelDecl.get_type decl in let pbody = match decl with - | LocalAssum _ -> mt () - | LocalDef (_,c,_) -> + | RelDecl.LocalAssum _ -> mt () + | RelDecl.LocalDef (_,c,_) -> (* Force evaluation *) let pb = pr_lconstr_env env sigma c in let pb = if isCast c then surround pb else pb in @@ -289,13 +292,16 @@ let pr_rel_decl env sigma decl = (* Prints a signature, all declarations on the same line if possible *) let pr_named_context_of env sigma = - let make_decl_list env d pps = pr_var_decl env sigma d :: pps in + let make_decl_list env d pps = pr_named_decl env sigma d :: pps in let psl = List.rev (fold_named_context make_decl_list env ~init:[]) in hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl) +let pr_var_list_decl env sigma decl = + hov 0 (pr_compacted_decl env sigma decl) + let pr_named_context env sigma ne_context = hv 0 (Context.Named.fold_outside - (fun d pps -> pps ++ ws 2 ++ pr_var_decl env sigma d) + (fun d pps -> pps ++ ws 2 ++ pr_named_decl env sigma d) ne_context ~init:(mt ())) let pr_rel_context env sigma rel_context = @@ -307,9 +313,9 @@ let pr_rel_context_of env sigma = (* Prints an env (variables and de Bruijn). Separator: newline *) let pr_context_unlimited env sigma = let sign_env = - Context.NamedList.fold + Context.Compacted.fold (fun d pps -> - let pidt = pr_var_list_decl env sigma d in + let pidt = pr_compacted_decl env sigma d in (pps ++ fnl () ++ pidt)) (Termops.compact_named_context (named_context env)) ~init:(mt ()) in @@ -326,39 +332,43 @@ let pr_ne_context_of header env sigma = List.is_empty (Environ.named_context env) then (mt ()) else let penv = pr_context_unlimited env sigma in (header ++ penv ++ fnl ()) -let pr_context_limit n env sigma = - let named_context = Environ.named_context env in - let lgsign = List.length named_context in - if n >= lgsign then - pr_context_unlimited env sigma - else - let k = lgsign-n in - let _,sign_env = - Context.NamedList.fold - (fun d (i,pps) -> - if i < k then - (i+1, (pps ++str ".")) - else - let pidt = pr_var_list_decl env sigma d in - (i+1, (pps ++ fnl () ++ - str (emacs_str "") ++ - pidt))) - (Termops.compact_named_context (Environ.named_context env)) ~init:(0,(mt ())) - in - let db_env = - fold_rel_context - (fun env d pps -> - let pnat = pr_rel_decl env sigma d in - (pps ++ fnl () ++ - str (emacs_str "") ++ - pnat)) - env ~init:(mt ()) - in - (sign_env ++ db_env) +let rec bld_sign_env env sigma ctxt pps = + match ctxt with + | [] -> pps + | d:: ctxt' -> + let pidt = pr_var_list_decl env sigma d in + let pps' = pps ++ brk (0,0) ++ pidt in + bld_sign_env env sigma ctxt' pps' + + +let pr_context_limit_compact ?n env sigma = + let ctxt = Termops.compact_named_context (named_context env) in + let lgth = List.length ctxt in + let n_capped = + match n with + | None -> lgth + | Some n when n > lgth -> lgth + | Some n -> n in + let ctxt_chopped,ctxt_hidden = Util.List.chop n_capped ctxt in + (* a dot line hinting the number of hiden hyps. *) + let hidden_dots = String.make (List.length ctxt_hidden) '.' in + let sign_env = v 0 (str hidden_dots ++ (mt ()) + ++ bld_sign_env env sigma (List.rev ctxt_chopped) (mt ())) in + let db_env = + fold_rel_context + (fun env d pps -> pps ++ fnl () ++ pr_rel_decl env sigma d) + env ~init:(mt ()) in + (sign_env ++ db_env) + +(* compact printing an env (variables and de Bruijn). Separator: three + spaces between simple hyps, and newline otherwise *) +let pr_context_unlimited_compact env sigma = + pr_context_limit_compact env sigma -let pr_context_of env sigma = match Flags.print_hyps_limit () with - | None -> hv 0 (pr_context_unlimited env sigma) - | Some n -> hv 0 (pr_context_limit n env sigma) +let pr_context_of env sigma = + match Flags.print_hyps_limit () with + | None -> hv 0 (pr_context_limit_compact env sigma) + | Some n -> hv 0 (pr_context_limit_compact ~n env sigma) (* display goal parts (Proof mode) *) @@ -417,8 +427,7 @@ let pr_evgl_sign sigma evi = | None -> [], [] | Some f -> List.filter2 (fun b c -> not b) f (evar_context evi) in - let open Context.Named.Declaration in - let ids = List.rev_map get_id l in + let ids = List.rev_map NamedDecl.get_id l in let warn = if List.is_empty ids then mt () else (str "(" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)") @@ -713,7 +722,7 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = let end_cmd = str "This subproof is complete, but there are some unfocused goals." ++ (let s = Proof_global.Bullet.suggest p in - if Pp.is_empty s then s else fnl () ++ s) ++ + if Pp.ismt s then s else fnl () ++ s) ++ fnl () in pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] bgoals diff --git a/printing/printer.mli b/printing/printer.mli index 695ab33b2..20032012a 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -108,8 +108,8 @@ val pr_pconstructor : env -> pconstructor -> std_ppcmds val pr_context_unlimited : env -> evar_map -> std_ppcmds val pr_ne_context_of : std_ppcmds -> env -> evar_map -> std_ppcmds -val pr_var_decl : env -> evar_map -> Context.Named.Declaration.t -> std_ppcmds -val pr_var_list_decl : env -> evar_map -> Context.NamedList.Declaration.t -> std_ppcmds +val pr_named_decl : env -> evar_map -> Context.Named.Declaration.t -> std_ppcmds +val pr_compacted_decl : env -> evar_map -> Context.Compacted.Declaration.t -> std_ppcmds val pr_rel_decl : env -> evar_map -> Context.Rel.Declaration.t -> std_ppcmds val pr_named_context : env -> evar_map -> Context.Named.t -> std_ppcmds diff --git a/printing/printing.mllib b/printing/printing.mllib index bc8f0750e..86b68d8fb 100644 --- a/printing/printing.mllib +++ b/printing/printing.mllib @@ -1,9 +1,7 @@ Genprint Pputils -Ppannotation Ppconstr Printer -Pptactic Printmod Prettyp Ppvernac diff --git a/printing/printmod.ml b/printing/printmod.ml index dfa66d437..baa1b8d79 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -26,6 +26,18 @@ open Goptions the "short" mode or (Some env) in the "rich" one. *) +module Tag = +struct + + let definition = "module.definition" + let keyword = "module.keyword" + +end + +let tag t s = Pp.tag t s +let tag_definition s = tag Tag.definition s +let tag_keyword s = tag Tag.keyword s + let short = ref false let _ = @@ -44,14 +56,8 @@ let mk_fake_top = let r = ref 0 in fun () -> incr r; Id.of_string ("FAKETOP"^(string_of_int !r)) -module Make (Taggers : sig - val tag_definition : std_ppcmds -> std_ppcmds - val tag_keyword : std_ppcmds -> std_ppcmds -end) = -struct - -let def s = Taggers.tag_definition (str s) -let keyword s = Taggers.tag_keyword (str s) +let def s = tag_definition (str s) +let keyword s = tag_keyword (str s) let get_new_id locals id = let rec get_id l id = @@ -397,11 +403,11 @@ let rec printable_body dir = let print_expression' is_type env mp me = States.with_state_protection - (fun e -> eval_ppcmds (print_expression is_type env mp [] e)) me + (fun e -> print_expression is_type env mp [] e) me let print_signature' is_type env mp me = States.with_state_protection - (fun e -> eval_ppcmds (print_signature is_type env mp [] e)) me + (fun e -> print_signature is_type env mp [] e) me let unsafe_print_module env mp with_body mb = let name = print_modpath [] mp in @@ -441,20 +447,4 @@ let print_modtype kn = with e when CErrors.noncritical e -> print_signature' true None kn mtb.mod_type)) -end - -module Tag = -struct - let definition = - let style = Terminal.make ~bold:true ~fg_color:`LIGHT_RED () in - Ppstyle.make ~style ["module"; "definition"] - let keyword = - let style = Terminal.make ~bold:true () in - Ppstyle.make ~style ["module"; "keyword"] -end -include Make(struct - let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s - let tag_definition s = tag Tag.definition s - let tag_keyword s = tag Tag.keyword s -end) diff --git a/printing/printmod.mli b/printing/printmod.mli index 7f7d34392..f3079d5b6 100644 --- a/printing/printmod.mli +++ b/printing/printmod.mli @@ -6,9 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Pp open Names (** false iff the module is an element of an open module type *) val printable_body : DirPath.t -> bool -include Printmodsig.Pp +val pr_mutual_inductive_body : Environ.env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds +val print_module : bool -> module_path -> std_ppcmds +val print_modtype : module_path -> std_ppcmds diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 0a90e0dbd..fad656223 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -155,7 +155,7 @@ let error_incompatible_inst clenv mv = let na = meta_name clenv.evd mv in match na with Name id -> - errorlabstrm "clenv_assign" + user_err ~hdr:"clenv_assign" (str "An incompatible instantiation has already been found for " ++ pr_id id) | _ -> @@ -417,11 +417,11 @@ let qhyp_eq h1 h2 = match h1, h2 with let check_bindings bl = match List.duplicates qhyp_eq (List.map pi2 bl) with | NamedHyp s :: _ -> - errorlabstrm "" + user_err (str "The variable " ++ pr_id s ++ str " occurs more than once in binding list."); | AnonHyp n :: _ -> - errorlabstrm "" + user_err (str "The position " ++ int n ++ str " occurs more than once in binding list.") | [] -> () @@ -435,7 +435,7 @@ let explain_no_such_bound_variable evd id = if na != Anonymous then out_name na :: l else l in let mvl = List.fold_left fold [] (Evd.meta_list evd) in - errorlabstrm "Evd.meta_with_name" + user_err ~hdr:"Evd.meta_with_name" (str"No such bound variable " ++ pr_id id ++ (if mvl == [] then str " (no bound variables at all in the expression)." else @@ -460,7 +460,7 @@ let meta_with_name evd id = | ([n],_|_,[n]) -> n | _ -> - errorlabstrm "Evd.meta_with_name" + user_err ~hdr:"Evd.meta_with_name" (str "Binder name \"" ++ pr_id id ++ strbrk "\" occurs more than once in clause.") @@ -469,12 +469,12 @@ let meta_of_binder clause loc mvs = function | AnonHyp n -> try List.nth mvs (n-1) with (Failure _|Invalid_argument _) -> - errorlabstrm "" (str "No such binder.") + user_err (str "No such binder.") let error_already_defined b = match b with | NamedHyp id -> - errorlabstrm "" + user_err (str "Binder name \"" ++ pr_id id ++ str"\" already defined with incompatible value.") | AnonHyp n -> @@ -527,7 +527,7 @@ let clenv_constrain_last_binding c clenv = clenv_assign_binding clenv k c let error_not_right_number_missing_arguments n = - errorlabstrm "" + user_err (strbrk "Not the right number of missing arguments (expected " ++ int n ++ str ").") @@ -641,7 +641,7 @@ let explain_no_such_bound_variable holes id = | [id] -> str "(possible name is: " ++ pr_id id ++ str ")." | _ -> str "(possible names are: " ++ pr_enum pr_id mvl ++ str ")." in - errorlabstrm "" (str "No such bound variable " ++ pr_id id ++ expl) + user_err (str "No such bound variable " ++ pr_id id ++ expl) let evar_with_name holes id = let map h = match h.hole_name with @@ -653,7 +653,7 @@ let evar_with_name holes id = | [] -> explain_no_such_bound_variable holes id | [h] -> h.hole_evar | _ -> - errorlabstrm "" + user_err (str "Binder name \"" ++ pr_id id ++ str "\" occurs more than once in clause.") @@ -664,7 +664,7 @@ let evar_of_binder holes = function let h = List.nth holes (pred n) in h.hole_evar with e when CErrors.noncritical e -> - errorlabstrm "" (str "No such binder.") + user_err (str "No such binder.") let define_with_type sigma env ev c = let t = Retyping.get_type_of env sigma ev in diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli index aa091aecd..8a096b645 100644 --- a/proofs/clenvtac.mli +++ b/proofs/clenvtac.mli @@ -10,8 +10,8 @@ open Term open Clenv -open Tacexpr open Unification +open Misctypes (** Tactics *) val unify : ?flags:unify_flags -> constr -> unit Proofview.tactic diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 29cad0635..509efbc5b 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -54,8 +54,8 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc with e when CErrors.noncritical e -> let loc = Glob_ops.loc_of_glob_constr rawc in - user_err_loc - (loc,"", str "Instance is not well-typed in the environment of " ++ + user_err ~loc + (str "Instance is not well-typed in the environment of " ++ pr_existential_key sigma evk ++ str ".") in define_and_solve_constraints evk typed_c env (evars_reset_evd sigma' sigma) diff --git a/proofs/goal.ml b/proofs/goal.ml index 111a947a9..a141708c2 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -10,7 +10,8 @@ open Util open Pp open Term open Sigma.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (* This module implements the abstract interface to goals *) (* A general invariant of the module, is that a goal whose associated @@ -77,7 +78,7 @@ module V82 = struct let evars = Sigma.to_evar_map evars in let evars = Evd.restore_future_goals evars prev_future_goals prev_principal_goal in let ctxt = Environ.named_context_of_val hyps in - let inst = Array.map_of_list (mkVar % get_id) ctxt in + let inst = Array.map_of_list (NamedDecl.get_id %> mkVar) ctxt in let ev = Term.mkEvar (evk,inst) in (evk, ev, evars) @@ -148,7 +149,7 @@ module V82 = struct let env = env sigma gl in let genv = Global.env () in let is_proof_var decl = - try ignore (Environ.lookup_named (get_id decl) genv); false + try ignore (Environ.lookup_named (NamedDecl.get_id decl) genv); false with Not_found -> true in Environ.fold_named_context_reverse (fun t decl -> if is_proof_var decl then diff --git a/proofs/logic.ml b/proofs/logic.ml index 65497c80d..44c629484 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -24,6 +24,8 @@ open Retyping open Misctypes open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + type refiner_error = (* Errors raised by the refiner *) @@ -151,7 +153,7 @@ let reorder_context env sign ord = | top::ord' when mem_q top moved_hyps -> let ((d,h),mh) = find_q top moved_hyps in if occur_vars_in_decl env h d then - errorlabstrm "reorder_context" + user_err ~hdr:"reorder_context" (str "Cannot move declaration " ++ pr_id top ++ spc() ++ str "before " ++ pr_sequence pr_id @@ -162,7 +164,7 @@ let reorder_context env sign ord = (match ctxt_head with | [] -> error_no_such_hypothesis (List.hd ord) | d :: ctxt -> - let x = get_id d in + let x = NamedDecl.get_id d in if Id.Set.mem x expected then step ord (Id.Set.remove x expected) ctxt (push_item x d moved_hyps) ctxt_tail @@ -178,11 +180,11 @@ let reorder_val_context env sign ord = let check_decl_position env sign d = - let x = get_id d in + let x = NamedDecl.get_id d in let needed = global_vars_set_of_decl env d in let deps = dependency_closure env (named_context_of_val sign) needed in if Id.List.mem x deps then - errorlabstrm "Logic.check_decl_position" + user_err ~hdr:"Logic.check_decl_position" (str "Cannot create self-referring hypothesis " ++ pr_id x); x::deps @@ -204,8 +206,8 @@ let move_location_eq m1 m2 = match m1, m2 with let rec get_hyp_after h = function | [] -> error_no_such_hypothesis h | d :: right -> - if Id.equal (get_id d) h then - match right with d' ::_ -> MoveBefore (get_id d') | [] -> MoveFirst + if Id.equal (NamedDecl.get_id d) h then + match right with d' ::_ -> MoveBefore (NamedDecl.get_id d') | [] -> MoveFirst else get_hyp_after h right @@ -213,7 +215,7 @@ let split_sign hfrom hto l = let rec splitrec left toleft = function | [] -> error_no_such_hypothesis hfrom | d :: right -> - let hyp,_,typ = to_tuple d in + let hyp = NamedDecl.get_id d in if Id.equal hyp hfrom then (left,right,d, toleft || move_location_eq hto MoveLast) else @@ -235,24 +237,24 @@ let move_hyp toleft (left,declfrom,right) hto = let env = Global.env() in let test_dep d d2 = if toleft - then occur_var_in_decl env (get_id d2) d - else occur_var_in_decl env (get_id d) d2 + then occur_var_in_decl env (NamedDecl.get_id d2) d + else occur_var_in_decl env (NamedDecl.get_id d) d2 in let rec moverec first middle = function | [] -> if match hto with MoveFirst | MoveLast -> false | _ -> true then error_no_such_hypothesis (hyp_of_move_location hto); List.rev first @ List.rev middle - | d :: _ as right when move_location_eq hto (MoveBefore (get_id d)) -> + | d :: _ as right when move_location_eq hto (MoveBefore (NamedDecl.get_id d)) -> List.rev first @ List.rev middle @ right | d :: right -> - let hyp = get_id d in + let hyp = NamedDecl.get_id d in let (first',middle') = if List.exists (test_dep d) middle then if not (move_location_eq hto (MoveAfter hyp)) then (first, d::middle) else - errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id (get_id declfrom) ++ + user_err ~hdr:"move_hyp" (str "Cannot move " ++ pr_id (NamedDecl.get_id declfrom) ++ Miscprint.pr_move_location pr_id hto ++ str (if toleft then ": it occurs in " else ": it depends on ") ++ pr_id hyp ++ str ".") @@ -292,7 +294,7 @@ let move_hyp_in_named_context hfrom hto sign = variables only in Application and Case *) let error_unsupported_deep_meta c = - errorlabstrm "" (strbrk "Application of lemmas whose beta-iota normal " ++ + user_err (strbrk "Application of lemmas whose beta-iota normal " ++ strbrk "form contains metavariables deep inside the term is not " ++ strbrk "supported; try \"refine\" instead.") @@ -300,9 +302,9 @@ let collect_meta_variables c = let rec collrec deep acc c = match kind_of_term c with | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc | Cast(c,_,_) -> collrec deep acc c - | (App _| Case _) -> fold_constr (collrec deep) acc c + | (App _| Case _) -> Term.fold_constr (collrec deep) acc c | Proj (_, c) -> collrec deep acc c - | _ -> fold_constr (collrec true) acc c + | _ -> Term.fold_constr (collrec true) acc c in List.rev (collrec false [] c) @@ -494,19 +496,20 @@ and mk_casegoals sigma goal goalacc p c = let convert_hyp check sign sigma d = - let id,b,bt = to_tuple d in + let id = NamedDecl.get_id d in + let b = NamedDecl.get_value d in let env = Global.env() in let reorder = ref [] in let sign' = apply_to_hyp check sign id (fun _ d' _ -> - let _,c,ct = to_tuple d' in + let c = NamedDecl.get_value d' in let env = Global.env_of_context sign in - if check && not (is_conv env sigma bt ct) then - errorlabstrm "Logic.convert_hyp" + if check && not (is_conv env sigma (NamedDecl.get_type d) (NamedDecl.get_type d')) then + user_err ~hdr:"Logic.convert_hyp" (str "Incorrect change of the type of " ++ pr_id id ++ str "."); if check && not (Option.equal (is_conv env sigma) b c) then - errorlabstrm "Logic.convert_hyp" + user_err ~hdr:"Logic.convert_hyp" (str "Incorrect change of the body of "++ pr_id id ++ str "."); if check then reorder := check_decl_position env sign d; d) in @@ -539,7 +542,7 @@ let prim_refiner r sigma goal = t,cl,sigma else (if !check && mem_named_context_val id sign then - errorlabstrm "Logic.prim_refiner" + user_err ~hdr:"Logic.prim_refiner" (str "Variable " ++ pr_id id ++ str " is already declared."); push_named_context_val (LocalAssum (id,t)) sign,t,cl,sigma) in let (sg2,ev2,sigma) = diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index eddbf72a8..b06ea43bd 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -143,12 +143,7 @@ let solve ?with_end_tac gi info_lvl tac pr = in (p,status) with - | Proof_global.NoCurrentProof -> CErrors.error "No focused proof" - | CList.IndexOutOfRange -> - match gi with - | Vernacexpr.SelectNth i -> let msg = str "No such goal: " ++ int i ++ str "." in - CErrors.errorlabstrm "" msg - | _ -> assert false + Proof_global.NoCurrentProof -> CErrors.error "No focused proof" let by tac = Proof_global.with_current_proof (fun _ -> solve (Vernacexpr.SelectNth 1) None tac) @@ -245,7 +240,7 @@ let solve_by_implicit_tactic env sigma evk = when Context.Named.equal (Environ.named_context_of_val evi.evar_hyps) (Environ.named_context env) -> - let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.UserError ("",Pp.str"Proof is not complete."))) []) in + let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.UserError (None,Pp.str"Proof is not complete."))) []) in (try let c = Evarutil.nf_evars_universes sigma evi.evar_concl in if Evarutil.has_undefined_evars sigma c then raise Exit; diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index ea604e08e..7458109fa 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -124,14 +124,14 @@ val get_all_proof_names : unit -> Id.t list (** [set_end_tac tac] applies tactic [tac] to all subgoal generate by [solve] *) -val set_end_tac : Tacexpr.raw_tactic_expr -> unit +val set_end_tac : Genarg.glob_generic_argument -> unit (** {6 ... } *) (** [set_used_variables l] declares that section variables [l] will be used in the proof *) val set_used_variables : - Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list -val get_used_variables : unit -> Context.section_context option + Id.t list -> Context.Named.t * (Loc.t * Names.Id.t) list +val get_used_variables : unit -> Context.Named.t option (** {6 Universe binders } *) val get_universe_binders : unit -> universe_binders option diff --git a/proofs/proof.ml b/proofs/proof.ml index 5c963d53e..b2103489a 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -68,9 +68,9 @@ let _ = CErrors.register_handler begin function | CannotUnfocusThisWay -> CErrors.error "This proof is focused, but cannot be unfocused this way" | NoSuchGoals (i,j) when Int.equal i j -> - CErrors.errorlabstrm "Focus" Pp.(str"No such goal (" ++ int i ++ str").") + CErrors.user_err ~hdr:"Focus" Pp.(str"No such goal (" ++ int i ++ str").") | NoSuchGoals (i,j) -> - CErrors.errorlabstrm "Focus" Pp.( + CErrors.user_err ~hdr:"Focus" Pp.( str"Not every goal in range ["++ int i ++ str","++int j++str"] exist." ) | FullyUnfocused -> CErrors.error "The proof is not focused" @@ -372,6 +372,22 @@ let in_proof p k = k (Proofview.return p.proofview) let unshelve p = { p with proofview = Proofview.unshelve (p.shelf) (p.proofview) ; shelf = [] } +let pr_proof p = + let p = map_structured_proof p (fun _sigma g -> g) in + Pp.( + let pr_goal_list = prlist_with_sep spc Goal.pr_goal in + let rec aux acc = function + | [] -> acc + | (before,after)::stack -> + aux (pr_goal_list before ++ spc () ++ str "{" ++ acc ++ str "}" ++ spc () ++ + pr_goal_list after) stack in + str "[" ++ str "focus structure: " ++ + aux (pr_goal_list p.fg_goals) p.bg_goals ++ str ";" ++ spc () ++ + str "shelved: " ++ pr_goal_list p.shelved_goals ++ str ";" ++ spc () ++ + str "given up: " ++ pr_goal_list p.given_up_goals ++ + str "]" + ) + (*** Compatibility layer with <=v8.2 ***) module V82 = struct let subgoals p = diff --git a/proofs/proof.mli b/proofs/proof.mli index 5053fc7fb..8dc165e72 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -182,6 +182,8 @@ val in_proof : proof -> (Evd.evar_map -> 'a) -> 'a focused goals. *) val unshelve : proof -> proof +val pr_proof : proof -> Pp.std_ppcmds + (*** Compatibility layer with <=v8.2 ***) module V82 : sig val subgoals : proof -> Goal.goal list Evd.sigma diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index e753e972d..ca7330fdb 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -18,6 +18,8 @@ open Util open Pp open Names +module NamedDecl = Context.Named.Declaration + (*** Proof Modes ***) (* Type of proof modes : @@ -88,8 +90,8 @@ type closed_proof = proof_object * proof_terminator type pstate = { pid : Id.t; terminator : proof_terminator CEphemeron.key; - endline_tactic : Tacexpr.raw_tactic_expr option; - section_vars : Context.section_context option; + endline_tactic : Genarg.glob_generic_argument option; + section_vars : Context.Named.t option; proof : Proof.proof; strength : Decl_kinds.goal_kind; mode : proof_mode CEphemeron.key; @@ -146,9 +148,6 @@ let cur_pstate () = let give_me_the_proof () = (cur_pstate ()).proof let get_current_proof_name () = (cur_pstate ()).pid -let interp_tac = ref (fun _ -> assert false) -let set_interp_tac f = interp_tac := f - let with_current_proof f = match !pstates with | [] -> raise NoCurrentProof @@ -156,7 +155,13 @@ let with_current_proof f = let et = match p.endline_tactic with | None -> Proofview.tclUNIT () - | Some tac -> !interp_tac tac in + | Some tac -> + let open Geninterp in + let ist = { lfun = Id.Map.empty; extra = TacStore.empty } in + let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in + let tac = Geninterp.interp tag ist tac in + Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) + in let (newpr,ret) = f et p.proof in let p = { p with proof = newpr } in pstates := p :: rest; @@ -190,9 +195,9 @@ let check_no_pending_proof () = if not (there_are_pending_proofs ()) then () else begin - CErrors.error (Pp.string_of_ppcmds + CErrors.user_err (str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++ - str"Use \"Abort All\" first or complete proof(s).")) + str"Use \"Abort All\" first or complete proof(s).") end let discard_gen id = @@ -202,8 +207,8 @@ let discard (loc,id) = let n = List.length !pstates in discard_gen id; if Int.equal (List.length !pstates) n then - CErrors.user_err_loc - (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs ()) + CErrors.user_err ~loc + ~hdr:"Pfedit.delete_proof" (str"No such proof" ++ msg_proofs ()) let discard_current () = if List.is_empty !pstates then raise NoCurrentProof else pstates := List.tl !pstates @@ -276,7 +281,7 @@ let set_used_variables l = let ids = List.fold_right Id.Set.add l Id.Set.empty in let ctx = Environ.keep_hyps env ids in let ctx_set = - List.fold_right Id.Set.add (List.map get_id ctx) Id.Set.empty in + List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in let vars_of = Environ.global_vars_set in let aux env entry (ctx, all_safe, to_clear as orig) = match entry with @@ -312,7 +317,10 @@ let constrain_variables init uctx = let cstrs = UState.constrain_variables levels uctx in Univ.ContextSet.add_constraints cstrs (UState.context_set uctx) -let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = +type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context + +let close_proof ~keep_body_ucst_separate ?feedback_id ~now + (fpl : closed_proof_output Future.computation) = let { pid; section_vars; strength; proof; terminator; universe_binders } = cur_pstate () in let poly = pi2 strength (* Polymorphic *) in @@ -390,8 +398,6 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = universes = (universes, binders) }, fun pr_ending -> CEphemeron.get terminator pr_ending -type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context - let return_proof ?(allow_partial=false) () = let { pid; proof; strength = (_,poly,_) } = cur_pstate () in if allow_partial then begin @@ -408,7 +414,7 @@ let return_proof ?(allow_partial=false) () = let evd = let error s = let prf = str " (in proof " ++ Id.print pid ++ str ")" in - raise (CErrors.UserError("last tactic before Qed",s ++ prf)) + raise (CErrors.UserError(Some "last tactic before Qed",s ++ prf)) in try Proof.return proof with | Proof.UnfinishedProof -> @@ -519,7 +525,7 @@ module Bullet = struct (function | FailedBullet (b,sugg) -> let prefix = str"Wrong bullet " ++ pr_bullet b ++ str" : " in - CErrors.errorlabstrm "Focus" (prefix ++ suggest_on_error sugg) + CErrors.user_err ~hdr:"Focus" (prefix ++ suggest_on_error sugg) | _ -> raise CErrors.Unhandled) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 59daa2968..97a21cf22 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -134,17 +134,14 @@ val simple_with_current_proof : (unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit (** Sets the tactic to be used when a tactic line is closed with [...] *) -val set_endline_tactic : Tacexpr.raw_tactic_expr -> unit -val set_interp_tac : - (Tacexpr.raw_tactic_expr -> unit Proofview.tactic) - -> unit +val set_endline_tactic : Genarg.glob_generic_argument -> unit (** Sets the section variables assumed by the proof, returns its closure * (w.r.t. type dependencies and let-ins covered by it) + a list of * ids to be cleared *) val set_used_variables : - Names.Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list -val get_used_variables : unit -> Context.section_context option + Names.Id.t list -> Context.Named.t * (Loc.t * Names.Id.t) list +val get_used_variables : unit -> Context.Named.t option val get_universe_binders : unit -> universe_binders option diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index c12079622..03bc5e471 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -11,7 +11,6 @@ open Evd open Names open Term -open Tacexpr open Glob_term open Nametab open Misctypes diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml index caa9b328a..f51586c73 100644 --- a/proofs/proof_using.ml +++ b/proofs/proof_using.ml @@ -12,6 +12,8 @@ open Util open Vernacexpr open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + let to_string e = let rec aux = function | SsEmpty -> "()" @@ -35,12 +37,14 @@ let in_nameset = let rec close_fwd e s = let s' = List.fold_left (fun s decl -> - let (id,b,ty) = Context.Named.Declaration.to_tuple decl in - let vb = Option.(default Id.Set.empty (map (global_vars_set e) b)) in - let vty = global_vars_set e ty in + let vb = match decl with + | LocalAssum _ -> Id.Set.empty + | LocalDef (_,b,_) -> global_vars_set e b + in + let vty = global_vars_set e (NamedDecl.get_type decl) in let vbty = Id.Set.union vb vty in if Id.Set.exists (fun v -> Id.Set.mem v s) vbty - then Id.Set.add id (Id.Set.union s vbty) else s) + then Id.Set.add (NamedDecl.get_id decl) (Id.Set.union s vbty) else s) s (named_context e) in if Id.Set.equal s s' then s else close_fwd e s' @@ -63,13 +67,13 @@ and set_of_id env ty id = Id.Set.union (global_vars_set env ty) acc) Id.Set.empty ty else if Id.to_string id = "All" then - List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty + List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty else if CList.mem_assoc_f Id.equal id !known_names then process_expr env (CList.assoc_f Id.equal id !known_names) [] else Id.Set.singleton id and full_set env = - List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty + List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty let process_expr env e ty = let ty_expr = SsSingl(Loc.ghost, Id.of_string "Type") in @@ -104,7 +108,7 @@ let remove_ids_and_lets env s ids = let suggest_Proof_using name env vars ids_typ context_ids = let module S = Id.Set in let open Pp in - let print x = prerr_endline (string_of_ppcmds x) in + let print x = Feedback.msg_error x in let pr_set parens s = let wrap ppcmds = if parens && S.cardinal s > 1 then str "(" ++ ppcmds ++ str ")" diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 72cb05f1b..34443b93d 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -73,7 +73,7 @@ let set_strategy_one ref l = let cb = Global.lookup_constant sp in (match cb.const_body with | OpaqueDef _ -> - errorlabstrm "set_transparent_const" + user_err ~hdr:"set_transparent_const" (str "Cannot make" ++ spc () ++ Nametab.pr_global_env Id.Set.empty (ConstRef sp) ++ spc () ++ str "transparent because it was declared opaque."); @@ -175,19 +175,19 @@ let red_expr_tab = Summary.ref String.Map.empty ~name:"Declare Reduction" let declare_reduction s f = if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab - then errorlabstrm "Redexpr.declare_reduction" + then user_err ~hdr:"Redexpr.declare_reduction" (str "There is already a reduction expression of name " ++ str s) else reduction_tab := String.Map.add s f !reduction_tab let check_custom = function | ExtraRedExpr s -> if not (String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab) - then errorlabstrm "Redexpr.check_custom" (str "Reference to undefined reduction expression " ++ str s) + then user_err ~hdr:"Redexpr.check_custom" (str "Reference to undefined reduction expression " ++ str s) |_ -> () let decl_red_expr s e = if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab - then errorlabstrm "Redexpr.decl_red_expr" + then user_err ~hdr:"Redexpr.decl_red_expr" (str "There is already a reduction expression of name " ++ str s) else begin check_custom e; @@ -247,7 +247,7 @@ let reduction_of_red_expr env = with Not_found -> (try reduction_of_red_expr (String.Map.find s !red_expr_tab) with Not_found -> - errorlabstrm "Redexpr.reduction_of_red_expr" + user_err ~hdr:"Redexpr.reduction_of_red_expr" (str "unknown user-defined reduction \"" ++ str s ++ str "\""))) | CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast) | CbvNative o -> (contextualize cbv_native cbv_native o, NATIVEcast) diff --git a/proofs/refine.ml b/proofs/refine.ml index 3f5527060..c238f731d 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -11,6 +11,8 @@ open Sigma.Notations open Proofview.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + let extract_prefix env info = let ctx1 = List.rev (Environ.named_context env) in let ctx2 = List.rev (Evd.evar_context info) in @@ -26,7 +28,7 @@ let typecheck_evar ev env sigma = let info = Evd.find sigma ev in (** Typecheck the hypotheses. *) let type_hyp (sigma, env) decl = - let t = get_type decl in + let t = NamedDecl.get_type decl in let evdref = ref sigma in let _ = Typing.e_sort_of env evdref t in let () = match decl with diff --git a/proofs/refiner.ml b/proofs/refiner.ml index ea8543b02..9a0b56b84 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -13,7 +13,8 @@ open Evd open Environ open Proof_type open Logic -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration let sig_it x = x.it let project x = x.sigma @@ -60,7 +61,7 @@ let tclIDTAC_MESSAGE s gls = Feedback.msg_info (hov 0 s); tclIDTAC gls (* General failure tactic *) -let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s) +let tclFAIL_s s gls = user_err ~hdr:"Refiner.tclFAIL_s" (str s) (* A special exception for levels for the Fail tactic *) exception FailError of int * std_ppcmds Lazy.t @@ -82,7 +83,7 @@ let thens3parts_tac tacfi tac tacli (sigr,gs) = let nf = Array.length tacfi in let nl = Array.length tacli in let ng = List.length gs in - if ng<nf+nl then errorlabstrm "Refiner.thensn_tac" (str "Not enough subgoals."); + if ng<nf+nl then user_err ~hdr:"Refiner.thensn_tac" (str "Not enough subgoals."); let gll = (List.map_i (fun i -> apply_sig_tac sigr (if i<nf then tacfi.(i) else if i>=ng-nl then tacli.(nl-ng+i) else tac)) @@ -164,14 +165,14 @@ the goal unchanged *) let tclWEAK_PROGRESS tac ptree = let rslt = tac ptree in if Goal.V82.weak_progress rslt ptree then rslt - else errorlabstrm "Refiner.WEAK_PROGRESS" (str"Failed to progress.") + else user_err ~hdr:"Refiner.WEAK_PROGRESS" (str"Failed to progress.") (* PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves the goal unchanged *) let tclPROGRESS tac ptree = let rslt = tac ptree in if Goal.V82.progress rslt ptree then rslt - else errorlabstrm "Refiner.PROGRESS" (str"Failed to progress.") + else user_err ~hdr:"Refiner.PROGRESS" (str"Failed to progress.") (* Same as tclWEAK_PROGRESS but fails also if tactics generates several goals, one of them being identical to the original goal *) @@ -182,7 +183,7 @@ let tclNOTSAMEGOAL (tac : tactic) goal = let rslt = tac goal in let {it=gls;sigma=sigma} = rslt in if List.exists (same_goal goal sigma) gls - then errorlabstrm "Refiner.tclNOTSAMEGOAL" + then user_err ~hdr:"Refiner.tclNOTSAMEGOAL" (str"Tactic generated a subgoal identical to the original goal.") else rslt @@ -202,7 +203,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) let { it = gls; sigma = sigma; } = rslt in let hyps:Context.Named.t list = List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in - let cmp d1 d2 = Names.Id.equal (get_id d1) (get_id d2) in + let cmp d1 d2 = Names.Id.equal (NamedDecl.get_id d1) (NamedDecl.get_id d2) in let newhyps = List.map (fun hypl -> List.subtract cmp hypl oldhyps) @@ -215,7 +216,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) List.fold_left (fun acc lh -> acc ^ (if !frst then (frst:=false;"") else " | ") ^ (List.fold_left - (fun acc d -> (Names.Id.to_string (get_id d)) ^ " " ^ acc) + (fun acc d -> (Names.Id.to_string (NamedDecl.get_id d)) ^ " " ^ acc) "" lh)) "" newhyps in Feedback.msg_notice @@ -316,7 +317,7 @@ let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl) let tclDO n t = let rec dorec k = - if k < 0 then errorlabstrm "Refiner.tclDO" + if k < 0 then user_err ~hdr:"Refiner.tclDO" (str"Wrong argument : Do needs a positive integer."); if Int.equal k 0 then tclIDTAC else if Int.equal k 1 then t else (tclTHEN t (dorec (k-1))) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 330594af5..030a3cbfb 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -21,6 +21,8 @@ open Refiner open Sigma.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + let re_sig it gc = { it = it; sigma = gc; } (**************************************************************) @@ -46,7 +48,7 @@ let pf_hyps_types gls = | LocalDef (id,_,x) -> id, x) sign -let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> get_id +let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> NamedDecl.get_id let pf_last_hyp gl = List.hd (pf_hyps gl) @@ -57,7 +59,7 @@ let pf_get_hyp gls id = raise (RefinerError (NoSuchHyp id)) let pf_get_hyp_typ gls id = - pf_get_hyp gls id |> get_type + id |> pf_get_hyp gls |> NamedDecl.get_type let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls) @@ -101,7 +103,7 @@ let pf_const_value = pf_reduce (fun env _ -> constant_value_in env) let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind -let pf_hnf_type_of gls = pf_whd_all gls % pf_get_type_of gls +let pf_hnf_type_of gls = pf_get_type_of gls %> pf_whd_all gls let pf_is_matching = pf_apply Constr_matching.is_matching_conv let pf_matches = pf_apply Constr_matching.matches_conv @@ -198,7 +200,7 @@ module New = struct sign let pf_get_hyp_typ id gl = - pf_get_hyp id gl |> get_type + pf_get_hyp id gl |> NamedDecl.get_type let pf_hyps_types gl = let env = Proofview.Goal.env gl in diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 8acc3c233..125491988 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -10,9 +10,9 @@ open CErrors open Pp open Util -let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr +let stm_pr_err pp = Format.eprintf "%s] @[%a@]%!\n" (System.process_id ()) Pp.pp_with pp -let prerr_endline s = if !Flags.debug then begin pr_err s end else () +let stm_prerr_endline s = if !Flags.debug then begin stm_pr_err (str s) end else () type 'a worker_status = [ `Fresh | `Old of 'a ] @@ -147,23 +147,23 @@ module Make(T : Task) = struct let stop_waiting = ref false in let expiration_date = ref (ref false) in let pick_task () = - prerr_endline "waiting for a task"; + stm_prerr_endline "waiting for a task"; let pick age (t, c) = not !c && T.task_match age t in let task, task_expiration = TQueue.pop ~picky:(pick !worker_age) ~destroy:stop_waiting queue in expiration_date := task_expiration; last_task := Some task; - prerr_endline ("got task: "^T.name_of_task task); + stm_prerr_endline ("got task: " ^ T.name_of_task task); task in let add_tasks l = List.iter (fun t -> TQueue.push queue (t,!expiration_date)) l in let get_exec_token () = ignore(CoqworkmgrApi.get 1); got_token := true; - prerr_endline ("got execution token") in + stm_prerr_endline ("got execution token") in let kill proc = Worker.kill proc; - prerr_endline ("Worker exited: " ^ + stm_prerr_endline ("Worker exited: " ^ match Worker.wait proc with | Unix.WEXITED 0x400 -> "exit code unavailable" | Unix.WEXITED i -> Printf.sprintf "exit(%d)" i @@ -196,7 +196,7 @@ module Make(T : Task) = struct report_status ~id "Idle"; let task = pick_task () in match T.request_of_task !worker_age task with - | None -> prerr_endline ("Task expired: " ^ T.name_of_task task) + | None -> stm_prerr_endline ("Task expired: " ^ T.name_of_task task) | Some req -> try get_exec_token (); @@ -222,8 +222,7 @@ module Make(T : Task) = struct raise e (* we pass the exception to the external handler *) | MarshalError s -> T.on_marshal_error s task; raise Die | e -> - pr_err ("Uncaught exception in worker manager: "^ - string_of_ppcmds (print e)); + stm_pr_err Pp.(seq [str "Uncaught exception in worker manager: "; print e]); flush_all (); raise Die done with | (Die | TQueue.BeingDestroyed) -> @@ -261,7 +260,7 @@ module Make(T : Task) = struct let broadcast { queue } = TQueue.broadcast queue let enqueue_task { queue; active } (t, _ as item) = - prerr_endline ("Enqueue task "^T.name_of_task t); + stm_prerr_endline ("Enqueue task "^T.name_of_task t); TQueue.push queue item let cancel_worker { active } n = Pool.cancel n active @@ -298,18 +297,11 @@ module Make(T : Task) = struct let slave_handshake () = Pool.worker_handshake (Option.get !slave_ic) (Option.get !slave_oc) - let pp_pid pp = - (* Breaking all abstraction barriers... very nice *) - let get_xml pp = match Richpp.repr pp with - | Xml_datatype.Element("_", [], xml) -> xml - | _ -> assert false in - Richpp.richpp_of_xml (Xml_datatype.Element("_", [], - get_xml (Richpp.richpp_of_pp Pp.(str (System.process_id ()^ " "))) @ - get_xml pp)) + let pp_pid pp = Pp.(str (System.process_id () ^ " ") ++ pp) let debug_with_pid = Feedback.(function | { contents = Message(Debug, loc, pp) } as fb -> - { fb with contents = Message(Debug,loc,pp_pid pp) } + { fb with contents = Message(Debug,loc, pp_pid pp) } | x -> x) let main_loop () = @@ -317,7 +309,6 @@ module Make(T : Task) = struct let slave_feeder oc fb = Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc in Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x); - Feedback.set_logger Feedback.feedback_logger; (* We ask master to allocate universe identifiers *) Universes.set_remote_new_univ_level (bufferize (fun () -> marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; @@ -337,11 +328,11 @@ module Make(T : Task) = struct CEphemeron.clear () with | MarshalError s -> - pr_err ("Fatal marshal error: " ^ s); flush_all (); exit 2 + stm_pr_err Pp.(prlist str ["Fatal marshal error: "; s]); flush_all (); exit 2 | End_of_file -> - prerr_endline "connection lost"; flush_all (); exit 2 + stm_prerr_endline "connection lost"; flush_all (); exit 2 | e -> - pr_err ("Slave: critical exception: " ^ Pp.string_of_ppcmds (print e)); + stm_pr_err Pp.(seq [str "Slave: critical exception: "; print e]); flush_all (); exit 1 done diff --git a/stm/proofworkertop.ml b/stm/proofworkertop.ml index 23538a467..0d2f9cb74 100644 --- a/stm/proofworkertop.ml +++ b/stm/proofworkertop.ml @@ -8,11 +8,7 @@ module W = AsyncTaskQueue.MakeWorker(Stm.ProofTask) -let () = Coqtop.toploop_init := (fun args -> - Flags.make_silent true; - W.init_stdout (); - CoqworkmgrApi.init !Flags.async_proofs_worker_priority; - args) +let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout let () = Coqtop.toploop_run := W.main_loop diff --git a/stm/queryworkertop.ml b/stm/queryworkertop.ml index fff6d5543..9d3047373 100644 --- a/stm/queryworkertop.ml +++ b/stm/queryworkertop.ml @@ -8,11 +8,7 @@ module W = AsyncTaskQueue.MakeWorker(Stm.QueryTask) -let () = Coqtop.toploop_init := (fun args -> - Flags.make_silent true; - W.init_stdout (); - CoqworkmgrApi.init !Flags.async_proofs_worker_priority; - args) +let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout let () = Coqtop.toploop_run := W.main_loop diff --git a/stm/stm.ml b/stm/stm.ml index f577994ff..b9dbb7891 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -6,14 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr +let stm_pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr +let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n" (System.process_id ()) Pp.pp_with pp; flush stderr -let prerr_endline s = if false then begin pr_err (s ()) end else () -let prerr_debug s = if !Flags.debug then begin pr_err (s ()) end else () +let stm_prerr_endline s = if false then begin stm_pr_err (s ()) end else () +let stm_prerr_debug s = if !Flags.debug then begin stm_pr_err (s ()) end else () -(* Opening ppvernac below aliases Richpp, see PR#185 *) -let pp_to_richpp = Richpp.richpp_of_pp -let str_to_richpp = Richpp.richpp_of_string +let stm_pperr_endline s = if false then begin stm_pp_err (s ()) end else () open Vernacexpr open CErrors @@ -24,11 +23,13 @@ open Ppvernac open Vernac_classifier open Feedback +let execution_error state_id loc msg = + feedback ~id:(State state_id) + (Message (Error, Some loc, msg)) + module Hooks = struct let process_error, process_error_hook = Hook.make () -let interp, interp_hook = Hook.make () -let with_fail, with_fail_hook = Hook.make () let state_computed, state_computed_hook = Hook.make ~default:(fun state_id ~in_cache -> @@ -46,11 +47,7 @@ let forward_feedback, forward_feedback_hook = let parse_error, parse_error_hook = Hook.make ~default:(fun id loc msg -> - feedback ~id (Message(Error, Some loc, pp_to_richpp msg))) () - -let execution_error, execution_error_hook = Hook.make - ~default:(fun state_id loc msg -> - feedback ~id:(State state_id) (Message(Error, Some loc, pp_to_richpp msg))) () + feedback ~id (Message(Error, Some loc, msg))) () let unreachable_state, unreachable_state_hook = Hook.make ~default:(fun _ _ -> ()) () @@ -105,26 +102,6 @@ let may_pierce_opaque = function | { expr = VernacExtend (("ExtractionInductive",_), _) } -> true | _ -> false -(* Wrapper for Vernacentries.interp to set the feedback id *) -let vernac_interp ?proof id ?route { verbose; loc; expr } = - let rec internal_command = function - | VernacResetName _ | VernacResetInitial | VernacBack _ - | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ - | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true - | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> internal_command e - | _ -> false in - if internal_command expr then begin - prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr)) - end else begin - set_id_for_feedback ?route (State id); - Aux_file.record_in_aux_set_at loc; - prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr)); - try Hooks.(call interp ?verbosely:(Some verbose) ?proof (loc, expr)) - with e -> - let e = CErrors.push e in - iraise Hooks.(call_process_error_once e) - end - (* Wrapper for Vernac.parse_sentence to set the feedback id *) let indentation_of_string s = let len = String.length s in @@ -566,7 +543,7 @@ end = struct (* {{{ *) let branch, mode = match Vcs_aux.find_proof_at_depth !vcs pl with | h, { Vcs_.kind = `Proof (m, _) } -> h, m | _ -> assert false in checkout branch; - prerr_endline (fun () -> "mode:" ^ mode); + stm_prerr_endline (fun () -> "mode:" ^ mode); Proof_global.activate_proof_mode mode with Failure _ -> checkout Branch.master; @@ -860,7 +837,7 @@ end = struct (* {{{ *) | None -> let loc = Option.default Loc.ghost (Loc.get_loc info) in let (e, info) = Hooks.(call_process_error_once (e, info)) in - Hooks.(call execution_error id loc (iprint (e, info))); + execution_error id loc (iprint (e, info)); (e, Stateid.add info ~valid id) let same_env { system = s1 } { system = s2 } = @@ -878,7 +855,7 @@ end = struct (* {{{ *) if is_cached id && not redefine then anomaly (str"defining state "++str str_id++str" twice"); try - prerr_endline (fun () -> "defining "^str_id^" (cache="^ + stm_prerr_endline (fun () -> "defining "^str_id^" (cache="^ if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)"); let good_id = match safe_id with None -> !cur_id | Some id -> id in fix_exn_ref := exn_on id ~valid:good_id; @@ -886,7 +863,7 @@ end = struct (* {{{ *) fix_exn_ref := (fun x -> x); if cache = `Yes then freeze `No id else if cache = `Shallow then freeze `Shallow id; - prerr_endline (fun () -> "setting cur id to "^str_id); + stm_prerr_endline (fun () -> "setting cur id to "^str_id); cur_id := id; if feedback_processed then Hooks.(call state_computed id ~in_cache:false); @@ -910,6 +887,126 @@ end = struct (* {{{ *) end (* }}} *) +(* indentation code for Show Script, initially contributed + * by D. de Rauglaudre. Should be moved away. + *) + +module ShowScript = struct + +let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) = + (* ng1 : number of goals remaining at the current level (before cmd) + ngl1 : stack of previous levels with their remaining goals + ng : number of goals after the execution of cmd + beginend : special indentation stack for { } *) + let ngprev = List.fold_left (+) ng1 ngl1 in + let new_ngl = + if ng > ngprev then + (* We've branched *) + (ng - ngprev + 1, ng1 - 1 :: ngl1) + else if ng < ngprev then + (* A subgoal have been solved. Let's compute the new current level + by discarding all levels with 0 remaining goals. *) + let rec loop = function + | (0, ng2::ngl2) -> loop (ng2,ngl2) + | p -> p + in loop (ng1-1, ngl1) + else + (* Standard case, same goal number as before *) + (ng1, ngl1) + in + (* When a subgoal have been solved, separate this block by an empty line *) + let new_nl = (ng < ngprev) + in + (* Indentation depth *) + let ind = List.length ngl1 + in + (* Some special handling of bullets and { }, to get a nicer display *) + let pred n = max 0 (n-1) in + let ind, nl, new_beginend = match cmd with + | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend + | VernacEndSubproof -> List.hd beginend, false, List.tl beginend + | VernacBullet _ -> pred ind, nl, beginend + | _ -> ind, nl, beginend + in + let pp = + (if nl then fnl () else mt ()) ++ + (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd)) + in + (new_ngl, new_nl, new_beginend, pp :: ppl) + +let get_script prf = + let branch, test = + match prf with + | None -> VCS.Branch.master, fun _ -> true + | Some name -> VCS.current_branch (),fun nl -> nl=[] || List.mem name nl in + let rec find acc id = + if Stateid.equal id Stateid.initial || + Stateid.equal id Stateid.dummy then acc else + let view = VCS.visit id in + match view.step with + | `Fork((_,_,_,ns), _) when test ns -> acc + | `Qed (qed, proof) -> find [qed.qast.expr, (VCS.get_info id).n_goals] proof + | `Sideff (`Ast (x,_)) -> + find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next + | `Sideff (`Id id) -> find acc id + | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *) + find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next + | `Cmd _ -> find acc view.next + | `Alias (id,_) -> find acc id + | `Fork _ -> find acc view.next + in + find [] (VCS.get_branch_pos branch) + +let show_script ?proof () = + try + let prf = + try match proof with + | None -> Some (Pfedit.get_current_proof_name ()) + | Some (p,_) -> Some (p.Proof_global.id) + with Proof_global.NoCurrentProof -> None + in + let cmds = get_script prf in + let _,_,_,indented_cmds = + List.fold_left indent_script_item ((1,[]),false,[],[]) cmds + in + let indented_cmds = List.rev (indented_cmds) in + msg_notice (v 0 (prlist_with_sep fnl (fun x -> x) indented_cmds)) + with Vcs_aux.Expired -> () + +end + +(* Wrapper for Vernacentries.interp to set the feedback id *) +(* It is currently called 19 times, this number should be certainly + reduced... *) +let stm_vernac_interp ?proof id ?route { verbose; loc; expr } = + (* The Stm will gain the capability to interpret commmads affecting + the whole document state, such as backtrack, etc... so we start + to design the stm command interpreter now *) + set_id_for_feedback ?route (State id); + Aux_file.record_in_aux_set_at loc; + (* We need to check if a command should be filtered from + * vernac_entries, as it cannot handle it. This should go away in + * future refactorings. + *) + let rec is_filtered_command = function + | VernacResetName _ | VernacResetInitial | VernacBack _ + | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ + | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true + | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> is_filtered_command e + | _ -> false + in + let aux_interp cmd = + if is_filtered_command cmd then + stm_pperr_endline Pp.(fun () -> str "ignoring " ++ pr_vernac expr) + else match cmd with + | VernacShow ShowScript -> ShowScript.show_script () + | expr -> + stm_pperr_endline Pp.(fun () -> str "interpreting " ++ pr_vernac expr); + try Vernacentries.interp ?verbosely:(Some verbose) ?proof (loc, expr) + with e -> + let e = CErrors.push e in + iraise Hooks.(call_process_error_once e) + in aux_interp expr (****************************** CRUFT *****************************************) (******************************************************************************) @@ -1041,7 +1138,7 @@ end = struct (* {{{ *) | _ -> VtUnknown, VtNow with | Not_found -> - CErrors.errorlabstrm "undo_vernac_classifier" + CErrors.user_err ~hdr:"undo_vernac_classifier" (str "Cannot undo") end (* }}} *) @@ -1109,7 +1206,7 @@ let proof_block_delimiters = ref [] let register_proof_block_delimiter name static dynamic = if List.mem_assoc name !proof_block_delimiters then - CErrors.errorlabstrm "STM" (str "Duplicate block delimiter " ++ str name); + CErrors.user_err ~hdr:"STM" (str "Duplicate block delimiter " ++ str name); proof_block_delimiters := (name, (static,dynamic)) :: !proof_block_delimiters let mk_doc_node id = function @@ -1144,7 +1241,7 @@ let detect_proof_block id name = VCS.create_proof_block decl name end with Not_found -> - CErrors.errorlabstrm "STM" + CErrors.user_err ~hdr:"STM" (str "Unknown proof block delimiter " ++ str name) ) (****************************** THE SCHEDULER *********************************) @@ -1287,7 +1384,7 @@ end = struct (* {{{ *) let info = Stateid.add ~valid:start Exninfo.null start in let e = (RemoteException (strbrk s), info) in t_assign (`Exn e); - Hooks.(call execution_error start Loc.ghost (strbrk s)); + execution_error start Loc.ghost (strbrk s); feedback (InProgress ~-1) let build_proof_here ~drop_pt (id,valid) loc eop = @@ -1321,7 +1418,7 @@ end = struct (* {{{ *) Proof_global.close_future_proof stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in - vernac_interp stop + stm_vernac_interp stop ~proof:(pobject, terminator) { verbose = false; loc; indentation = 0; strlen = 0; expr = (VernacEndProof (Proved (Opaque None,None))) }) in @@ -1337,11 +1434,10 @@ end = struct (* {{{ *) | Some (safe, err) -> err, safe | None -> Stateid.dummy, Stateid.dummy in let e_msg = iprint (e, info) in - prerr_endline (fun () -> "failed with the following exception:"); - prerr_endline (fun () -> string_of_ppcmds e_msg); + stm_pperr_endline Pp.(fun () -> str "failed with the following exception: " ++ fnl () ++ e_msg); let e_safe_states = List.filter State.is_cached_and_valid my_states in RespError { e_error_at; e_safe_id; e_msg; e_safe_states } - + let perform_states query = if query = [] then [] else let is_tac e = match classify_vernac e with @@ -1463,7 +1559,7 @@ end = struct (* {{{ *) (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) Reach.known_state ~cache:`No start; - vernac_interp stop ~proof + stm_vernac_interp stop ~proof { verbose = false; loc; indentation = 0; strlen = 0; expr = (VernacEndProof (Proved (Opaque None,None))) }; `OK proof @@ -1520,9 +1616,9 @@ end = struct (* {{{ *) Future.from_val (Option.get (Global.body_of_constant_body c)) in let uc = Future.chain - ~greedy:true ~pure:true uc Univ.hcons_universe_context_set in - let pr = Future.chain ~greedy:true ~pure:true pr discharge in - let pr = Future.chain ~greedy:true ~pure:true pr Constr.hcons in + ~pure:true uc Univ.hcons_universe_context_set in + let pr = Future.chain ~pure:true pr discharge in + let pr = Future.chain ~pure:true pr Constr.hcons in Future.sink pr; let extra = Future.join uc in u.(bucket) <- uc; @@ -1603,7 +1699,7 @@ end = struct (* {{{ *) | Some (ReqBuildProof (r, b, _)) -> Some(r, b) | _ -> None) tasks in - prerr_endline (fun () -> Printf.sprintf "dumping %d tasks\n" (List.length reqs)); + stm_prerr_endline (fun () -> Printf.sprintf "dumping %d tasks\n" (List.length reqs)); reqs let reset_task_queue () = TaskQueue.clear (Option.get !queue) @@ -1687,7 +1783,7 @@ end = struct (* {{{ *) `Stay ((),[]) let on_marshal_error err { t_name } = - pr_err ("Fatal marshal error: " ^ t_name ); + stm_pr_err ("Fatal marshal error: " ^ t_name ); flush_all (); exit 1 let on_task_cancellation_or_expiration_or_slave_death = function @@ -1709,12 +1805,12 @@ end = struct (* {{{ *) List.for_all (Context.Named.Declaration.for_all (Evarutil.is_ground_term sigma0)) Evd.(evar_context g)) then - CErrors.errorlabstrm "STM" (strbrk("the par: goal selector supports ground "^ + CErrors.user_err ~hdr:"STM" (strbrk("the par: goal selector supports ground "^ "goals only")) else begin let (i, ast) = r_ast in Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); - vernac_interp r_state_fb ast; + stm_vernac_interp r_state_fb ast; let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> RespNoProgress @@ -1722,7 +1818,7 @@ end = struct (* {{{ *) let t = Evarutil.nf_evar sigma t in if Evarutil.is_ground_term sigma t then RespBuiltSubProof (t, Evd.evar_universe_context sigma) - else CErrors.errorlabstrm "STM" (str"The solution is not ground") + else CErrors.user_err ~hdr:"STM" (str"The solution is not ground") end) () with e when CErrors.noncritical e -> RespError (CErrors.print e) @@ -1750,7 +1846,7 @@ end = struct (* {{{ *) | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> find true fail e | VernacFail e -> find time true e | _ -> e, time, fail in find false false e in - Hooks.call Hooks.with_fail fail (fun () -> + Vernacentries.with_fail fail (fun () -> (if time then System.with_time false else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> Proof_global.with_current_proof (fun _ p -> @@ -1786,10 +1882,10 @@ end = struct (* {{{ *) let open Notations in try let pt, uc = Future.join f in - prerr_endline (fun () -> string_of_ppcmds(hov 0 ( + stm_pperr_endline (fun () -> hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ str"t=" ++ (Printer.pr_constr pt) ++ spc () ++ - str"uc=" ++ Evd.pr_evar_universe_context uc))); + str"uc=" ++ Evd.pr_evar_universe_context uc)); (if abstract then Tactics.tclABSTRACT None else (fun x -> x)) (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*> Tactics.exact_no_check pt) @@ -1831,7 +1927,7 @@ end = struct (* {{{ *) let use_response _ _ _ = `End let on_marshal_error _ _ = - pr_err ("Fatal marshal error in query"); + stm_pr_err ("Fatal marshal error in query"); flush_all (); exit 1 let on_task_cancellation_or_expiration_or_slave_death _ = () @@ -1843,11 +1939,11 @@ end = struct (* {{{ *) VCS.print (); Reach.known_state ~cache:`No r_where; try - vernac_interp r_for { r_what with verbose = true }; + stm_vernac_interp r_for { r_what with verbose = true }; feedback ~id:(State r_for) Processed with e when CErrors.noncritical e -> let e = CErrors.push e in - let msg = pp_to_richpp (iprint e) in + let msg = iprint e in feedback ~id:(State r_for) (Message (Error, None, msg)) let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what) @@ -1906,7 +2002,7 @@ let warn_deprecated_nested_proofs = "stop working in a future Coq version")) let collect_proof keep cur hd brkind id = - prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id); + stm_prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id); let no_name = "" in let name = function | [] -> no_name @@ -2006,7 +2102,7 @@ let string_of_reason = function | `NoPU_NoHint_NoES -> "no 'Proof using..', no .aux file, inside a section" | `Unknown -> "unsupported case" -let log_string s = prerr_debug (fun () -> "STM: " ^ s) +let log_string s = stm_prerr_debug (fun () -> "STM: " ^ s) let log_processing_async id name = log_string Printf.(sprintf "%s: proof %s: asynch" (Stateid.to_string id) name ) @@ -2052,14 +2148,14 @@ let known_state ?(redefine_qed=false) ~cache id = Proof_global.with_current_proof (fun _ p -> feedback ~id:(State id) Feedback.AddedAxiom; fst (Pfedit.solve Vernacexpr.SelectAll None tac p), ()); - Option.iter (fun expr -> vernac_interp id { + Option.iter (fun expr -> stm_vernac_interp id { verbose = true; loc = Loc.ghost; expr; indentation = 0; strlen = 0 }) recovery_command | _ -> assert false end with Not_found -> - CErrors.errorlabstrm "STM" + CErrors.user_err ~hdr:"STM" (str "Unknown proof block delimiter " ++ str name) in @@ -2093,16 +2189,16 @@ let known_state ?(redefine_qed=false) ~cache id = Summary.unfreeze_summary s; Lib.unfreeze l; update_global_env () in let rec pure_cherry_pick_non_pstate safe_id id = Future.purify (fun id -> - prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id); + stm_prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id); reach ~safe_id id; cherry_pick_non_pstate ()) id (* traverses the dag backward from nodes being already calculated *) and reach ?safe_id ?(redefine_qed=false) ?(cache=cache) id = - prerr_endline (fun () -> "reaching: " ^ Stateid.to_string id); + stm_prerr_endline (fun () -> "reaching: " ^ Stateid.to_string id); if not redefine_qed && State.is_cached ~cache id then begin Hooks.(call state_computed id ~in_cache:true); - prerr_endline (fun () -> "reached (cache)"); + stm_prerr_endline (fun () -> "reached (cache)"); State.install_cached id end else let step, cache_step, feedback_processed = @@ -2131,24 +2227,24 @@ let known_state ?(redefine_qed=false) ~cache id = resilient_tactic id cblock (fun () -> reach view.next; Hooks.(call tactic_being_run true); - vernac_interp id x; + stm_vernac_interp id x; Hooks.(call tactic_being_run false)); if eff then update_global_env () ), (if eff then `Yes else cache), true | `Cmd { cast = x; ceff = eff } -> (fun () -> resilient_command reach view.next; - vernac_interp id x; + stm_vernac_interp id x; if eff then update_global_env () ), (if eff then `Yes else cache), true | `Fork ((x,_,_,_), None) -> (fun () -> resilient_command reach view.next; - vernac_interp id x; + stm_vernac_interp id x; wall_clock_last_fork := Unix.gettimeofday () ), `Yes, true | `Fork ((x,_,_,_), Some prev) -> (fun () -> (* nested proof *) reach ~cache:`Shallow prev; reach view.next; - (try vernac_interp id x; + (try stm_vernac_interp id x; with e when CErrors.noncritical e -> let (e, info) = CErrors.push e in let info = Stateid.add info ~valid:prev id in @@ -2198,14 +2294,14 @@ let known_state ?(redefine_qed=false) ~cache id = Proof_global.close_future_proof ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; - vernac_interp id ~proof x; + stm_vernac_interp id ~proof x; feedback ~id:(State id) Incomplete | { VCS.kind = `Master }, _ -> assert false end; Proof_global.discard_all () ), (if redefine_qed then `No else `Yes), true | `Sync (name, _, `Immediate) -> (fun () -> - reach eop; vernac_interp id x; Proof_global.discard_all () + reach eop; stm_vernac_interp id x; Proof_global.discard_all () ), `Yes, true | `Sync (name, pua, reason) -> (fun () -> log_processing_sync id name reason; @@ -2226,7 +2322,7 @@ let known_state ?(redefine_qed=false) ~cache id = if keep != VtKeepAsAxiom then reach view.next; let wall_clock2 = Unix.gettimeofday () in - vernac_interp id ?proof x; + stm_vernac_interp id ?proof x; let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at x.loc "proof_check_time" (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); @@ -2242,7 +2338,7 @@ let known_state ?(redefine_qed=false) ~cache id = in aux (collect_proof keep (view.next, x) brname brinfo eop) | `Sideff (`Ast (x,_)) -> (fun () -> - reach view.next; vernac_interp id x; update_global_env () + reach view.next; stm_vernac_interp id x; update_global_env () ), cache, true | `Sideff (`Id origin) -> (fun () -> reach view.next; @@ -2254,7 +2350,7 @@ let known_state ?(redefine_qed=false) ~cache id = else cache_step in State.define ?safe_id ~cache:cache_step ~redefine:redefine_qed ~feedback_processed step id; - prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in + stm_prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in reach ~redefine_qed id end (* }}} *) @@ -2269,7 +2365,7 @@ let init () = Backtrack.record (); Slaves.init (); if Flags.async_proofs_is_master () then begin - prerr_endline (fun () -> "Initializing workers"); + stm_prerr_endline (fun () -> "Initializing workers"); Query.init (); let opts = match !Flags.async_proofs_private_flags with | None -> [] @@ -2321,9 +2417,9 @@ let rec join_admitted_proofs id = let join () = finish (); wait (); - prerr_endline (fun () -> "Joining the environment"); + stm_prerr_endline (fun () -> "Joining the environment"); Global.join_safe_environment (); - prerr_endline (fun () -> "Joining Admitted proofs"); + stm_prerr_endline (fun () -> "Joining Admitted proofs"); join_admitted_proofs (VCS.get_branch_pos (VCS.current_branch ())); VCS.print (); VCS.print () @@ -2397,7 +2493,7 @@ let handle_failure (e, info) vcs tty = anomaly(str"error with no safe_id attached:" ++ spc() ++ CErrors.iprint_no_report (e, info)) | Some (safe_id, id) -> - prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); + stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); VCS.restore vcs; if tty && interactive () = `Yes then begin (* We stay on a valid state *) @@ -2411,7 +2507,7 @@ let handle_failure (e, info) vcs tty = let snapshot_vio ldir long_f_dot_vo = finish (); if List.length (VCS.branches ()) > 1 then - CErrors.errorlabstrm "stm" (str"Cannot dump a vio with open proofs"); + CErrors.user_err ~hdr:"stm" (str"Cannot dump a vio with open proofs"); Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_vo (Global.opaque_tables ()) @@ -2420,17 +2516,17 @@ let reset_task_queue = Slaves.reset_task_queue (* Document building *) let process_transaction ?(newtip=Stateid.fresh ()) ~tty ({ verbose; loc; expr } as x) c = - prerr_endline (fun () -> "{{{ processing: "^ string_of_ppcmds (pr_ast x)); + stm_pperr_endline (fun () -> str "{{{ processing: " ++ pr_ast x); let vcs = VCS.backup () in try let head = VCS.current_branch () in VCS.checkout head; let rc = begin - prerr_endline (fun () -> + stm_prerr_endline (fun () -> " classified as: " ^ string_of_vernac_classification c); match c with (* PG stuff *) - | VtStm(VtPG,false), VtNow -> vernac_interp Stateid.dummy x; `Ok + | VtStm(VtPG,false), VtNow -> stm_vernac_interp Stateid.dummy x; `Ok | VtStm(VtPG,_), _ -> anomaly(str "PG command in script or VtLater") (* Joining various parts of the document *) | VtStm (VtJoinDocument, b), VtNow -> join (); `Ok @@ -2464,7 +2560,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty VCS.commit id (Alias (oid,x)); Backtrack.record (); if w == VtNow then finish (); `Ok | VtStm (VtBack id, false), VtNow -> - prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id); + stm_prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id); Backtrack.backto id; VCS.checkout_shallowest_proof_branch (); Reach.known_state ~cache:(interactive ()) id; `Ok @@ -2474,13 +2570,13 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty (* Query *) | VtQuery (false,(report_id,route)), VtNow when tty = true -> finish (); - (try Future.purify (vernac_interp report_id ~route) + (try Future.purify (stm_vernac_interp report_id ~route) {x with verbose = true } with e when CErrors.noncritical e -> let e = CErrors.push e in iraise (State.exn_on ~valid:Stateid.dummy report_id e)); `Ok | VtQuery (false,(report_id,route)), VtNow -> - (try vernac_interp report_id ~route x + (try stm_vernac_interp report_id ~route x with e -> let e = CErrors.push e in iraise (State.exn_on ~valid:Stateid.dummy report_id e)); `Ok @@ -2553,7 +2649,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty (* Side effect on all branches *) | VtUnknown, _ when expr = VernacToplevelControl Drop -> - vernac_interp (VCS.get_branch_pos head) x; `Ok + stm_vernac_interp (VCS.get_branch_pos head) x; `Ok | VtSideff l, w -> let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in @@ -2579,7 +2675,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty VCS.checkout VCS.Branch.master; let mid = VCS.get_branch_pos VCS.Branch.master in Reach.known_state ~cache:(interactive ()) mid; - vernac_interp id x; + stm_vernac_interp id x; (* Vernac x may or may not start a proof *) if not in_proof && Proof_global.there_are_pending_proofs () then begin @@ -2609,12 +2705,12 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty begin match expr with | VernacStm (PGLast _) -> if not (VCS.Branch.equal head VCS.Branch.master) then - vernac_interp Stateid.dummy + stm_vernac_interp Stateid.dummy { verbose = true; loc = Loc.ghost; indentation = 0; strlen = 0; expr = VernacShow (ShowGoal OpenSubgoals) } | _ -> () end; - prerr_endline (fun () -> "processed }}}"); + stm_prerr_endline (fun () -> "processed }}}"); VCS.print (); rc with e -> @@ -2800,7 +2896,7 @@ let edit_at id = anomaly (str ("edit_at "^Stateid.to_string id^": ") ++ CErrors.print_no_report e) | Some (_, id) -> - prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); + stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); VCS.restore vcs; VCS.print (); iraise (e, info) @@ -2856,102 +2952,13 @@ let proofname b = match VCS.get_branch b with let get_all_proof_names () = List.map unmangle (List.map_filter proofname (VCS.branches ())) -let get_current_proof_name () = - Option.map unmangle (proofname (VCS.current_branch ())) - -let get_script prf = - let branch, test = - match prf with - | None -> VCS.Branch.master, fun _ -> true - | Some name -> VCS.current_branch (),fun nl -> nl=[] || List.mem name nl in - let rec find acc id = - if Stateid.equal id Stateid.initial || - Stateid.equal id Stateid.dummy then acc else - let view = VCS.visit id in - match view.step with - | `Fork((_,_,_,ns), _) when test ns -> acc - | `Qed (qed, proof) -> find [qed.qast.expr, (VCS.get_info id).n_goals] proof - | `Sideff (`Ast (x,_)) -> - find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next - | `Sideff (`Id id) -> find acc id - | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *) - find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next - | `Cmd _ -> find acc view.next - | `Alias (id,_) -> find acc id - | `Fork _ -> find acc view.next - in - find [] (VCS.get_branch_pos branch) - -(* indentation code for Show Script, initially contributed - by D. de Rauglaudre *) - -let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) = - (* ng1 : number of goals remaining at the current level (before cmd) - ngl1 : stack of previous levels with their remaining goals - ng : number of goals after the execution of cmd - beginend : special indentation stack for { } *) - let ngprev = List.fold_left (+) ng1 ngl1 in - let new_ngl = - if ng > ngprev then - (* We've branched *) - (ng - ngprev + 1, ng1 - 1 :: ngl1) - else if ng < ngprev then - (* A subgoal have been solved. Let's compute the new current level - by discarding all levels with 0 remaining goals. *) - let rec loop = function - | (0, ng2::ngl2) -> loop (ng2,ngl2) - | p -> p - in loop (ng1-1, ngl1) - else - (* Standard case, same goal number as before *) - (ng1, ngl1) - in - (* When a subgoal have been solved, separate this block by an empty line *) - let new_nl = (ng < ngprev) - in - (* Indentation depth *) - let ind = List.length ngl1 - in - (* Some special handling of bullets and { }, to get a nicer display *) - let pred n = max 0 (n-1) in - let ind, nl, new_beginend = match cmd with - | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend - | VernacEndSubproof -> List.hd beginend, false, List.tl beginend - | VernacBullet _ -> pred ind, nl, beginend - | _ -> ind, nl, beginend - in - let pp = - (if nl then fnl () else mt ()) ++ - (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd)) - in - (new_ngl, new_nl, new_beginend, pp :: ppl) - -let show_script ?proof () = - try - let prf = - try match proof with - | None -> Some (Pfedit.get_current_proof_name ()) - | Some (p,_) -> Some (p.Proof_global.id) - with Proof_global.NoCurrentProof -> None - in - let cmds = get_script prf in - let _,_,_,indented_cmds = - List.fold_left indent_script_item ((1,[]),false,[],[]) cmds - in - let indented_cmds = List.rev (indented_cmds) in - msg_notice (v 0 (prlist_with_sep fnl (fun x -> x) indented_cmds)) - with Vcs_aux.Expired -> () - (* Export hooks *) let state_computed_hook = Hooks.state_computed_hook let state_ready_hook = Hooks.state_ready_hook let parse_error_hook = Hooks.parse_error_hook -let execution_error_hook = Hooks.execution_error_hook let forward_feedback_hook = Hooks.forward_feedback_hook let process_error_hook = Hooks.process_error_hook -let interp_hook = Hooks.interp_hook -let with_fail_hook = Hooks.with_fail_hook let unreachable_state_hook = Hooks.unreachable_state_hook -let get_fix_exn () = !State.fix_exn_ref +let () = Hook.set Obligations.stm_get_fix_exn (fun () -> !State.fix_exn_ref) let tactic_being_run_hook = Hooks.tactic_being_run_hook (* vim:set foldmethod=marker: *) diff --git a/stm/stm.mli b/stm/stm.mli index b8a2a3859..0f0a3c4e1 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -184,7 +184,6 @@ val register_proof_block_delimiter : val state_computed_hook : (Stateid.t -> in_cache:bool -> unit) Hook.t val parse_error_hook : (Feedback.edit_or_state_id -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t -val execution_error_hook : (Stateid.t -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t val unreachable_state_hook : (Stateid.t -> Exninfo.iexn -> unit) Hook.t (* ready means that master has it at hand *) val state_ready_hook : (Stateid.t -> unit) Hook.t @@ -213,12 +212,6 @@ val interp : bool -> vernac_expr located -> unit (* Queries for backward compatibility *) val current_proof_depth : unit -> int val get_all_proof_names : unit -> Id.t list -val get_current_proof_name : unit -> Id.t option -val show_script : ?proof:Proof_global.closed_proof -> unit -> unit (* Hooks to be set by other Coq components in order to break file cycles *) val process_error_hook : Future.fix_exn Hook.t -val interp_hook : (?verbosely:bool -> ?proof:Proof_global.closed_proof -> - Loc.t * Vernacexpr.vernac_expr -> unit) Hook.t -val with_fail_hook : (bool -> (unit -> unit) -> unit) Hook.t -val get_fix_exn : unit -> (Exninfo.iexn -> Exninfo.iexn) diff --git a/stm/stm.mllib b/stm/stm.mllib index 939ee187a..72b538016 100644 --- a/stm/stm.mllib +++ b/stm/stm.mllib @@ -4,8 +4,8 @@ Vcs TQueue WorkerPool Vernac_classifier -Lemmas CoqworkmgrApi +WorkerLoop AsyncTaskQueue Stm ProofBlockDelimiter diff --git a/stm/tacworkertop.ml b/stm/tacworkertop.ml index d5333d107..256532c6b 100644 --- a/stm/tacworkertop.ml +++ b/stm/tacworkertop.ml @@ -8,11 +8,7 @@ module W = AsyncTaskQueue.MakeWorker(Stm.TacTask) -let () = Coqtop.toploop_init := (fun args -> - Flags.make_silent true; - W.init_stdout (); - CoqworkmgrApi.init !Flags.async_proofs_worker_priority; - args) +let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout let () = Coqtop.toploop_run := W.main_loop diff --git a/stm/workerLoop.ml b/stm/workerLoop.ml new file mode 100644 index 000000000..50b42512c --- /dev/null +++ b/stm/workerLoop.ml @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +let rec parse = function + | "--xml_format=Ppcmds" :: rest -> parse rest + | x :: rest -> x :: parse rest + | [] -> [] + +let loop init args = + let args = parse args in + Flags.make_silent true; + init (); + CoqworkmgrApi.init !Flags.async_proofs_worker_priority; + args diff --git a/printing/printmodsig.mli b/stm/workerLoop.mli index f71fffdce..dcbf9c88d 100644 --- a/printing/printmodsig.mli +++ b/stm/workerLoop.mli @@ -6,12 +6,4 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp -open Names - -module type Pp = -sig - val pr_mutual_inductive_body : Environ.env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds - val print_module : bool -> module_path -> std_ppcmds - val print_modtype : module_path -> std_ppcmds -end +val loop : (unit -> unit) -> string list -> string list diff --git a/tactics/auto.ml b/tactics/auto.ml index bc6448577..7558a707e 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -20,7 +20,6 @@ open Genredexpr open Tactics open Tacticals open Clenv -open Tacexpr open Locus open Proofview.Notations open Hints @@ -150,7 +149,7 @@ let conclPattern concl pat tac = constr_bindings env sigma >>= fun constr_bindings -> let open Genarg in let open Geninterp in - let inj c = match val_tag (topwit Constrarg.wit_constr) with + let inj c = match val_tag (topwit Stdarg.wit_constr) with | Val.Base tag -> Val.Dyn (tag, c) | _ -> assert false in @@ -260,7 +259,7 @@ and erase_subtree depth = function | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l let pr_info_atom (d,pp) = - str (String.make d ' ') ++ pp () ++ str "." + str (String.make (d-1) ' ') ++ pp () ++ str "." let pr_info_trace = function | (Info,_,{contents=(d,Some pp)::l}) -> diff --git a/tactics/auto.mli b/tactics/auto.mli index 3befaaade..de0dbd483 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -14,6 +14,7 @@ open Clenv open Pattern open Decl_kinds open Hints +open Tactypes val compute_secvars : ('a,'b) Proofview.Goal.t -> Id.Pred.t @@ -39,43 +40,43 @@ val conclPattern : constr -> constr_pattern option -> Genarg.glob_generic_argume (** The use of the "core" database can be de-activated by passing "nocore" amongst the databases. *) -val auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic +val auto : ?debug:debug -> + int -> delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** Auto with more delta. *) -val new_auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic +val new_auto : ?debug:debug -> + int -> delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** auto with default search depth and with the hint database "core" *) val default_auto : unit Proofview.tactic (** auto with all hint databases *) -val full_auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic +val full_auto : ?debug:debug -> + int -> delayed_open_constr list -> unit Proofview.tactic (** auto with all hint databases and doing delta *) -val new_full_auto : ?debug:Tacexpr.debug -> - int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic +val new_full_auto : ?debug:debug -> + int -> delayed_open_constr list -> unit Proofview.tactic (** auto with default search depth and with all hint databases *) val default_full_auto : unit Proofview.tactic (** The generic form of auto (second arg [None] means all bases) *) -val gen_auto : ?debug:Tacexpr.debug -> - int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val gen_auto : ?debug:debug -> + int option -> delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** The hidden version of auto *) -val h_auto : ?debug:Tacexpr.debug -> - int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val h_auto : ?debug:debug -> + int option -> delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** Trivial *) -val trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic -val gen_trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic -val full_trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> unit Proofview.tactic -val h_trivial : ?debug:Tacexpr.debug -> - Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val trivial : ?debug:debug -> + delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic +val gen_trivial : ?debug:debug -> + delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic +val full_trivial : ?debug:debug -> + delayed_open_constr list -> unit Proofview.tactic +val h_trivial : ?debug:debug -> + delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 475005648..dae1cc9f1 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -65,7 +65,7 @@ let raw_find_base bas = String.Map.find bas !rewtab let find_base bas = try raw_find_base bas with Not_found -> - errorlabstrm "AutoRewrite" + user_err ~hdr:"AutoRewrite" (str "Rewriting base " ++ str bas ++ str " does not exist.") let find_rewrites bas = @@ -83,7 +83,7 @@ let print_rewrite_hintdb bas = str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ Option.cata (fun tac -> str " then use tactic " ++ - Pptactic.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) + Pputils.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option @@ -294,8 +294,8 @@ let find_applied_relation metas loc env sigma c left2right = match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c | None -> - user_err_loc (loc, "decompose_applied_relation", - str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ + user_err ~loc ~hdr:"decompose_applied_relation" + (str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 070657179..49e8588da 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -9,7 +9,6 @@ (** This files implements the autorewrite tactic. *) open Term -open Tacexpr open Equality (** Rewriting rules before tactic interpretation *) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index d1ae85e7b..edfe21d34 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -31,6 +31,8 @@ open Misctypes open Proofview.Notations open Hints +module NamedDecl = Context.Named.Declaration + (** Hint database named "typeclass_instances", now created directly in Auto *) (** Options handling *) @@ -496,7 +498,16 @@ let catchable = function | Refiner.FailError _ -> true | e -> Logic.catchable_exception e -let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) +(* alternate separators in debug search path output *) +let debug_seps = [| "." ; "-" |] +let next_sep seps = + let num_seps = Array.length seps in + let sep_index = ref 0 in + fun () -> + let sep = seps.(!sep_index) in + sep_index := (!sep_index + 1) mod num_seps; + str sep +let pr_depth l = prlist_with_sep (next_sep debug_seps) int (List.rev l) let is_Prop env sigma concl = let ty = Retyping.get_type_of env sigma concl in @@ -546,9 +557,8 @@ let evars_to_goals p evm = (** Making local hints *) let make_resolve_hyp env sigma st flags only_classes pri decl = - let open Context.Named.Declaration in - let id = get_id decl in - let cty = Evarutil.nf_evar sigma (get_type decl) in + let id = NamedDecl.get_id decl in + let cty = Evarutil.nf_evar sigma (NamedDecl.get_type decl) in let rec iscl env ty = let ctx, ar = decompose_prod_assum ty in match kind_of_term (fst (decompose_app ar)) with @@ -593,10 +603,9 @@ let make_hints g st only_classes sign = List.fold_left (fun hints hyp -> let consider = - let open Context.Named.Declaration in - try let t = Global.lookup_named (get_id hyp) |> get_type in + try let t = hyp |> NamedDecl.get_id |> Global.lookup_named |> NamedDecl.get_type in (* Section variable, reindex only if the type changed *) - not (Term.eq_constr t (get_type hyp)) + not (Term.eq_constr t (NamedDecl.get_type hyp)) with Not_found -> true in if consider then diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 445a104d6..6b29f574c 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -13,7 +13,8 @@ open Coqlib open Reductionops open Misctypes open Proofview.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (* Absurd *) @@ -48,7 +49,7 @@ let use_negated_unit_or_eq_type () = Flags.version_strictly_greater Flags.V8_5 let filter_hyp f tac = let rec seek = function | [] -> Proofview.tclZERO Not_found - | d::rest when f (get_type d) -> tac (get_id d) + | d::rest when f (NamedDecl.get_type d) -> tac (NamedDecl.get_id d) | _::rest -> seek rest in Proofview.Goal.enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in @@ -62,8 +63,8 @@ let contradiction_context = let rec seek_neg l = match l with | [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction") | d :: rest -> - let id = get_id d in - let typ = nf_evar sigma (get_type d) in + let id = NamedDecl.get_id d in + let typ = nf_evar sigma (NamedDecl.get_type d) in let typ = whd_all env sigma typ in if is_empty_type typ then simplest_elim (mkVar id) diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 23ff58225..885183174 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -20,7 +20,7 @@ open Tactics open Clenv open Auto open Genredexpr -open Tacexpr +open Tactypes open Locus open Locusops open Hints @@ -97,8 +97,8 @@ let prolog_tac l n = in let l = List.map map l in try (prolog l n gl) - with UserError ("Refiner.tclFIRST",_) -> - errorlabstrm "Prolog.prolog" (str "Prolog failed.") + with UserError (Some "Refiner.tclFIRST",_) -> + user_err ~hdr:"Prolog.prolog" (str "Prolog failed.") end open Auto @@ -206,7 +206,7 @@ type search_state = { dblist : hint_db list; localdb : hint_db list; prev : prev_search_state; - local_lemmas : Tacexpr.delayed_open_constr list; + local_lemmas : delayed_open_constr list; } and prev_search_state = (* for info eauto *) @@ -436,7 +436,7 @@ let cons a l = a :: l let autounfolds db occs cls gl = let unfolds = List.concat (List.map (fun dbname -> let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in let hyps = pf_ids_of_hyps gl in @@ -503,7 +503,7 @@ let autounfold_one db cl = let st = List.fold_left (fun (i,c) dbname -> let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 8812093d5..1f69e4ab3 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -9,6 +9,7 @@ open Term open Proof_type open Hints +open Tactypes val e_assumption : unit Proofview.tactic @@ -16,15 +17,15 @@ val registered_e_assumption : unit Proofview.tactic val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic -val prolog_tac : Tacexpr.delayed_open_constr list -> int -> unit Proofview.tactic +val prolog_tac : delayed_open_constr list -> int -> unit Proofview.tactic -val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> +val gen_eauto : ?debug:debug -> bool * int -> delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic val eauto_with_bases : - ?debug:Tacexpr.debug -> + ?debug:debug -> bool * int -> - Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic + delayed_open_constr list -> hint_db list -> Proof_type.tactic val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic diff --git a/tactics/elim.ml b/tactics/elim.ml index f2b9eec4b..3f0c01a29 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -16,7 +16,8 @@ open Tacmach.New open Tacticals.New open Tactics open Proofview.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (* Supposed to be called without as clause *) let introElimAssumsThen tac ba = @@ -139,7 +140,7 @@ let induction_trailer abs_i abs_j bargs = let (hyps,_) = List.fold_left (fun (bring_ids,leave_ids) d -> - let cid = get_id d in + let cid = NamedDecl.get_id d in if not (List.mem cid leave_ids) then (d::bring_ids,leave_ids) else (bring_ids,cid::leave_ids)) diff --git a/tactics/elim.mli b/tactics/elim.mli index ae9cf85f3..29c441463 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -10,11 +10,12 @@ open Names open Term open Tacticals open Misctypes +open Tactypes (** Eliminations tactics. *) -val introCaseAssumsThen : Tacexpr.evars_flag -> - (Tacexpr.intro_patterns -> branch_assumptions -> unit Proofview.tactic) -> +val introCaseAssumsThen : evars_flag -> + (intro_patterns -> branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic val h_decompose : inductive list -> constr -> unit Proofview.tactic diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index b1d3290aa..1a67bedc2 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -22,6 +22,7 @@ open Tacticals.New open Auto open Constr_matching open Misctypes +open Tactypes open Hipattern open Pretyping open Tacmach.New @@ -73,7 +74,7 @@ let mkBranches c1 c2 = let discrHyp id = let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in - let tac c = Equality.discr_tac false (Some (None, Tacexpr.ElimOnConstr c)) in + let tac c = Equality.discr_tac false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac let solveNoteqBranch side = @@ -121,7 +122,7 @@ let eqCase tac = let injHyp id = let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in - let tac c = Equality.injClause None false (Some (None, Tacexpr.ElimOnConstr c)) in + let tac c = Equality.injClause None false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac let diseqCase hyps eqonleft = diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 1a45217a4..c94dcfa9d 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -60,6 +60,8 @@ open Indrec open Sigma.Notations open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + let hid = Id.of_string "H" let xid = Id.of_string "X" let default_id_of_sort = function InProp | InSet -> hid | InType -> xid @@ -600,9 +602,9 @@ let fix_r2l_forward_rew_scheme (c, ctx') = | hp :: p :: ind :: indargs -> let c' = my_it_mkLambda_or_LetIn indargs - (mkLambda_or_LetIn (map_constr (liftn (-1) 1) p) - (mkLambda_or_LetIn (map_constr (liftn (-1) 2) hp) - (mkLambda_or_LetIn (map_constr (lift 2) ind) + (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 1) p) + (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 2) hp) + (mkLambda_or_LetIn (RelDecl.map_constr (lift 2) ind) (Reductionops.whd_beta Evd.empty (applist (c, Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) @@ -741,7 +743,7 @@ let build_congr env (eq,refl,ctx) ind = if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported."; let env_with_arity = push_rel_context arityctxt env in - let ty = get_type (lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity) in + let ty = RelDecl.get_type (lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity) in let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in if Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt) then diff --git a/tactics/equality.ml b/tactics/equality.ml index bb3cbad92..d44dcf10d 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -26,7 +26,6 @@ open Retyping open Tacmach.New open Logic open Hipattern -open Tacexpr open Tacticals.New open Tactics open Tacred @@ -45,6 +44,8 @@ open Proofview.Notations open Unification open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + (* Options *) let discriminate_introduction = ref true @@ -359,7 +360,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = let _ = Global.lookup_constant c1' in c1' with Not_found -> - errorlabstrm "Equality.find_elim" + user_err ~hdr:"Equality.find_elim" (str "Cannot find rewrite principle " ++ pr_label l' ++ str ".") end | _ -> destConstRef pr1 @@ -724,7 +725,7 @@ let find_positions env sigma t1 t2 = let hd1,args1 = whd_all_stack env sigma t1 in let hd2,args2 = whd_all_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with - | Construct (sp1,_), Construct (sp2,_) + | Construct ((ind1,i1 as sp1),u1), Construct (sp2,_) when Int.equal (List.length args1) (constructor_nallargs_env env sp1) -> let sorts' = @@ -733,11 +734,14 @@ let find_positions env sigma t1 t2 = (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) if eq_constructor sp1 sp2 then - let nrealargs = constructor_nrealargs_env env sp1 in - let rargs1 = List.lastn nrealargs args1 in - let rargs2 = List.lastn nrealargs args2 in + let nparams = inductive_nparams_env env ind1 in + let params1,rargs1 = List.chop nparams args1 in + let _,rargs2 = List.chop nparams args2 in + let (mib,mip) = lookup_mind_specif env ind1 in + let ctxt = (get_constructor ((ind1,u1),mib,mip,params1) i1).cs_args in + let adjust i = Vars.adjust_rel_to_rel_context ctxt (i+1) - 1 in List.flatten - (List.map2_i (fun i -> findrec sorts' ((sp1,i)::posn)) + (List.map2_i (fun i -> findrec sorts' ((sp1,adjust i)::posn)) 0 rargs1 rargs2) else if Sorts.List.mem InType sorts' then (* see build_discriminator *) @@ -888,7 +892,7 @@ let build_selector env sigma dirn c ind special default = on (c bool true) = (c bool false) CP : changed assert false in a more informative error *) - errorlabstrm "Equality.construct_discriminator" + user_err ~hdr:"Equality.construct_discriminator" (str "Cannot discriminate on inductive constructors with \ dependent types.") in let (indp,_) = dest_ind_family indf in @@ -974,7 +978,7 @@ let apply_on_clause (f,t) clause = let argmv = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv - | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in + | _ -> user_err (str "Ill-formed clause applicator.")) in clenv_fchain ~with_univs:false argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = @@ -1052,7 +1056,7 @@ let discrEverywhere with_evars = else (* <= 8.2 compat *) tryAllHypsAndConcl (discrSimpleClause with_evars)) (* (fun gls -> - errorlabstrm "DiscrEverywhere" (str"No discriminable equalities.")) + user_err ~hdr:"DiscrEverywhere" (str"No discriminable equalities.")) *) let discr_tac with_evars = function | None -> discrEverywhere with_evars @@ -1666,13 +1670,13 @@ exception FoundHyp of (Id.t * constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occurring in [t] *) let is_eq_x gl x d = - let id = get_id d in + let id = NamedDecl.get_id d in try let is_var id c = match kind_of_term c with | Var id' -> Id.equal id id' | _ -> false in - let c = pf_nf_evar gl (get_type d) in + let c = pf_nf_evar gl (NamedDecl.get_type d) in let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in if (is_var x lhs) && not (local_occur_var x rhs) then raise (FoundHyp (id,rhs,true)); if (is_var x rhs) && not (local_occur_var x lhs) then raise (FoundHyp (id,lhs,false)) @@ -1690,7 +1694,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = (* The set of hypotheses using x *) let dephyps = List.rev (pi3 (List.fold_right (fun dcl (dest,deps,allhyps) -> - let id = get_id dcl in + let id = NamedDecl.get_id dcl in if not (Id.equal id hyp) && List.exists (fun y -> occur_var_in_decl env y dcl) deps then @@ -1719,9 +1723,9 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = let subst_one_var dep_proof_ok x = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in - let xval = pf_get_hyp x gl |> get_value in + let decl = pf_get_hyp x gl in (* If x has a body, simply replace x with body and clear x *) - if not (Option.is_empty xval) then tclTHEN (unfold_body x) (clear [x]) else + if is_local_def decl then tclTHEN (unfold_body x) (clear [x]) else (* Find a non-recursive definition for x *) let res = try @@ -1729,7 +1733,7 @@ let subst_one_var dep_proof_ok x = let hyps = Proofview.Goal.hyps gl in let test hyp _ = is_eq_x gl x hyp in Context.Named.fold_outside test ~init:() hyps; - errorlabstrm "Subst" + user_err ~hdr:"Subst" (str "Cannot find any non-recursive equality over " ++ pr_id x ++ str".") with FoundHyp res -> res in @@ -1767,14 +1771,14 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let find_eq_data_decompose = find_eq_data_decompose gl in let select_equation_name decl = try - let lbeq,u,(_,x,y) = find_eq_data_decompose (get_type decl) in + let lbeq,u,(_,x,y) = find_eq_data_decompose (NamedDecl.get_type decl) in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match kind_of_term x, kind_of_term y with | Var z, _ when not (is_evaluable env (EvalVarRef z)) -> - Some (get_id decl) + Some (NamedDecl.get_id decl) | _, Var z when not (is_evaluable env (EvalVarRef z)) -> - Some (get_id decl) + Some (NamedDecl.get_id decl) | _ -> None with Constr_matching.PatternMatchingFailure -> None @@ -1789,7 +1793,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in - let c = pf_get_hyp hyp gl |> get_type in + let c = pf_get_hyp hyp gl |> NamedDecl.get_type in let _,_,(_,x,y) = find_eq_data_decompose c in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then Proofview.tclUNIT () else @@ -1858,10 +1862,10 @@ let rewrite_assumption_cond cond_eq_term cl = let rec arec hyps gl = match hyps with | [] -> error "No such assumption." | hyp ::rest -> - let id = get_id hyp in + let id = NamedDecl.get_id hyp in begin try - let dir = cond_eq_term (get_type hyp) gl in + let dir = cond_eq_term (NamedDecl.get_type hyp) gl in general_rewrite_clause dir false (mkVar id,NoBindings) cl with | Failure _ | UserError _ -> arec rest gl end diff --git a/tactics/equality.mli b/tactics/equality.mli index 47cb6b82f..6a4a8126e 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -11,10 +11,10 @@ open Names open Term open Evd open Environ -open Tacexpr open Ind_tables open Locus open Misctypes +open Tactypes (*i*) type dep_proof_flag = bool (* true = support rewriting dependent proofs *) diff --git a/tactics/hints.ml b/tactics/hints.ml index 9a96b7389..59d015fa2 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -20,11 +20,11 @@ open Namegen open Libnames open Smartlocate open Misctypes +open Tactypes open Evd open Termops open Inductiveops open Typing -open Tacexpr open Decl_kinds open Pattern open Patternops @@ -34,12 +34,15 @@ open Tacred open Printer open Vernacexpr open Sigma.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (****************************************) (* General functions *) (****************************************) +type debug = Debug | Info | Off + exception Bound let head_constr_bound t = @@ -71,6 +74,7 @@ let decompose_app_bound t = different declaration between the named hyps and the section context. *) let secvars_of_hyps hyps = let secctx = Global.named_context () in + let open Context.Named.Declaration in let pred, all = List.fold_left (fun (pred,all) decl -> try let _ = Context.Named.lookup (get_id decl) hyps in @@ -716,7 +720,7 @@ let current_db () = Hintdbmap.bindings !searchtable let current_pure_db () = List.map snd (current_db ()) let error_no_such_hint_database x = - errorlabstrm "Hints" (str "No such Hint database: " ++ str x ++ str ".") + user_err ~hdr:"Hints" (str "No such Hint database: " ++ str x ++ str ".") (**************************************************************************) (* Definition of the summary *) @@ -877,7 +881,7 @@ let make_resolves env sigma flags info poly ?name cr = make_apply_entry env sigma flags info poly ?name] in if List.is_empty ents then - errorlabstrm "Hint" + user_err ~hdr:"Hint" (pr_lconstr c ++ spc() ++ (if pi1 flags then str"cannot be used as a hint." else str "can be used as a hint only for eauto.")); @@ -885,12 +889,12 @@ let make_resolves env sigma flags info poly ?name cr = (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma decl = - let hname = get_id decl in + let hname = NamedDecl.get_id decl in let c = mkVar hname in try [make_apply_entry env sigma (true, true, false) empty_hint_info false ~name:(PathHints [VarRef hname]) - (c, get_type decl, Univ.ContextSet.empty)] + (c, NamedDecl.get_type decl, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") @@ -909,7 +913,6 @@ let make_unfold eref = code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = - let tacast = Genarg.in_gen (Genarg.glbwit Constrarg.wit_ltac) tacast in let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri = pri; @@ -926,7 +929,7 @@ let make_mode ref m = let n = List.length ctx in let m' = Array.of_list m in if not (n == Array.length m') then - errorlabstrm "Hint" + user_err ~hdr:"Hint" (pr_global ref ++ str" has " ++ int n ++ str" arguments while the mode declares " ++ int (Array.length m')) else m' @@ -1192,8 +1195,6 @@ let add_trivials env sigma l local dbnames = Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let (forward_intern_tac, extern_intern_tac) = Hook.make () - type hnf = bool type hint_info = (patvar list * constr_pattern) hint_info_gen @@ -1205,7 +1206,7 @@ type hints_entry = | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsModeEntry of global_reference * hint_mode list - | HintsExternEntry of hint_info * glob_tactic_expr + | HintsExternEntry of hint_info * Genarg.glob_generic_argument let default_prepare_hint_ident = Id.of_string "H" @@ -1296,7 +1297,9 @@ let interp_hints poly = | HintsExtern (pri, patcom, tacexp) -> let pat = Option.map fp patcom in let l = match pat with None -> [] | Some (l, _) -> l in - let tacexp = Hook.get forward_intern_tac l tacexp in + let ltacvars = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in + let env = Genintern.({ genv = env; ltacvars }) in + let _, tacexp = Genintern.generic_intern env tacexp in HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) let add_hints local dbnames0 h = @@ -1389,7 +1392,7 @@ let pr_hint h = match h.obj with env with e when CErrors.noncritical e -> Global.env () in - (str "(*external*) " ++ Pptactic.pr_glb_generic env tac) + (str "(*external*) " ++ Pputils.pr_glb_generic env tac) let pr_id_hint (id, v) = let pr_pat p = str", pattern " ++ pr_lconstr_pattern p in @@ -1527,6 +1530,6 @@ let run_hint tac k = match !warn_hint with else Proofview.tclBIND (k tac.obj) (fun x -> warn tac x) | `STRICT -> if is_imported tac then k tac.obj - else Proofview.tclZERO (UserError ("", (str "Tactic failure."))) + else Proofview.tclZERO (UserError (None, (str "Tactic failure."))) let repr_hint h = h.obj diff --git a/tactics/hints.mli b/tactics/hints.mli index 1be3e0c52..05d41adfe 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -15,6 +15,7 @@ open Globnames open Decl_kinds open Evd open Misctypes +open Tactypes open Clenv open Pattern open Vernacexpr @@ -25,6 +26,8 @@ exception Bound val decompose_app_bound : constr -> global_reference * constr array +type debug = Debug | Info | Off + val secvars_of_hyps : Context.Named.t -> Id.Pred.t val empty_hint_info : 'a hint_info_gen @@ -154,7 +157,7 @@ type hints_entry = | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsModeEntry of global_reference * hint_mode list - | HintsExternEntry of hint_info * Tacexpr.glob_tactic_expr + | HintsExternEntry of hint_info * Genarg.glob_generic_argument val searchtable_map : hint_db_name -> hint_db @@ -233,7 +236,7 @@ val make_resolve_hyp : (** [make_extern pri pattern tactic_expr] *) val make_extern : - int -> constr_pattern option -> Tacexpr.glob_tactic_expr + int -> constr_pattern option -> Genarg.glob_generic_argument -> hint_entry val run_hint : hint -> @@ -243,14 +246,11 @@ val run_hint : hint -> written code. *) val repr_hint : hint -> (raw_hint * clausenv) hint_ast -val extern_intern_tac : - (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr) Hook.t - (** Create a Hint database from the pairs (name, constr). Useful to take the current goal hypotheses as hints; Boolean tells if lemmas with evars are allowed *) -val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> Tacexpr.delayed_open_constr list -> hint_db +val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> delayed_open_constr list -> hint_db val make_db_list : hint_db_name list -> hint_db list diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 7b52a9cee..27af7200b 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -19,6 +19,8 @@ open Declarations open Tacmach.New open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (* I implemented the following functions which test whether a term t is an inductive but non-recursive type, a general conjuction, a general disjunction, or a type with no constructors. @@ -100,7 +102,7 @@ let match_with_one_constructor style onlybinary allow_rec t = (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in if List.for_all - (fun decl -> let c = get_type decl in + (fun decl -> let c = RelDecl.get_type decl in is_local_assum decl && isRel c && Int.equal (destRel c) mib.mind_nparams) ctx @@ -109,7 +111,7 @@ let match_with_one_constructor style onlybinary allow_rec t = else None else let ctyp = prod_applist mip.mind_nf_lc.(0) args in - let cargs = List.map get_type (prod_assum ctyp) in + let cargs = List.map RelDecl.get_type (prod_assum ctyp) in if not (is_lax_conjunction style) || has_nodep_prod ctyp then (* Record or non strict conjunction *) Some (hdapp,List.rev cargs) @@ -450,7 +452,7 @@ let find_this_eq_data_decompose gl eqn = try (*first_match (match_eq eqn) inversible_equalities*) find_eq_data eqn with PatternMatchingFailure -> - errorlabstrm "" (str "No primitive equality found.") in + user_err (str "No primitive equality found.") in let eq_args = try extract_eq_args gl eq_args with PatternMatchingFailure -> diff --git a/tactics/inv.ml b/tactics/inv.ml index bda16b01c..e7d8249e4 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -25,10 +25,10 @@ open Tactics open Elim open Equality open Misctypes -open Tacexpr open Sigma.Notations open Proofview.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration let var_occurs_in_pf gl id = let env = Proofview.Goal.env gl in @@ -76,7 +76,7 @@ let make_inv_predicate env evd indf realargs id status concl = (hyps_arity,concl) | Dep dflt_concl -> if not (occur_var env id concl) then - errorlabstrm "make_inv_predicate" + user_err ~hdr:"make_inv_predicate" (str "Current goal does not depend on " ++ pr_id id ++ str"."); (* We abstract the conclusion of goal with respect to realargs and c to * be concl in order to rewrite and have @@ -182,7 +182,7 @@ let dependent_hyps env id idlist gl = | [] -> [] | d::l -> (* Update the type of id1: it may have been subject to rewriting *) - let d = pf_get_hyp (get_id d) gl in + let d = pf_get_hyp (NamedDecl.get_id d) gl in if occur_var_in_decl env id d then d :: dep_rec l else dep_rec l @@ -192,7 +192,7 @@ let dependent_hyps env id idlist gl = let split_dep_and_nodep hyps gl = List.fold_right (fun d (l1,l2) -> - if var_occurs_in_pf gl (get_id d) then (d::l1,l2) else (l1,d::l2)) + if var_occurs_in_pf gl (NamedDecl.get_id d) then (d::l1,l2) else (l1,d::l2)) hyps ([],[]) (* Computation of dids is late; must have been done in rewrite_equations*) @@ -383,7 +383,7 @@ let rewrite_equations as_mode othin neqns names ba = Proofview.Goal.nf_enter { enter = begin fun gl -> let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in let first_eq = ref MoveLast in - let avoid = if as_mode then List.map get_id nodepids else [] in + let avoid = if as_mode then List.map NamedDecl.get_id nodepids else [] in match othin with | Some thin -> tclTHENLIST @@ -399,10 +399,10 @@ let rewrite_equations as_mode othin neqns names ba = tclTRY (projectAndApply as_mode thin avoid id first_eq names depids))))) names; tclMAP (fun d -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) - let idopt = if as_mode then Some (get_id d) else None in + let idopt = if as_mode then Some (NamedDecl.get_id d) else None in intro_move idopt (if thin then MoveLast else !first_eq)) nodepids; - (tclMAP (fun d -> tclTRY (clear [get_id d])) depids)] + (tclMAP (fun d -> tclTRY (clear [NamedDecl.get_id d])) depids)] | None -> (* simple inversion *) if as_mode then @@ -440,7 +440,7 @@ let raw_inversion inv_kind id status names = try pf_apply Tacred.reduce_to_atomic_ind gl (pf_unsafe_type_of gl c) with UserError _ -> let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in - CErrors.errorlabstrm "" msg + CErrors.user_err msg in let IndType (indf,realargs) = find_rectype env sigma t in let evdref = ref sigma in @@ -496,8 +496,6 @@ let inversion inv_kind status names id = let inv_gen thin status names = try_intros_until (inversion thin status names) -open Tacexpr - let inv k = inv_gen k NoDep let inv_tac id = inv FullInversion None (NamedHyp id) diff --git a/tactics/inv.mli b/tactics/inv.mli index af1cb996a..df629e7c9 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -9,7 +9,7 @@ open Names open Term open Misctypes -open Tacexpr +open Tactypes type inversion_status = Dep of constr option | NoDep diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 40b600c89..10fc5076c 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -29,6 +29,8 @@ open Decl_kinds open Proofview.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + let no_inductive_inconstr env sigma constr = (str "Cannot recognize an inductive predicate in " ++ pr_lconstr_env env sigma constr ++ @@ -156,7 +158,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let revargs,ownsign = fold_named_context (fun env d (revargs,hyps) -> - let id = get_id d in + let id = NamedDecl.get_id d in if Id.List.mem id ivars then ((mkVar id)::revargs, Context.Named.add d hyps) else @@ -183,7 +185,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let ind = try find_rectype env sigma i with Not_found -> - errorlabstrm "inversion_scheme" (no_inductive_inconstr env sigma i) + user_err ~hdr:"inversion_scheme" (no_inductive_inconstr env sigma i) in let (invEnv,invGoal) = compute_first_inversion_scheme env sigma ind sort dep_option @@ -193,7 +195,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = (global_vars env invGoal) (ids_of_named_context (named_context invEnv))); (* - errorlabstrm "lemma_inversion" + user_err ~hdr:"lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) let pf = Proof.start (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in @@ -206,7 +208,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let ownSign = ref begin fold_named_context (fun env d sign -> - if mem_named_context_val (get_id d) global_named_context then sign + if mem_named_context_val (NamedDecl.get_id d) global_named_context then sign else Context.Named.add d sign) invEnv ~init:Context.Named.empty end in @@ -247,8 +249,8 @@ let add_inversion_lemma_exn na com comsort bool tac = try add_inversion_lemma na env sigma c sort bool tac with - | UserError ("Case analysis",s) -> (* Reference to Indrec *) - errorlabstrm "Inv needs Nodep Prop Set" s + | UserError (Some "Case analysis",s) -> (* Reference to Indrec *) + user_err ~hdr:"Inv needs Nodep Prop Set" s (* ================================= *) (* Applying a given inversion lemma *) @@ -261,10 +263,10 @@ let lemInv id c gls = Proofview.V82.of_tactic (Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false) gls with | NoSuchBinding -> - errorlabstrm "" + user_err (hov 0 (pr_constr c ++ spc () ++ str "does not refer to an inversion lemma.")) | UserError (a,b) -> - errorlabstrm "LemInv" + user_err ~hdr:"LemInv" (str "Cannot refine current goal with the lemma " ++ pr_lconstr_env (Refiner.pf_env gls) (Refiner.project gls) c) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 66da9ee18..c5562b326 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -15,8 +15,10 @@ open Termops open Declarations open Tacmach open Clenv +open Tactypes open Sigma.Notations -open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (************************************************************************) (* Tacticals re-exported from the Refiner module *) @@ -70,7 +72,7 @@ let nthDecl m gl = try List.nth (pf_hyps gl) (m-1) with Failure _ -> error "No such assumption." -let nthHypId m gl = nthDecl m gl |> get_id +let nthHypId m gl = nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = mkVar (nthHypId m gl) let lastDecl gl = nthDecl 1 gl @@ -81,7 +83,7 @@ let nLastDecls n gl = try List.firstn n (pf_hyps gl) with Failure _ -> error "Not enough hypotheses in the goal." -let nLastHypsId n gl = List.map get_id (nLastDecls n gl) +let nLastHypsId n gl = List.map NamedDecl.get_id (nLastDecls n gl) let nLastHyps n gl = List.map mkVar (nLastHypsId n gl) let onNthDecl m tac gl = tac (nthDecl m gl) gl @@ -99,7 +101,7 @@ let onNLastHypsId n tac = onHyps (nLastHypsId n) tac let onNLastHyps n tac = onHyps (nLastHyps n) tac let afterHyp id gl = - fst (List.split_when (Id.equal id % get_id) (pf_hyps gl)) + fst (List.split_when (NamedDecl.get_id %> Id.equal id) (pf_hyps gl)) (***************************************) (* Clause Tacticals *) @@ -151,7 +153,7 @@ type branch_args = { nassums : int; (* number of assumptions/letin to be introduced *) branchsign : bool list; (* the signature of the branch. true=assumption, false=let-in *) - branchnames : Tacexpr.intro_patterns} + branchnames : intro_patterns} type branch_assumptions = { ba : branch_args; (* the branch args *) @@ -172,14 +174,14 @@ let check_or_and_pattern_size check_and loc names branchsigns = let n = Array.length branchsigns in let msg p1 p2 = strbrk "a conjunctive pattern made of " ++ int p1 ++ (if p1 == p2 then mt () else str " or " ++ int p2) ++ str " patterns" in let err1 p1 p2 = - user_err_loc (loc,"",str "Expects " ++ msg p1 p2 ++ str ".") in + user_err ~loc (str "Expects " ++ msg p1 p2 ++ str ".") in let errn n = - user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n + user_err ~loc (str "Expects a disjunctive pattern with " ++ int n ++ str " branches.") in let err1' p1 p2 = - user_err_loc (loc,"",strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in + user_err ~loc (strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in let errforthcoming loc = - user_err_loc (loc,"",strbrk "Unexpected non atomic pattern.") in + user_err ~loc (strbrk "Unexpected non atomic pattern.") in match names with | IntroAndPattern l -> if not (Int.equal n 1) then errn n; @@ -311,7 +313,7 @@ module New = struct tclZERO (Refiner.FailError (lvl,lazy msg)) let tclZEROMSG ?loc msg = - let err = UserError ("", msg) in + let err = UserError (None, msg) in let info = match loc with | None -> Exninfo.null | Some loc -> Loc.add_loc Exninfo.null loc @@ -366,6 +368,16 @@ module New = struct catch_failerror e <*> t2 end end + + let tclORELSE0L t1 t2 = + tclINDEPENDENTL begin + tclORELSE + t1 + begin fun e -> + catch_failerror e <*> t2 + end + end + let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2 @@ -417,6 +429,9 @@ module New = struct let tclTRY t = tclORELSE0 t (tclUNIT ()) + + let tclTRYb t = + tclORELSE0L (t <*> tclUNIT true) (tclUNIT false) let tclIFTHENELSE t1 t2 t3 = tclINDEPENDENT begin @@ -478,10 +493,10 @@ module New = struct (* Select a subset of the goals *) let tclSELECT = function - | Tacexpr.SelectNth i -> Proofview.tclFOCUS i i - | Tacexpr.SelectList l -> Proofview.tclFOCUSLIST l - | Tacexpr.SelectId id -> Proofview.tclFOCUSID id - | Tacexpr.SelectAll -> fun tac -> tac + | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i + | Vernacexpr.SelectList l -> Proofview.tclFOCUSLIST l + | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id + | Vernacexpr.SelectAll -> fun tac -> tac (* Check that holes in arguments have been resolved *) @@ -508,7 +523,7 @@ module New = struct | [] -> () | (evk,evi) :: _ -> let (loc,_) = evi.Evd.evar_source in - Pretype_errors.error_unsolvable_implicit loc env sigma evk None + Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None let tclWITHHOLES accept_unresolved_holes tac sigma = tclEVARMAP >>= fun sigma_initial -> @@ -532,7 +547,7 @@ module New = struct Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let Sigma (x, sigma, _) = x.Tacexpr.delayed env sigma in + let Sigma (x, sigma, _) = x.delayed env sigma in tclWITHHOLES check (tac x) (Sigma.to_evar_map sigma) end } @@ -560,7 +575,7 @@ module New = struct let nthHypId m gl = (** We only use [id] *) let gl = Proofview.Goal.assume gl in - nthDecl m gl |> get_id + nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = mkVar (nthHypId m gl) @@ -592,7 +607,7 @@ module New = struct let afterHyp id tac = Proofview.Goal.enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let rem, _ = List.split_when (Id.equal id % get_id) hyps in + let rem, _ = List.split_when (NamedDecl.get_id %> Id.equal id) hyps in tac rem end } @@ -643,7 +658,7 @@ module New = struct | Var id -> string_of_id id | _ -> "\b" in - errorlabstrm "Tacticals.general_elim_then_using" + user_err ~hdr:"Tacticals.general_elim_then_using" (str "The elimination combinator " ++ str name_elim ++ str " is unknown.") in let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index cfdc2cffd..7aacc52f3 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -11,9 +11,9 @@ open Names open Term open Tacmach open Proof_type -open Tacexpr open Locus open Misctypes +open Tactypes (** Tacticals i.e. functions from tactics to tactics. *) @@ -209,6 +209,7 @@ module New : sig val tclMAP : ('a -> unit tactic) -> 'a list -> unit tactic val tclTRY : unit tactic -> unit tactic + val tclTRYb : unit tactic -> bool list tactic val tclFIRST : unit tactic list -> unit tactic val tclIFTHENELSE : unit tactic -> unit tactic -> unit tactic -> unit tactic val tclIFTHENSVELSE : unit tactic -> unit tactic array -> unit tactic -> unit tactic @@ -221,7 +222,7 @@ module New : sig val tclCOMPLETE : 'a tactic -> 'a tactic val tclSOLVE : unit tactic list -> unit tactic val tclPROGRESS : unit tactic -> unit tactic - val tclSELECT : goal_selector -> 'a tactic -> 'a tactic + val tclSELECT : Vernacexpr.goal_selector -> 'a tactic -> 'a tactic val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic val tclDELAYEDWITHHOLES : bool -> 'a delayed_open -> ('a -> unit tactic) -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f186f6e0e..8a78037ce 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -32,7 +32,6 @@ open Refiner open Tacticals open Hipattern open Coqlib -open Tacexpr open Decl_kinds open Evarutil open Indrec @@ -41,8 +40,13 @@ open Unification open Locus open Locusops open Misctypes +open Tactypes open Proofview.Notations open Sigma.Notations +open Context.Named.Declaration + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration let inj_with_occurrences e = (AllOccurrences,e) @@ -52,7 +56,7 @@ let typ_of env sigma c = let open Retyping in try get_type_of ~lax:true env (Sigma.to_evar_map sigma) c with RetypeError e -> - user_err_loc (Loc.ghost, "", print_retype_error e) + user_err (print_retype_error e) open Goptions @@ -166,19 +170,17 @@ let _ = (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) let unsafe_intro env store decl b = - let open Context.Named.Declaration in Refine.refine ~unsafe:true { run = begin fun sigma -> let ctx = named_context_val env in let nctx = push_named_context_val decl ctx in - let inst = List.map (mkVar % get_id) (named_context env) in + let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in let ninst = mkRel 1 :: inst in - let nb = subst1 (mkVar (get_id decl)) b in + let nb = subst1 (mkVar (NamedDecl.get_id decl)) b in let Sigma (ev, sigma, p) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in Sigma (mkNamedLambda_or_LetIn decl ev, sigma, p) end } let introduction ?(check=true) id = - let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in @@ -187,9 +189,10 @@ let introduction ?(check=true) id = let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in let () = if check && mem_named_context_val id hyps then - errorlabstrm "Tactics.introduction" + user_err ~hdr:"Tactics.introduction" (str "Variable " ++ pr_id id ++ str " is already declared.") in + let open Context.Named.Declaration in match kind_of_term (whd_evar sigma concl) with | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b @@ -259,7 +262,7 @@ let clear_dependency_msg env sigma id = function Printer.pr_existential env sigma ev ++ str"." let error_clear_dependency env sigma id err = - errorlabstrm "" (clear_dependency_msg env sigma id err) + user_err (clear_dependency_msg env sigma id err) let replacing_dependency_msg env sigma id = function | Evarutil.OccurHypInSimpleClause None -> @@ -273,7 +276,7 @@ let replacing_dependency_msg env sigma id = function Printer.pr_existential env sigma ev ++ str"." let error_replacing_dependency env sigma id err = - errorlabstrm "" (replacing_dependency_msg env sigma id err) + user_err (replacing_dependency_msg env sigma id err) (* This tactic enables the user to remove hypotheses from the signature. * Some care is taken to prevent him from removing variables that are @@ -332,7 +335,6 @@ let move_hyp id dest = (* Renaming hypotheses *) let rename_hyp repl = - let open Context.Named.Declaration in let fold accu (src, dst) = match accu with | None -> None | Some (srcs, dsts) -> @@ -354,7 +356,7 @@ let rename_hyp repl = let concl = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in (** Check that we do not mess variables *) - let fold accu decl = Id.Set.add (get_id decl) accu in + let fold accu decl = Id.Set.add (NamedDecl.get_id decl) accu in let vars = List.fold_left fold Id.Set.empty hyps in let () = if not (Id.Set.subset src vars) then @@ -365,7 +367,7 @@ let rename_hyp repl = let () = try let elt = Id.Set.choose (Id.Set.inter dst mods) in - CErrors.errorlabstrm "" (pr_id elt ++ str " is already used") + CErrors.user_err (pr_id elt ++ str " is already used") with Not_found -> () in (** All is well *) @@ -373,13 +375,13 @@ let rename_hyp repl = let subst = List.map make_subst repl in let subst c = Vars.replace_vars subst c in let map decl = - decl |> map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) - |> map_constr subst + decl |> NamedDecl.map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) + |> NamedDecl.map_constr subst in let nhyps = List.map map hyps in let nconcl = subst concl in let nctx = Environ.val_of_named_context nhyps in - let instance = List.map (mkVar % get_id) hyps in + let instance = List.map (NamedDecl.get_id %> mkVar) hyps in Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance end } @@ -438,7 +440,7 @@ let find_name mayrepl decl naming gl = match naming with let ids_of_hyps = Tacmach.New.pf_ids_of_hyps gl in let id' = next_ident_away id ids_of_hyps in if not mayrepl && not (Id.equal id' id) then - user_err_loc (loc,"",pr_id id ++ str" is already used."); + user_err ~loc (pr_id id ++ str" is already used."); id (**************************************************************) @@ -523,7 +525,7 @@ let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> if not (eq_mind sp sp') then error "Fixpoints should be on the same mutual inductive declaration."; if mem_named_context_val f sign then - errorlabstrm "Logic.prim_refiner" + user_err ~hdr:"Logic.prim_refiner" (str "Name " ++ pr_id f ++ str " already used in the environment"); mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in @@ -614,7 +616,7 @@ let pf_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); LocalAssum (id,redfun' ty) | LocalDef (id,b,ty) -> let b' = if where != InHypTypeOnly then redfun' b else b in @@ -715,7 +717,7 @@ let pf_e_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = redfun sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> @@ -755,7 +757,7 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str " has no value."); + user_err (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> @@ -793,12 +795,12 @@ let check_types env sigma mayneedglobalcheck deep newc origc = isSort (whd_all env sigma t2) then (mayneedglobalcheck := true; sigma) else - errorlabstrm "convert-check-hyp" (str "Types are incompatible.") + user_err ~hdr:"convert-check-hyp" (str "Types are incompatible.") else sigma end else if not (isSort (whd_all env sigma t1)) then - errorlabstrm "convert-check-hyp" (str "Not a type.") + user_err ~hdr:"convert-check-hyp" (str "Not a type.") else sigma (* Now we introduce different instances of the previous tacticals *) @@ -807,7 +809,7 @@ let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun en let sigma = Sigma.to_evar_map sigma in let sigma = check_types env sigma mayneedglobalcheck deep t' c in let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in - if not b then errorlabstrm "convert-check-hyp" (str "Not convertible."); + if not b then user_err ~hdr:"convert-check-hyp" (str "Not convertible."); Sigma.Unsafe.of_pair (t', sigma) end } @@ -884,7 +886,11 @@ let reduction_clause redexp cl = (None, bind_red_expr_occurrences occs nbcl redexp)) cl let reduce redexp cl = - let trace () = Pp.(hov 2 (Pptactic.pr_atomic_tactic (Global.env()) (TacReduce (redexp,cl)))) in + let trace () = + let open Printer in + let pr = (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern) in + Pp.(hov 2 (Pputils.pr_red_expr pr str redexp)) + in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter { enter = begin fun gl -> let cl' = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in @@ -901,7 +907,7 @@ let reduce redexp cl = let unfold_constr = function | ConstRef sp -> unfold_in_concl [AllOccurrences,EvalConstRef sp] | VarRef id -> unfold_in_concl [AllOccurrences,EvalVarRef id] - | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.") + | _ -> user_err ~hdr:"unfold_constr" (str "Cannot unfold a non-constant.") (*******************************************) (* Introduction tactics *) @@ -1000,23 +1006,21 @@ let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = aux n [] let get_next_hyp_position id gl = - let open Context.Named.Declaration in let rec aux = function | [] -> raise (RefinerError (NoSuchHyp id)) | decl :: right -> - if Id.equal (get_id decl) id then - match right with decl::_ -> MoveBefore (get_id decl) | [] -> MoveLast + if Id.equal (NamedDecl.get_id decl) id then + match right with decl::_ -> MoveBefore (NamedDecl.get_id decl) | [] -> MoveLast else aux right in aux (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let get_previous_hyp_position id gl = - let open Context.Named.Declaration in let rec aux dest = function | [] -> raise (RefinerError (NoSuchHyp id)) | decl :: right -> - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if Id.equal hyp id then dest else aux (MoveAfter hyp) right in aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) @@ -1096,7 +1100,7 @@ let depth_of_quantified_hypothesis red h gl = match lookup_hypothesis_as_renamed_gen red h gl with | Some depth -> depth | None -> - errorlabstrm "lookup_quantified_hypothesis" + user_err ~hdr:"lookup_quantified_hypothesis" (str "No " ++ msg_quantified_hypothesis h ++ strbrk " in current goal" ++ (if red then strbrk " even after head-reduction" else mt ()) ++ @@ -1245,7 +1249,7 @@ let cut c = let error_uninstantiated_metas t clenv = let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta") - in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".") + in user_err (str "Cannot find an instance for " ++ pr_id id ++ str".") let check_unresolved_evars_of_metas sigma clenv = (* This checks that Metas turned into Evars by *) @@ -1378,7 +1382,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags let indmv = (match kind_of_term (nth_arg i elimclause.templval.rebus) with | Meta mv -> mv - | _ -> errorlabstrm "elimination_clause" + | _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.")) in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in @@ -1543,7 +1547,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) try match List.remove Int.equal indmv (clenv_independent elimclause) with | [a] -> a | _ -> failwith "" - with Failure _ -> errorlabstrm "elimination_clause" + with Failure _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.") in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in let hyp = mkVar id in @@ -1552,7 +1556,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in if Term.eq_constr hyp_typ new_hyp_typ then - errorlabstrm "general_rewrite_in" + user_err ~hdr:"general_rewrite_in" (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id id sigma elimclause'' (fun id -> Proofview.tclUNIT ()) @@ -1577,7 +1581,7 @@ let make_projection env sigma params cstr sign elim i n c u = | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) let decl = List.nth cstr.cs_args i in - let t = get_type decl in + let t = RelDecl.get_type decl in let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> b in let branch = it_mkLambda_or_LetIn b cstr.cs_args in if @@ -1811,24 +1815,37 @@ let find_matching_clause unifier clause = with NotExtensibleClause -> failwith "Cannot apply" in find clause +exception UnableToApply + let progress_with_clause flags innerclause clause = let ordered_metas = List.rev (clenv_independent clause) in - if List.is_empty ordered_metas then error "Statement without assumptions."; + if List.is_empty ordered_metas then raise UnableToApply; let f mv = try Some (find_matching_clause (clenv_fchain ~with_univs:false mv ~flags clause) innerclause) with Failure _ -> None in try List.find_map f ordered_metas - with Not_found -> error "Unable to unify." + with Not_found -> raise UnableToApply -let apply_in_once_main flags innerclause env sigma (d,lbind) = +let explain_unable_to_apply_lemma loc env sigma thm innerclause = + user_err ~loc (hov 0 + (Pp.str "Unable to apply lemma of type" ++ brk(1,1) ++ + Pp.quote (Printer.pr_lconstr_env env sigma thm) ++ spc() ++ + str "on hypothesis of type" ++ brk(1,1) ++ + Pp.quote (Printer.pr_lconstr_env innerclause.env innerclause.evd (clenv_type innerclause)) ++ + str ".")) + +let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> - let e = CErrors.push e in + let e' = CErrors.push e in try aux (clenv_push_prod clause) - with NotExtensibleClause -> iraise e + with NotExtensibleClause -> + match e with + | UnableToApply -> explain_unable_to_apply_lemma loc env sigma thm innerclause + | _ -> iraise e' in aux (make_clenv_binding env sigma (d,thm) lbind) @@ -1848,7 +1865,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try - let clause = apply_in_once_main flags innerclause env sigma (c,lbind) in + let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in clenv_refine_in ~sidecond_first with_evars targetid id sigma clause (fun id -> Tacticals.New.tclTHENLIST [ @@ -1959,7 +1976,6 @@ let exact_proof c = end } let assumption = - let open Context.Named.Declaration in let rec arec gl only_eq = function | [] -> if only_eq then @@ -1967,7 +1983,7 @@ let assumption = arec gl false hyps else Tacticals.New.tclZEROMSG (str "No such assumption.") | decl::rest -> - let t = get_type decl in + let t = NamedDecl.get_type decl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let (sigma, is_same_type) = @@ -1978,7 +1994,7 @@ let assumption = in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> - exact_no_check (mkVar (get_id decl)) + exact_no_check (mkVar (NamedDecl.get_id decl)) else arec gl only_eq rest in let assumption_tac = { enter = begin fun gl -> @@ -2008,7 +2024,7 @@ let check_is_type env sigma ty = let check_decl env sigma decl = let open Context.Named.Declaration in - let ty = get_type decl in + let ty = NamedDecl.get_type decl in let evdref = ref sigma in try let _ = Typing.e_sort_of env evdref ty in @@ -2018,7 +2034,7 @@ let check_decl env sigma decl = in !evdref with e when CErrors.noncritical e -> - let id = get_id decl in + let id = NamedDecl.get_id decl in raise (DependsOnBody (Some id)) let clear_body ids = @@ -2031,7 +2047,7 @@ let clear_body ids = let map = function | LocalAssum (id,t) as decl -> let () = if List.mem_f Id.equal id ids then - errorlabstrm "" (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") + user_err (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") in decl | LocalDef (id,_,t) as decl -> @@ -2050,7 +2066,7 @@ let clear_body ids = check_decl env sigma decl else sigma in - let seen = seen || List.mem_f Id.equal (get_id decl) ids in + let seen = seen || List.mem_f Id.equal (NamedDecl.get_id decl) ids in (push_named decl env, sigma, seen) in let (env, sigma, _) = List.fold_left check (base_env, sigma, false) (List.rev ctx) in @@ -2090,13 +2106,12 @@ let rec intros_clearing = function (* Keeping only a few hypotheses *) let keep hyps = - let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in let cl,_ = fold_named_context_reverse (fun (clear,keep) decl -> - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if Id.List.mem hyp hyps || List.exists (occur_var_in_decl env hyp) keep || occur_var env hyp ccl @@ -2162,7 +2177,7 @@ let check_number_of_constructors expctdnumopt i nconstr = if Int.equal i 0 then error "The constructors are numbered starting from 1."; begin match expctdnumopt with | Some n when not (Int.equal n nconstr) -> - errorlabstrm "Tactics.check_number_of_constructors" + user_err ~hdr:"Tactics.check_number_of_constructors" (str "Not an inductive goal with " ++ int n ++ str (String.plural n " constructor") ++ str ".") | _ -> () end; @@ -2251,7 +2266,7 @@ let error_unexpected_extra_pattern loc bound pat = | IntroNaming (IntroIdentifier _) -> "name", (String.plural nb " introduction pattern"), "no" | _ -> "introduction pattern", "", "none" in - user_err_loc (loc,"",str "Unexpected " ++ str s1 ++ str " (" ++ + user_err ~loc (str "Unexpected " ++ str s1 ++ str " (" ++ (if Int.equal nb 0 then (str s3 ++ str s2) else (str "at most " ++ int nb ++ str s2)) ++ spc () ++ str (if Int.equal nb 1 then "was" else "were") ++ @@ -2465,7 +2480,7 @@ and intro_pattern_action loc with_evars b style pat thin destopt tac id = intro_decomp_eq loc l' thin tac id | IntroRewrite l2r -> rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None []) - | IntroApplyOn (f,(loc,pat)) -> + | IntroApplyOn ((loc',f),(loc,pat)) -> let naming,tac_ipat = prepare_intros_loc loc with_evars (IntroIdentifier id) destopt pat in let doclear = @@ -2477,7 +2492,7 @@ and intro_pattern_action loc with_evars b style pat thin destopt tac id = let Sigma (c, sigma, p) = f.delayed env sigma in Sigma ((c, NoBindings), sigma, p) } in - apply_in_delayed_once false true true with_evars naming id (None,(loc,f)) + apply_in_delayed_once false true true with_evars naming id (None,(loc',f)) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros_loc loc with_evars dft destopt = function @@ -2491,8 +2506,8 @@ and prepare_intros_loc loc with_evars dft destopt = function (fun _ l -> clear_wildcards l) in fun id -> intro_pattern_action loc with_evars true true ipat [] destopt tac id) - | IntroForthcoming _ -> user_err_loc - (loc,"",str "Introduction pattern for one hypothesis expected.") + | IntroForthcoming _ -> user_err ~loc + (str "Introduction pattern for one hypothesis expected.") let intro_patterns_bound_to with_evars n destopt = intro_patterns_core with_evars true [] [] [] destopt @@ -2634,13 +2649,12 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = end } let insert_before decls lasthyp env = - let open Context.Named.Declaration in match lasthyp with | None -> push_named_context decls env | Some id -> Environ.fold_named_context (fun _ d env -> - let env = if Id.equal id (get_id d) then push_named_context decls env else env in + let env = if Id.equal id (NamedDecl.get_id d) then push_named_context decls env else env in push_named d env) ~init:(reset_context env) env @@ -2659,7 +2673,7 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = | IntroFresh heq_base -> fresh_id_in_env [id] heq_base env | IntroIdentifier id -> if List.mem id (ids_of_named_context (named_context env)) then - user_err_loc (loc,"",pr_id id ++ str" is already used."); + user_err ~loc (pr_id id ++ str" is already used."); id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in @@ -2741,7 +2755,7 @@ let enough_by na t tac = forward false (Some (Some tac)) (ipat_of_name na) t let generalized_name c t ids cl = function | Name id as na -> if Id.List.mem id ids then - errorlabstrm "" (pr_id id ++ str " is already used."); + user_err (pr_id id ++ str " is already used."); na | Anonymous -> match kind_of_term c with @@ -2779,19 +2793,18 @@ let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = generalize_goal_gen env sigma ids i o t cl let old_generalize_dep ?(with_let=false) c gl = - let open Context.Named.Declaration in let env = pf_env gl in let sign = pf_hyps gl in let init_ids = ids_of_named_context (Global.named_context()) in let seek (d:Context.Named.Declaration.t) (toquant:Context.Named.t) = - if List.exists (fun d' -> occur_var_in_decl env (get_id d') d) toquant + if List.exists (fun d' -> occur_var_in_decl env (NamedDecl.get_id d') d) toquant || dependent_in_decl c d then d::toquant else toquant in let to_quantify = Context.Named.fold_outside seek sign ~init:[] in let to_quantify_rev = List.rev to_quantify in - let qhyps = List.map get_id to_quantify_rev in + let qhyps = List.map NamedDecl.get_id to_quantify_rev in let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in let tothin' = match kind_of_term c with @@ -2803,7 +2816,7 @@ let old_generalize_dep ?(with_let=false) c gl = let body = if with_let then match kind_of_term c with - | Var id -> Tacmach.pf_get_hyp gl id |> get_value + | Var id -> id |> Tacmach.pf_get_hyp gl |> NamedDecl.get_value | _ -> None else None in @@ -2906,7 +2919,7 @@ let specialize (c,lbind) ipat = let tstack = chk tstack in let term = applist(thd,List.map (nf_evar clause.evd) tstack) in if occur_meta term then - errorlabstrm "" (str "Cannot infer an instance for " ++ + user_err (str "Cannot infer an instance for " ++ pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ str "."); @@ -2951,12 +2964,12 @@ let unfold_body x = (** We normalize the given hypothesis immediately. *) let env = Proofview.Goal.env (Proofview.Goal.assume gl) in let xval = match Environ.lookup_named x env with - | LocalAssum _ -> errorlabstrm "unfold_body" + | LocalAssum _ -> user_err ~hdr:"unfold_body" (pr_id x ++ str" is not a defined hypothesis.") | LocalDef (_,xval,_) -> xval in Tacticals.New.afterHyp x begin fun aft -> - let hl = List.fold_right (fun decl cl -> (get_id decl, InHyp) :: cl) aft [] in + let hl = List.fold_right (fun decl cl -> (NamedDecl.get_id decl, InHyp) :: cl) aft [] in let rfun _ _ c = replace_vars [x, xval] c in let reducth h = reduct_in_hyp rfun h in let reductc = reduct_in_concl (rfun, DEFAULTcast) in @@ -3048,7 +3061,7 @@ let safe_dest_intro_patterns with_evars avoid thin dest pat tac = Proofview.tclORELSE (dest_intro_patterns with_evars avoid thin dest pat tac) begin function (e, info) -> match e with - | UserError ("move_hyp",_) -> + | UserError (Some "move_hyp",_) -> (* May happen e.g. with "destruct x using s" with an hypothesis which is morally an induction hypothesis to be "MoveLast" if known as such but which is considered instead as a subterm of @@ -3275,7 +3288,6 @@ exception Shunt of Id.t move_location let cook_sign hyp0_opt inhyps indvars env = (* First phase from L to R: get [toclear], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) - let open Context.Named.Declaration in let toclear = ref [] in let avoid = ref [] in let decldeps = ref [] in @@ -3285,7 +3297,7 @@ let cook_sign hyp0_opt inhyps indvars env = let before = ref true in let maindep = ref false in let seek_deps env decl rhyp = - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then begin before:=false; @@ -3304,7 +3316,7 @@ let cook_sign hyp0_opt inhyps indvars env = in let depother = List.is_empty inhyps && (List.exists (fun id -> occur_var_in_decl env id decl) indvars || - List.exists (fun decl' -> occur_var_in_decl env (get_id decl') decl) !decldeps) + List.exists (fun decl' -> occur_var_in_decl env (NamedDecl.get_id decl') decl) !decldeps) in if not (List.is_empty inhyps) && Id.List.mem hyp inhyps || dephyp0 || depother @@ -3327,7 +3339,7 @@ let cook_sign hyp0_opt inhyps indvars env = let _ = fold_named_context seek_deps env ~init:MoveFirst in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) let compute_lstatus lhyp decl = - let hyp = get_id decl in + let hyp = NamedDecl.get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then raise (Shunt lhyp); if Id.List.mem hyp !ldeps then begin @@ -3448,7 +3460,7 @@ let make_up_names n ind_opt cname = let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in - errorlabstrm "Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") + user_err ~hdr:"Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") let glob = Universes.constr_of_global @@ -3495,8 +3507,8 @@ let ids_of_constr ?(all=false) vars c = Array.fold_left_from (if all then 0 else mib.Declarations.mind_nparams) aux vars args - | _ -> fold_constr aux vars c) - | _ -> fold_constr aux vars c + | _ -> Term.fold_constr aux vars c) + | _ -> Term.fold_constr aux vars c in aux vars c let decompose_indapp f args = @@ -3551,13 +3563,12 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = end } let hyps_of_vars env sign nogen hyps = - let open Context.Named.Declaration in if Id.Set.is_empty hyps then [] else let (_,lh) = Context.Named.fold_inside (fun (hs,hl) d -> - let x = get_id d in + let x = NamedDecl.get_id d in if Id.Set.mem x nogen then (hs,hl) else if Id.Set.mem x hs then (hs,x::hl) else @@ -3587,8 +3598,7 @@ let linear vars args = with Seen -> false let is_defined_variable env id = - let open Context.Named.Declaration in - lookup_named id env |> is_local_def + env |> lookup_named id |> is_local_def let abstract_args gl generalize_vars dep id defined f args = let open Context.Rel.Declaration in @@ -3611,7 +3621,7 @@ let abstract_args gl generalize_vars dep id defined f args = let name, ty, arity = let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in let decl = List.hd rel in - get_name decl, get_type decl, c + RelDecl.get_name decl, RelDecl.get_type decl, c in let argty = Tacmach.pf_unsafe_type_of gl arg in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in @@ -4046,14 +4056,15 @@ let is_functional_induction elimc gl = need a dependent one or not *) let get_eliminator elim dep s gl = - let open Context.Rel.Declaration in match elim with | ElimUsing (elim,indsign) -> Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in - let branchlengthes = List.map (fun d -> assert (is_local_assum d); pi1 (decompose_prod_letin (get_type d))) (List.rev s.branches) in + let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (RelDecl.get_type d))) + (List.rev s.branches) + in evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l (* Instantiate all meta variables of elimclause using lid, some elts @@ -4066,7 +4077,7 @@ let recolle_clenv i params args elimclause gl = (fun x -> match kind_of_term x with | Meta mv -> mv - | _ -> errorlabstrm "elimination_clause" + | _ -> user_err ~hdr:"elimination_clause" (str "The type of the elimination clause is not well-formed.")) arr in let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in @@ -4115,7 +4126,6 @@ let induction_tac with_evars params indvars elim = induction applies with the induction hypotheses *) let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_tac = - let open Context.Named.Declaration in Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in @@ -4128,7 +4138,7 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let s = Retyping.get_sort_family_of env sigma tmpcl in let deps_cstr = List.fold_left - (fun a decl -> if is_local_assum decl then (mkVar (get_id decl))::a else a) [] deps in + (fun a decl -> if NamedDecl.is_local_assum decl then (mkVar (NamedDecl.get_id decl))::a else a) [] deps in let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in let branchletsigns = let f (_,is_not_let,_,_) = is_not_let in @@ -4210,16 +4220,15 @@ let induction_without_atomization isrec with_evars elim names lid = (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls = Proofview.Goal.nf_enter { enter = begin fun gl -> - let open Context.Named.Declaration in if occur_var (Tacmach.New.pf_env gl) id (Tacmach.New.pf_concl gl) && cls.concl_occs == NoOccurrences - then errorlabstrm "" + then user_err (str "Conclusion must be mentioned: it depends on " ++ pr_id id ++ str "."); match cls.onhyps with | Some hyps -> let to_erase d = - let id' = get_id d in + let id' = NamedDecl.get_id d in if Id.List.mem id' inhyps then (* if selected, do not erase *) None else (* erase if not selected and dependent on id or selected hyps *) @@ -4412,7 +4421,7 @@ let induction_gen_l isrec with_evars elim names lc = let lc = List.map (function | (c,None) -> c | (c,Some(loc,eqname)) -> - user_err_loc (loc,"",str "Do not know what to do with " ++ + user_err ~loc (str "Do not know what to do with " ++ Miscprint.pr_intro_pattern_naming eqname)) lc in let rec atomize_list l = match l with @@ -4786,7 +4795,7 @@ let interpretable_as_section_decl evd d1 d2 = | LocalDef _, LocalAssum _ -> false | LocalDef (_,b1,t1), LocalDef (_,b2,t2) -> e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2 - | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (get_type d2) + | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (NamedDecl.get_type d2) let rec decompose len c t accu = let open Context.Rel.Declaration in @@ -4799,7 +4808,6 @@ let rec decompose len c t accu = | _ -> assert false let rec shrink ctx sign c t accu = - let open Context.Rel.Declaration in match ctx, sign with | [], [] -> (c, t, accu) | p :: ctx, decl :: sign -> @@ -4810,9 +4818,9 @@ let rec shrink ctx sign c t accu = else let c = mkLambda_or_LetIn p c in let t = mkProd_or_LetIn p t in - let accu = if is_local_assum p then let open Context.Named.Declaration in - mkVar (get_id decl) :: accu - else accu + let accu = if RelDecl.is_local_assum p + then mkVar (NamedDecl.get_id decl) :: accu + else accu in shrink ctx sign c t accu | _ -> assert false @@ -4838,7 +4846,6 @@ let abstract_subproof id gk tac = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in - let open Context.Named.Declaration in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let current_sign = Global.named_context_val () @@ -4848,7 +4855,7 @@ let abstract_subproof id gk tac = let sign,secsign = List.fold_right (fun d (s1,s2) -> - let id = get_id d in + let id = NamedDecl.get_id d in if mem_named_context_val id current_sign && interpretable_as_section_decl evdref (lookup_named_val id current_sign) d then (s1,push_named_context_val d s2) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index fb033363e..7acfb6286 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -15,10 +15,10 @@ open Evd open Clenv open Redexpr open Globnames -open Tacexpr open Pattern open Unification open Misctypes +open Tactypes open Locus (** Main tactics defined in ML. This file is huge and should probably be split diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 093302608..f54ad86a3 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -16,7 +16,6 @@ Hints Auto Eauto Class_tactics -Tactic_matching Term_dnet Eqdecide Autorewrite diff --git a/test-suite/bugs/closed/2417.v b/test-suite/bugs/closed/2417.v new file mode 100644 index 000000000..b2f00ffc6 --- /dev/null +++ b/test-suite/bugs/closed/2417.v @@ -0,0 +1,15 @@ +Parameter x y : nat. +Axiom H : x = y. +Hint Rewrite H : mybase. + +Ltac bar base := autorewrite with base. + +Tactic Notation "foo" ident(base) := autorewrite with base. + +Goal x = 0. + bar mybase. + now_show (y = 0). + Undo 2. + foo mybase. + now_show (y = 0). +Abort. diff --git a/test-suite/bugs/closed/3612.v b/test-suite/bugs/closed/3612.v index a54768507..4b4f81dbc 100644 --- a/test-suite/bugs/closed/3612.v +++ b/test-suite/bugs/closed/3612.v @@ -38,8 +38,11 @@ Axiom path_path_sigma : forall {A : Type} (P : A -> Type) (u v : sigT P) (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2), p = q. +Declare ML Module "ltac_plugin". Declare ML Module "coretactics". +Set Default Proof Mode "Classic". + Goal forall (A : Type) (B : forall _ : A, Type) (x : @sigT A (fun x : A => B x)) (xx : @paths (@sigT A (fun x0 : A => B x0)) x x), @paths (@paths (@sigT A (fun x0 : A => B x0)) x x) xx diff --git a/test-suite/bugs/closed/3649.v b/test-suite/bugs/closed/3649.v index fc4c171e2..8687eaab0 100644 --- a/test-suite/bugs/closed/3649.v +++ b/test-suite/bugs/closed/3649.v @@ -2,7 +2,9 @@ (* File reduced by coq-bug-finder from original input, then from 9518 lines to 404 lines, then from 410 lines to 208 lines, then from 162 lines to 77 lines *) (* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *) +Declare ML Module "ltac_plugin". Declare ML Module "coretactics". +Set Default Proof Mode "Classic". Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Reserved Notation "x = y" (at level 70, no associativity). Delimit Scope type_scope with type. diff --git a/test-suite/bugs/closed/4121.v b/test-suite/bugs/closed/4121.v index d34a2b8b1..816bc845f 100644 --- a/test-suite/bugs/closed/4121.v +++ b/test-suite/bugs/closed/4121.v @@ -4,6 +4,8 @@ Unset Strict Universe Declaration. (* coqc version 8.5beta1 (March 2015) compiled on Mar 11 2015 18:51:36 with OCaml 4.01.0 coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (8dbfee5c5f897af8186cb1bdfb04fd4f88eca677) *) +Declare ML Module "ltac_plugin". + Set Universe Polymorphism. Class Contr_internal (A : Type) := BuildContr { center : A }. Arguments center A {_}. @@ -13,4 +15,4 @@ Definition contr_paths_contr0 {A} `{Contr A} : Contr A := {| center := center A Instance contr_paths_contr1 {A} `{Contr A} : Contr A := {| center := center A |}. Check @contr_paths_contr0@{i}. Check @contr_paths_contr1@{i}. (* Error: Universe instance should have length 2 *) -(** It should have length 1, just like contr_paths_contr0 *)
\ No newline at end of file +(** It should have length 1, just like contr_paths_contr0 *) diff --git a/test-suite/bugs/closed/4527.v b/test-suite/bugs/closed/4527.v index 08628377f..c6fcc24b6 100644 --- a/test-suite/bugs/closed/4527.v +++ b/test-suite/bugs/closed/4527.v @@ -5,6 +5,7 @@ then from 269 lines to 255 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) +Declare ML Module "ltac_plugin". Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. diff --git a/test-suite/bugs/closed/4533.v b/test-suite/bugs/closed/4533.v index ae17fb145..64c7fd8eb 100644 --- a/test-suite/bugs/closed/4533.v +++ b/test-suite/bugs/closed/4533.v @@ -5,6 +5,7 @@ then from 285 lines to 271 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) +Declare ML Module "ltac_plugin". Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. @@ -223,4 +224,4 @@ v = _) r, | [ |- p2 @ p0 @ p1 @ eissect (to O A) (g x) = r ] => idtac "good" | [ |- ?G ] => fail 1 "bad" G end. - Fail rewrite concat_p_pp.
\ No newline at end of file + Fail rewrite concat_p_pp. diff --git a/test-suite/bugs/closed/4544.v b/test-suite/bugs/closed/4544.v index da140c931..64dd8c304 100644 --- a/test-suite/bugs/closed/4544.v +++ b/test-suite/bugs/closed/4544.v @@ -2,6 +2,7 @@ (* File reduced by coq-bug-finder from original input, then from 2553 lines to 1932 lines, then from 1946 lines to 1932 lines, then from 2467 lines to 1002 lines, then from 1016 lines to 1002 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) +Declare ML Module "ltac_plugin". Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. @@ -1004,4 +1005,4 @@ Proof. Fail Timeout 1 Time rewrite !loops_functor_group. (* 0.004 s in 8.5rc1, 8.677 s in 8.5 *) Timeout 1 do 3 rewrite loops_functor_group. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/closed/5277.v b/test-suite/bugs/closed/5277.v new file mode 100644 index 000000000..7abc38bfc --- /dev/null +++ b/test-suite/bugs/closed/5277.v @@ -0,0 +1,11 @@ +(* Scheme Equality not robust wrt names *) + +Module A1. + Inductive A (T : Type) := C (a : T). + Scheme Equality for A. (* success *) +End A1. + +Module A2. + Inductive A (x : Type) := C (a : x). + Scheme Equality for A. +End A2. diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index a2ee2d4c8..979396969 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -97,8 +97,8 @@ Expands to: Constant Top.f forall w : r, w 3 true = tt : Prop The command has indeed failed with message: -Error: Unknown interpretation for notation "$". +Unknown interpretation for notation "$". w 3 true = tt : Prop The command has indeed failed with message: -Error: Extra arguments: _, _. +Extra arguments: _, _. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index b084ad498..4df21ae35 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -1,5 +1,5 @@ The command has indeed failed with message: -Error: To rename arguments the "rename" flag must be specified. +To rename arguments the "rename" flag must be specified. Argument A renamed to B. File "stdin", line 2, characters 0-25: Warning: This command is just asserting the names of arguments of identity. @@ -103,15 +103,15 @@ Expands to: Constant Top.myplus @myplus : forall Z : Type, Z -> nat -> nat -> nat The command has indeed failed with message: -Error: Argument lists should agree on the names they provide. +Argument lists should agree on the names they provide. The command has indeed failed with message: -Error: Sequences of implicit arguments must be of different lengths. +Sequences of implicit arguments must be of different lengths. The command has indeed failed with message: -Error: Some argument names are duplicated: F +Some argument names are duplicated: F The command has indeed failed with message: -Error: Argument z cannot be declared implicit. +Argument z cannot be declared implicit. The command has indeed failed with message: -Error: Extra arguments: y. +Extra arguments: y. The command has indeed failed with message: -Error: To rename arguments the "rename" flag must be specified. +To rename arguments the "rename" flag must be specified. Argument A renamed to R. diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out index 06a6b2d15..38d055b28 100644 --- a/test-suite/output/Errors.out +++ b/test-suite/output/Errors.out @@ -7,4 +7,4 @@ In nested Ltac calls to "f" and "apply x", last call failed. Unable to unify "nat" with "True". The command has indeed failed with message: Ltac call to "instantiate ( (ident) := (lglob) )" failed. -Error: Instance is not well-typed in the environment of ?x. +Instance is not well-typed in the environment of ?x. diff --git a/test-suite/output/FunExt.out b/test-suite/output/FunExt.out new file mode 100644 index 000000000..8d2a125c1 --- /dev/null +++ b/test-suite/output/FunExt.out @@ -0,0 +1,19 @@ +The command has indeed failed with message: +Ltac call to "extensionality in (var)" failed. +Tactic failure: Not an extensional equality. +The command has indeed failed with message: +Ltac call to "extensionality in (var)" failed. +Tactic failure: Not an extensional equality. +The command has indeed failed with message: +Ltac call to "extensionality in (var)" failed. +Tactic failure: Not an extensional equality. +The command has indeed failed with message: +Ltac call to "extensionality in (var)" failed. +Tactic failure: Not an extensional equality. +The command has indeed failed with message: +Ltac call to "extensionality in (var)" failed. +Tactic failure: Already an intensional equality. +The command has indeed failed with message: +In nested Ltac calls to "extensionality in (var)" and +"clearbody (ne_var_list)", last call failed. +Hypothesis e depends on the body of H' diff --git a/test-suite/output/FunExt.v b/test-suite/output/FunExt.v new file mode 100644 index 000000000..7658ce718 --- /dev/null +++ b/test-suite/output/FunExt.v @@ -0,0 +1,168 @@ +Require Import FunctionalExtensionality. + +(* Basic example *) +Goal (forall x y z, x+y+z = z+y+x) -> (fun x y z => z+y+x) = (fun x y z => x+y+z). +intro H. +extensionality in H. +symmetry in H. +assumption. +Qed. + +(* Test rejection of non-equality *) +Goal forall H:(forall A:Prop, A), H=H -> forall H'':True, H''=H''. +intros H H' H''. +Fail extensionality in H. +clear H'. +Fail extensionality in H. +Fail extensionality in H''. +Abort. + +(* Test success on dependent equality *) +Goal forall (p : forall x, S x = x + 1), p = p -> S = fun x => x + 1. +intros p H. +extensionality in p. +assumption. +Qed. + +(* Test dependent functional extensionality *) +Goal forall (P:nat->Type) (Q:forall a, P a -> Type) (f g:forall a (b:P a), Q a b), + (forall x y, f x y = g x y) -> f = g. +intros * H. +extensionality in H. +assumption. +Qed. + +(* Other tests, courtesy of Jason Gross *) + +Goal forall A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c), (forall a b c, f a b c = g a b c) -> f = g. +Proof. + intros A B C D f g H. + extensionality in H. + match type of H with f = g => idtac end. + exact H. +Qed. + +Section test_section. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall a b c, f a b c = g a b c). + Goal f = g. + Proof. + extensionality in H. + match type of H with f = g => idtac end. + exact H. + Qed. +End test_section. + +Section test2. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall b a c, f a b c = g a b c). + Goal (fun b a c => f a b c) = (fun b a c => g a b c). + Proof. + extensionality in H. + match type of H with (fun b a => f a b) = (fun b' a' => g a' b') => idtac end. + exact H. + Qed. +End test2. + +Section test3. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall a c, (fun b => f a b c) = (fun b => g a b c)). + Goal (fun a c b => f a b c) = (fun a c b => g a b c). + Proof. + extensionality in H. + match type of H with (fun a c b => f a b c) = (fun a' c' b' => g a' b' c') => idtac end. + exact H. + Qed. +End test3. + +Section test4. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c -> Type) + (H : forall b, (forall a c d, f a b c d) = (forall a c d, g a b c d)). + Goal (fun b => forall a c d, f a b c d) = (fun b => forall a c d, g a b c d). + Proof. + extensionality in H. + exact H. + Qed. +End test4. + +Section test5. + Goal nat -> True. + Proof. + intro n. + Fail extensionality in n. + constructor. + Qed. +End test5. + +Section test6. + Goal let f := fun A (x : A) => x in let pf := fun A x => @eq_refl _ (f A x) in f = f. + Proof. + intros f pf. + extensionality in pf. + match type of pf with f = f => idtac end. + exact pf. + Qed. +End test6. + +Section test7. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall a b c, True -> f a b c = g a b c). + Goal True. + Proof. + extensionality in H. + match type of H with (fun a b c (_ : True) => f a b c) = (fun a' b' c' (_ : True) => g a' b' c') => idtac end. + constructor. + Qed. +End test7. + +Section test8. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : True -> forall a b c, f a b c = g a b c). + Goal True. + Proof. + extensionality in H. + match type of H with (fun (_ : True) => f) = (fun (_ : True) => g) => idtac end. + constructor. + Qed. +End test8. + +Section test9. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall b a c, f a b c = g a b c). + Goal (fun b a c => f a b c) = (fun b a c => g a b c). + Proof. + pose H as H'. + extensionality in H. + extensionality in H'. + let T := type of H in let T' := type of H' in constr_eq T T'. + match type of H with (fun b a => f a b) = (fun b' a' => g a' b') => idtac end. + exact H'. + Qed. +End test9. + +Section test10. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : f = g). + Goal True. + Proof. + Fail extensionality in H. + constructor. + Qed. +End test10. + +Section test11. + Context A B C (D : forall a : A, C a -> Type) (f g : forall a : A, B -> forall c : C a, D a c) + (H : forall a b c, f a b c = f a b c). + Goal True. + Proof. + pose H as H'. + pose (eq_refl : H = H') as e. + extensionality in H. + Fail extensionality in H'. + clear e. + extensionality in H'. + let T := type of H in let T' := type of H' in constr_eq T T'. + lazymatch type of H with f = f => idtac end. + constructor. + Qed. +End test11. diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 26eaca827..9d106d2da 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -41,29 +41,29 @@ fun x : nat => ifn x is succ n then n else 0 -4 : Z The command has indeed failed with message: -Error: x should not be bound in a recursive pattern of the right-hand side. +x should not be bound in a recursive pattern of the right-hand side. The command has indeed failed with message: -Error: in the right-hand side, y and z should appear in +in the right-hand side, y and z should appear in term position as part of a recursive pattern. The command has indeed failed with message: The reference w was not found in the current environment. The command has indeed failed with message: -Error: in the right-hand side, y and z should appear in +in the right-hand side, y and z should appear in term position as part of a recursive pattern. The command has indeed failed with message: -Error: z is expected to occur in binding position in the right-hand side. +z is expected to occur in binding position in the right-hand side. The command has indeed failed with message: -Error: as y is a non-closed binder, no such "," is allowed to occur. +as y is a non-closed binder, no such "," is allowed to occur. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Cannot find where the recursive pattern starts. +Cannot find where the recursive pattern starts. The command has indeed failed with message: -Error: Both ends of the recursive pattern are the same. +Both ends of the recursive pattern are the same. SUM (nat * nat) nat : Set FST (0; 1) diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index c17b285bc..81fda176e 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -1,108 +1,108 @@ le_n: forall n : nat, n <= n +le_0_n: forall n : nat, 0 <= n le_S: forall n m : nat, n <= m -> n <= S m +le_n_S: forall n m : nat, n <= m -> S n <= S m +le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m +le_S_n: forall n m : nat, S n <= S m -> n <= m +min_l: forall n m : nat, n <= m -> Nat.min n m = n +max_r: forall n m : nat, n <= m -> Nat.max n m = m +min_r: forall n m : nat, m <= n -> Nat.min n m = m +max_l: forall n m : nat, m <= n -> Nat.max n m = n le_ind: forall (n : nat) (P : nat -> Prop), P n -> (forall m : nat, n <= m -> P m -> P (S m)) -> forall n0 : nat, n <= n0 -> P n0 -le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m -le_S_n: forall n m : nat, S n <= S m -> n <= m -le_0_n: forall n : nat, 0 <= n -le_n_S: forall n m : nat, n <= m -> S n <= S m -max_l: forall n m : nat, m <= n -> Nat.max n m = n -max_r: forall n m : nat, n <= m -> Nat.max n m = m -min_l: forall n m : nat, n <= m -> Nat.min n m = n -min_r: forall n m : nat, m <= n -> Nat.min n m = m -true: bool false: bool -bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b -bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b -bool_rec: forall P : bool -> Set, P true -> P false -> forall b : bool, P b -andb: bool -> bool -> bool -orb: bool -> bool -> bool -implb: bool -> bool -> bool -xorb: bool -> bool -> bool +true: bool +is_true: bool -> Prop negb: bool -> bool -andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true -andb_true_intro: - forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true eq_true: bool -> Prop -eq_true_rect: - forall P : bool -> Type, P true -> forall b : bool, eq_true b -> P b -eq_true_ind: - forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b +implb: bool -> bool -> bool +orb: bool -> bool -> bool +andb: bool -> bool -> bool +xorb: bool -> bool -> bool +Nat.even: nat -> bool +Nat.odd: nat -> bool +BoolSpec: Prop -> Prop -> bool -> Prop +Nat.eqb: nat -> nat -> bool +Nat.testbit: nat -> nat -> bool +Nat.ltb: nat -> nat -> bool +Nat.leb: nat -> nat -> bool +Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat +bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b +bool_rec: forall P : bool -> Set, P true -> P false -> forall b : bool, P b eq_true_rec: forall P : bool -> Set, P true -> forall b : bool, eq_true b -> P b -is_true: bool -> Prop -eq_true_ind_r: - forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true -eq_true_rec_r: - forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true +eq_true_ind: + forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b eq_true_rect_r: forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true -BoolSpec: Prop -> Prop -> bool -> Prop +eq_true_rec_r: + forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true +eq_true_rect: + forall P : bool -> Type, P true -> forall b : bool, eq_true b -> P b +bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b +eq_true_ind_r: + forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true +andb_true_intro: + forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true BoolSpec_ind: forall (P Q : Prop) (P0 : bool -> Prop), (P -> P0 true) -> (Q -> P0 false) -> forall b : bool, BoolSpec P Q b -> P0 b -Nat.eqb: nat -> nat -> bool -Nat.leb: nat -> nat -> bool -Nat.ltb: nat -> nat -> bool -Nat.even: nat -> bool -Nat.odd: nat -> bool -Nat.testbit: nat -> nat -> bool -Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat bool_choice: forall (S : Set) (R1 R2 : S -> Prop), (forall x : S, {R1 x} + {R2 x}) -> {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x} -eq_S: forall x y : nat, x = y -> S x = S y -f_equal_nat: forall (B : Type) (f : nat -> B) (x y : nat), x = y -> f x = f y -f_equal_pred: forall x y : nat, x = y -> Nat.pred x = Nat.pred y +mult_n_O: forall n : nat, 0 = n * 0 +plus_O_n: forall n : nat, 0 + n = n +plus_n_O: forall n : nat, n = n + 0 +n_Sn: forall n : nat, n <> S n pred_Sn: forall n : nat, n = Nat.pred (S n) +O_S: forall n : nat, 0 <> S n +f_equal_pred: forall x y : nat, x = y -> Nat.pred x = Nat.pred y +eq_S: forall x y : nat, x = y -> S x = S y eq_add_S: forall n m : nat, S n = S m -> n = m +min_r: forall n m : nat, m <= n -> Nat.min n m = m +min_l: forall n m : nat, n <= m -> Nat.min n m = n +max_r: forall n m : nat, n <= m -> Nat.max n m = m +max_l: forall n m : nat, m <= n -> Nat.max n m = n +plus_Sn_m: forall n m : nat, S n + m = S (n + m) +plus_n_Sm: forall n m : nat, S (n + m) = n + S m +f_equal_nat: forall (B : Type) (f : nat -> B) (x y : nat), x = y -> f x = f y not_eq_S: forall n m : nat, n <> m -> S n <> S m -O_S: forall n : nat, 0 <> S n -n_Sn: forall n : nat, n <> S n +mult_n_Sm: forall n m : nat, n * m + n = n * S m f_equal2_plus: forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2 +f_equal2_mult: + forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2 f_equal2_nat: forall (B : Type) (f : nat -> nat -> B) (x1 y1 x2 y2 : nat), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2 -plus_n_O: forall n : nat, n = n + 0 -plus_O_n: forall n : nat, 0 + n = n -plus_n_Sm: forall n m : nat, S (n + m) = n + S m -plus_Sn_m: forall n m : nat, S n + m = S (n + m) -f_equal2_mult: - forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2 -mult_n_O: forall n : nat, 0 = n * 0 -mult_n_Sm: forall n m : nat, n * m + n = n * S m -max_l: forall n m : nat, m <= n -> Nat.max n m = n -max_r: forall n m : nat, n <= m -> Nat.max n m = m -min_l: forall n m : nat, n <= m -> Nat.min n m = n -min_r: forall n m : nat, m <= n -> Nat.min n m = m -andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true andb_true_intro: forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true bool_choice: forall (S : Set) (R1 R2 : S -> Prop), (forall x : S, {R1 x} + {R2 x}) -> {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x} -andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true andb_true_intro: forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true -h': newdef n <> n +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true h: n <> newdef n h': newdef n <> n h: n <> newdef n +h': newdef n <> n h: n <> newdef n h: n <> newdef n -h': ~ P n h: P n h': ~ P n h: P n h': ~ P n h: P n +h': ~ P n h: P n h: P n diff --git a/test-suite/output/SearchHead.out b/test-suite/output/SearchHead.out index 0d5924ec6..7038eac22 100644 --- a/test-suite/output/SearchHead.out +++ b/test-suite/output/SearchHead.out @@ -1,39 +1,39 @@ le_n: forall n : nat, n <= n +le_0_n: forall n : nat, 0 <= n le_S: forall n m : nat, n <= m -> n <= S m le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m -le_S_n: forall n m : nat, S n <= S m -> n <= m -le_0_n: forall n : nat, 0 <= n le_n_S: forall n m : nat, n <= m -> S n <= S m -true: bool +le_S_n: forall n m : nat, S n <= S m -> n <= m false: bool -andb: bool -> bool -> bool -orb: bool -> bool -> bool +true: bool +negb: bool -> bool implb: bool -> bool -> bool +orb: bool -> bool -> bool +andb: bool -> bool -> bool xorb: bool -> bool -> bool -negb: bool -> bool -Nat.eqb: nat -> nat -> bool -Nat.leb: nat -> nat -> bool -Nat.ltb: nat -> nat -> bool Nat.even: nat -> bool Nat.odd: nat -> bool +Nat.leb: nat -> nat -> bool +Nat.ltb: nat -> nat -> bool Nat.testbit: nat -> nat -> bool -eq_S: forall x y : nat, x = y -> S x = S y -f_equal_pred: forall x y : nat, x = y -> Nat.pred x = Nat.pred y +Nat.eqb: nat -> nat -> bool +mult_n_O: forall n : nat, 0 = n * 0 +plus_O_n: forall n : nat, 0 + n = n +plus_n_O: forall n : nat, n = n + 0 pred_Sn: forall n : nat, n = Nat.pred (S n) +f_equal_pred: forall x y : nat, x = y -> Nat.pred x = Nat.pred y eq_add_S: forall n m : nat, S n = S m -> n = m -f_equal2_plus: - forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2 -plus_n_O: forall n : nat, n = n + 0 -plus_O_n: forall n : nat, 0 + n = n +eq_S: forall x y : nat, x = y -> S x = S y +max_r: forall n m : nat, n <= m -> Nat.max n m = m +max_l: forall n m : nat, m <= n -> Nat.max n m = n +min_r: forall n m : nat, m <= n -> Nat.min n m = m +min_l: forall n m : nat, n <= m -> Nat.min n m = n plus_n_Sm: forall n m : nat, S (n + m) = n + S m plus_Sn_m: forall n m : nat, S n + m = S (n + m) +mult_n_Sm: forall n m : nat, n * m + n = n * S m +f_equal2_plus: + forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2 f_equal2_mult: forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2 -mult_n_O: forall n : nat, 0 = n * 0 -mult_n_Sm: forall n m : nat, n * m + n = n * S m -max_l: forall n m : nat, m <= n -> Nat.max n m = n -max_r: forall n m : nat, n <= m -> Nat.max n m = m -min_l: forall n m : nat, n <= m -> Nat.min n m = n -min_r: forall n m : nat, m <= n -> Nat.min n m = m h: newdef n h: P n diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out index f3c12effc..45ff5e73b 100644 --- a/test-suite/output/SearchPattern.out +++ b/test-suite/output/SearchPattern.out @@ -1,77 +1,77 @@ -true: bool false: bool -andb: bool -> bool -> bool -orb: bool -> bool -> bool +true: bool +negb: bool -> bool implb: bool -> bool -> bool +orb: bool -> bool -> bool +andb: bool -> bool -> bool xorb: bool -> bool -> bool -negb: bool -> bool -Nat.eqb: nat -> nat -> bool -Nat.leb: nat -> nat -> bool -Nat.ltb: nat -> nat -> bool Nat.even: nat -> bool Nat.odd: nat -> bool +Nat.leb: nat -> nat -> bool +Nat.ltb: nat -> nat -> bool Nat.testbit: nat -> nat -> bool -O: nat -S: nat -> nat -length: forall A : Type, list A -> nat +Nat.eqb: nat -> nat -> bool +Nat.two: nat Nat.zero: nat Nat.one: nat -Nat.two: nat -Nat.succ: nat -> nat +O: nat +Nat.double: nat -> nat +Nat.sqrt: nat -> nat +Nat.div2: nat -> nat +Nat.log2: nat -> nat Nat.pred: nat -> nat +Nat.square: nat -> nat +S: nat -> nat +Nat.succ: nat -> nat +Nat.ldiff: nat -> nat -> nat Nat.add: nat -> nat -> nat -Nat.double: nat -> nat +Nat.lor: nat -> nat -> nat +Nat.lxor: nat -> nat -> nat +Nat.land: nat -> nat -> nat Nat.mul: nat -> nat -> nat Nat.sub: nat -> nat -> nat Nat.max: nat -> nat -> nat -Nat.min: nat -> nat -> nat -Nat.pow: nat -> nat -> nat Nat.div: nat -> nat -> nat +Nat.pow: nat -> nat -> nat +Nat.min: nat -> nat -> nat Nat.modulo: nat -> nat -> nat Nat.gcd: nat -> nat -> nat -Nat.square: nat -> nat Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat -Nat.sqrt: nat -> nat Nat.log2_iter: nat -> nat -> nat -> nat -> nat -Nat.log2: nat -> nat -Nat.div2: nat -> nat +length: forall A : Type, list A -> nat Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat -Nat.land: nat -> nat -> nat -Nat.lor: nat -> nat -> nat +Nat.div2: nat -> nat +Nat.sqrt: nat -> nat +Nat.log2: nat -> nat +Nat.double: nat -> nat +Nat.pred: nat -> nat +Nat.square: nat -> nat +Nat.succ: nat -> nat +S: nat -> nat Nat.ldiff: nat -> nat -> nat +Nat.pow: nat -> nat -> nat +Nat.land: nat -> nat -> nat Nat.lxor: nat -> nat -> nat -S: nat -> nat -Nat.succ: nat -> nat -Nat.pred: nat -> nat -Nat.add: nat -> nat -> nat -Nat.double: nat -> nat +Nat.div: nat -> nat -> nat Nat.mul: nat -> nat -> nat -Nat.sub: nat -> nat -> nat -Nat.max: nat -> nat -> nat Nat.min: nat -> nat -> nat -Nat.pow: nat -> nat -> nat -Nat.div: nat -> nat -> nat Nat.modulo: nat -> nat -> nat +Nat.sub: nat -> nat -> nat +Nat.lor: nat -> nat -> nat Nat.gcd: nat -> nat -> nat -Nat.square: nat -> nat -Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat -Nat.sqrt: nat -> nat +Nat.max: nat -> nat -> nat +Nat.add: nat -> nat -> nat Nat.log2_iter: nat -> nat -> nat -> nat -> nat -Nat.log2: nat -> nat -Nat.div2: nat -> nat +Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat -Nat.land: nat -> nat -> nat -Nat.lor: nat -> nat -> nat -Nat.ldiff: nat -> nat -> nat -Nat.lxor: nat -> nat -> nat mult_n_Sm: forall n m : nat, n * m + n = n * S m -identity_refl: forall (A : Type) (a : A), identity a a iff_refl: forall A : Prop, A <-> A +le_n: forall n : nat, n <= n +identity_refl: forall (A : Type) (a : A), identity a a eq_refl: forall (A : Type) (x : A), x = x Nat.divmod: nat -> nat -> nat -> nat -> nat * nat -le_n: forall n : nat, n <= n -pair: forall A B : Type, A -> B -> A * B conj: forall A B : Prop, A -> B -> A /\ B +pair: forall A B : Type, A -> B -> A * B Nat.divmod: nat -> nat -> nat -> nat -> nat * nat h: n <> newdef n h: n <> newdef n diff --git a/test-suite/output/ShowProof.out b/test-suite/output/ShowProof.out new file mode 100644 index 000000000..2d4be8bce --- /dev/null +++ b/test-suite/output/ShowProof.out @@ -0,0 +1 @@ +(fun x : Type => conj I ?Goal) diff --git a/test-suite/output/ShowProof.v b/test-suite/output/ShowProof.v new file mode 100644 index 000000000..73ecaf220 --- /dev/null +++ b/test-suite/output/ShowProof.v @@ -0,0 +1,6 @@ +(* Was #4524 *) +Definition foo (x : Type) : True /\ True. +Proof. +split. +- exact I. + Show Proof. (* Was not finding an evar name at some time *) diff --git a/test-suite/output/auto.out b/test-suite/output/auto.out new file mode 100644 index 000000000..a5b55a999 --- /dev/null +++ b/test-suite/output/auto.out @@ -0,0 +1,20 @@ +(* info auto: *) +simple apply or_intror (in core). + intro. + assumption. +Debug: (* debug auto: *) +Debug: * assumption. (*fail*) +Debug: * intro. (*fail*) +Debug: * simple apply or_intror (in core). (*success*) +Debug: ** assumption. (*fail*) +Debug: ** intro. (*success*) +Debug: ** assumption. (*success*) +(* info eauto: *) +simple apply or_intror. + intro. + exact H. +Debug: (* debug eauto: *) +Debug: 1 depth=5 +Debug: 1.1 depth=4 simple apply or_intror +Debug: 1.1.1 depth=4 intro +Debug: 1.1.1.1 depth=4 exact H diff --git a/test-suite/output/auto.v b/test-suite/output/auto.v new file mode 100644 index 000000000..a77b7b82e --- /dev/null +++ b/test-suite/output/auto.v @@ -0,0 +1,11 @@ +(* testing info/debug auto/eauto *) + +Goal False \/ (True -> True). +info_auto. +Undo. +debug auto. +Undo. +info_eauto. +Undo. +debug eauto. +Qed. diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index 1ff09e3af..35c3057d8 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -1,5 +1,4 @@ The command has indeed failed with message: -Error: Ltac variable y depends on pattern variable name z which is not bound in current context. Ltac f x y z := symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize @@ -22,11 +21,11 @@ The term "I" has type "True" while it is expected to have type "False". The command has indeed failed with message: In nested Ltac calls to "h" and "injection (destruction_arg)", last call failed. -Error: No primitive equality found. +No primitive equality found. The command has indeed failed with message: In nested Ltac calls to "h" and "injection (destruction_arg)", last call failed. -Error: No primitive equality found. +No primitive equality found. Hx nat nat diff --git a/test-suite/output/ltac_missing_args.out b/test-suite/output/ltac_missing_args.out new file mode 100644 index 000000000..172612405 --- /dev/null +++ b/test-suite/output/ltac_missing_args.out @@ -0,0 +1,20 @@ +The command has indeed failed with message: +A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +A fully applied tactic is expected: missing arguments for variables y and _. +The command has indeed failed with message: +A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +A fully applied tactic is expected: missing argument for variable _. +The command has indeed failed with message: +A fully applied tactic is expected: missing argument for variable _. +The command has indeed failed with message: +A fully applied tactic is expected: missing argument for variable _. +The command has indeed failed with message: +A fully applied tactic is expected: missing argument for variable x. +The command has indeed failed with message: +A fully applied tactic is expected: missing argument for variable x. diff --git a/test-suite/output/ltac_missing_args.v b/test-suite/output/ltac_missing_args.v new file mode 100644 index 000000000..8ecd97aa5 --- /dev/null +++ b/test-suite/output/ltac_missing_args.v @@ -0,0 +1,19 @@ +Ltac foo x := idtac x. +Ltac bar x := fun y _ => idtac x y. +Ltac baz := foo. +Ltac qux := bar. +Ltac mydo tac := tac (). +Ltac rec x := rec. + +Goal True. + Fail foo. + Fail bar. + Fail bar True. + Fail baz. + Fail qux. + Fail mydo ltac:(fun _ _ => idtac). + Fail let tac := (fun _ => idtac) in tac. + Fail (fun _ => idtac). + Fail rec True. + Fail let rec tac x := tac in tac True. +Abort.
\ No newline at end of file diff --git a/test-suite/success/Discriminate.v b/test-suite/success/Discriminate.v index a75967411..6abfca4c3 100644 --- a/test-suite/success/Discriminate.v +++ b/test-suite/success/Discriminate.v @@ -38,3 +38,10 @@ Abort. Goal ~ identity 0 1. discriminate. Qed. + +(* Check discriminate on types with local definitions *) + +Inductive A := B (T := unit) (x y : bool) (z := x). +Goal forall x y, B x true = B y false -> False. +discriminate. +Qed. diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v index da2183841..78652fb64 100644 --- a/test-suite/success/Injection.v +++ b/test-suite/success/Injection.v @@ -150,6 +150,13 @@ match goal with end. Abort. +(* Injection in the presence of local definitions *) +Inductive A := B (T := unit) (x y : bool) (z := x). +Goal forall x y x' y', B x y = B x' y' -> y = y'. +intros * [= H1 H2]. +exact H2. +Qed. + (* Injection does not project at positions in Prop... allow it? Inductive t (A:Prop) : Set := c : A -> t A. diff --git a/test-suite/success/decl_mode.v b/test-suite/success/decl_mode.v index 58f79d45e..e569bcb49 100644 --- a/test-suite/success/decl_mode.v +++ b/test-suite/success/decl_mode.v @@ -153,7 +153,7 @@ proof. thus ~= (IZR (Zneg z) * IZR (Zneg z)). end cases. end proof. -Qed. +Admitted. Definition irrational (x:R):Prop := forall (p:Z) (q:nat),q<>0%nat -> x<> (IZR p/INR q). diff --git a/test-suite/success/hintdb_in_ltac.v b/test-suite/success/hintdb_in_ltac.v new file mode 100644 index 000000000..f12b4d1f4 --- /dev/null +++ b/test-suite/success/hintdb_in_ltac.v @@ -0,0 +1,14 @@ +Definition x := 0. + +Hint Unfold x : mybase. + +Ltac autounfoldify base := autounfold with base. + +Tactic Notation "autounfoldify_bis" ident(base) := autounfold with base. + +Goal x = 0. + progress autounfoldify mybase. + Undo. + progress autounfoldify_bis mybase. + trivial. +Qed. diff --git a/test-suite/success/hintdb_in_ltac_bis.v b/test-suite/success/hintdb_in_ltac_bis.v new file mode 100644 index 000000000..f5c25540e --- /dev/null +++ b/test-suite/success/hintdb_in_ltac_bis.v @@ -0,0 +1,15 @@ +Parameter Foo : Prop. +Axiom H : Foo. + +Hint Resolve H : mybase. + +Ltac foo base := eauto with base. + +Tactic Notation "bar" ident(base) := + typeclasses eauto with base. + +Goal Foo. + progress foo mybase. + Undo. + progress bar mybase. +Qed.
\ No newline at end of file diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 58d3a2b38..5a3d5631d 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -24,7 +24,7 @@ Section Between. Lemma bet_eq : forall k l, l = k -> between k l. Proof. - induction 1; auto with arith. + intros * ->; auto with arith. Qed. Hint Resolve bet_eq: arith. @@ -37,9 +37,7 @@ Section Between. Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l. Proof. - intros k l H; induction H as [|l H]. - intros; absurd (S k <= k); auto with arith. - destruct H; auto with arith. + induction 1 as [|* [|]]; auto with arith. Qed. Hint Resolve between_Sk_l: arith. @@ -74,32 +72,32 @@ Section Between. Lemma in_int_intro : forall p q r, p <= r -> r < q -> in_int p q r. Proof. - red; auto with arith. + split; assumption. Qed. Hint Resolve in_int_intro: arith. Lemma in_int_lt : forall p q r, in_int p q r -> p < q. Proof. - induction 1; intros. - apply le_lt_trans with r; auto with arith. + intros * []. + eapply le_lt_trans; eassumption. Qed. Lemma in_int_p_Sq : - forall p q r, in_int p (S q) r -> in_int p q r \/ r = q :>nat. + forall p q r, in_int p (S q) r -> in_int p q r \/ r = q. Proof. - induction 1; intros. - elim (le_lt_or_eq r q); auto with arith. + intros p q r []. + destruct (le_lt_or_eq r q); auto with arith. Qed. Lemma in_int_S : forall p q r, in_int p q r -> in_int p (S q) r. Proof. - induction 1; auto with arith. + intros * []; auto with arith. Qed. Hint Resolve in_int_S: arith. Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r. Proof. - induction 1; auto with arith. + intros * []; auto with arith. Qed. Hint Immediate in_int_Sp_q: arith. @@ -107,10 +105,9 @@ Section Between. forall k l, between k l -> forall r, in_int k l r -> P r. Proof. induction 1; intros. - absurd (k < k); auto with arith. - apply in_int_lt with r; auto with arith. - elim (in_int_p_Sq k l r); intros; auto with arith. - rewrite H2; trivial with arith. + - absurd (k < k). { auto with arith. } + eapply in_int_lt; eassumption. + - destruct (in_int_p_Sq k l r) as [| ->]; auto with arith. Qed. Lemma in_int_between : @@ -120,17 +117,17 @@ Section Between. Qed. Lemma exists_in_int : - forall k l, exists_between k l -> exists2 m : nat, in_int k l m & Q m. + forall k l, exists_between k l -> exists2 m : nat, in_int k l m & Q m. Proof. - induction 1. - case IHexists_between; intros p inp Qp; exists p; auto with arith. - exists l; auto with arith. + induction 1 as [* ? (p, ?, ?)|]. + - exists p; auto with arith. + - exists l; auto with arith. Qed. Lemma in_int_exists : forall k l r, in_int k l r -> Q r -> exists_between k l. Proof. - destruct 1; intros. - elim H0; auto with arith. + intros * (?, lt_r_l) ?. + induction lt_r_l; auto with arith. Qed. Lemma between_or_exists : @@ -139,9 +136,11 @@ Section Between. (forall n:nat, in_int k l n -> P n \/ Q n) -> between k l \/ exists_between k l. Proof. - induction 1; intros; auto with arith. - elim IHle; intro; auto with arith. - elim (H0 m); auto with arith. + induction 1 as [|m ? IHle]. + - auto with arith. + - intros P_or_Q. + destruct IHle; auto with arith. + destruct (P_or_Q m); auto with arith. Qed. Lemma between_not_exists : @@ -150,14 +149,14 @@ Section Between. (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l. Proof. induction 1; red; intros. - absurd (k < k); auto with arith. - absurd (Q l); auto with arith. - elim (exists_in_int k (S l)); auto with arith; intros l' inl' Ql'. - replace l with l'; auto with arith. - elim inl'; intros. - elim (le_lt_or_eq l' l); auto with arith; intros. - absurd (exists_between k l); auto with arith. - apply in_int_exists with l'; auto with arith. + - absurd (k < k); auto with arith. + - absurd (Q l). { auto with arith. } + destruct (exists_in_int k (S l)) as (l',[],?). + + auto with arith. + + replace l with l'. { trivial. } + destruct (le_lt_or_eq l' l); auto with arith. + absurd (exists_between k l). { auto with arith. } + eapply in_int_exists; eauto with arith. Qed. Inductive P_nth (init:nat) : nat -> nat -> Prop := @@ -168,15 +167,16 @@ Section Between. Lemma nth_le : forall (init:nat) l (n:nat), P_nth init l n -> init <= l. Proof. - induction 1; intros; auto with arith. - apply le_trans with (S k); auto with arith. + induction 1. + - auto with arith. + - eapply le_trans; eauto with arith. Qed. Definition eventually (n:nat) := exists2 k : nat, k <= n & Q k. Lemma event_O : eventually 0 -> Q 0. Proof. - induction 1; intros. + intros (x, ?, ?). replace 0 with x; auto with arith. Qed. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index ddaf08bf7..11d80dbc3 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -262,6 +262,11 @@ Inductive comparison : Set := | Lt : comparison | Gt : comparison. +Lemma comparison_eq_stable : forall c c' : comparison, ~~ c = c' -> c = c'. +Proof. + destruct c, c'; intro H; reflexivity || destruct H; discriminate. +Qed. + Definition CompOpp (r:comparison) := match r with | Eq => Eq @@ -326,7 +331,6 @@ Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c, CompSpec eq lt x y c -> CompSpecT eq lt x y c. Proof. intros. apply CompareSpec2Type; assumption. Defined. - (******************************************************************) (** * Misc Other Datatypes *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 85123cc44..9b58c524e 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -125,6 +125,25 @@ Proof. [apply Hl | apply Hr]; assumption. Qed. +Theorem imp_iff_compat_l : forall A B C : Prop, + (B <-> C) -> ((A -> B) <-> (A -> C)). +Proof. + intros ? ? ? [Hl Hr]; split; intros H ?; [apply Hl | apply Hr]; apply H; assumption. +Qed. + +Theorem imp_iff_compat_r : forall A B C : Prop, + (B <-> C) -> ((B -> A) <-> (C -> A)). +Proof. + intros ? ? ? [Hl Hr]; split; intros H ?; [apply H, Hr | apply H, Hl]; assumption. +Qed. + +Theorem not_iff_compat : forall A B : Prop, + (A <-> B) -> (~ A <-> ~B). +Proof. + intros; apply imp_iff_compat_r; assumption. +Qed. + + (** Some equivalences *) Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False). @@ -553,7 +572,8 @@ Proof. intros A P (x & Hp & Huniq); split. - intro; exists x; auto. - intros (x0 & HPx0 & HQx0) x1 HPx1. - replace x1 with x0 by (transitivity x; [symmetry|]; auto). + assert (H : x0 = x1) by (transitivity x; [symmetry|]; auto). + destruct H. assumption. Qed. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 48fbe0793..edcd53005 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -88,9 +88,12 @@ Open Scope type_scope. (** ML Tactic Notations *) +Declare ML Module "ltac_plugin". Declare ML Module "coretactics". Declare ML Module "extratactics". Declare ML Module "g_auto". Declare ML Module "g_class". Declare ML Module "g_eqdecide". Declare ML Module "g_rewrite". + +Global Set Default Proof Mode "Classic". diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 9fc00e80c..2cc2ecbc2 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -103,7 +103,7 @@ Definition sig_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sig P of an [a] of type [A], a of a proof [h] that [a] satisfies [P], and a proof [h'] that [a] satisfies [Q]. Then [(proj1_sig (sig_of_sig2 y))] is the witness [a], - [(proj2_sig (sig_of_sig2 y))] is the proof of [(P a)], and + [(proj2_sig (sig_of_sig2 y))] is the proof of [(P a)], and [(proj3_sig y)] is the proof of [(Q a)]. *) Section Subset_projections2. @@ -190,6 +190,23 @@ Definition sig2_of_sigT2 (A : Type) (P Q : A -> Prop) (X : sigT2 P Q) : sig2 P Q Definition sigT2_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sigT2 P Q := existT2 P Q (proj1_sig (sig_of_sig2 X)) (proj2_sig (sig_of_sig2 X)) (proj3_sig X). +(** η Principles *) +Definition sigT_eta {A P} (p : { a : A & P a }) + : p = existT _ (projT1 p) (projT2 p). +Proof. destruct p; reflexivity. Defined. + +Definition sig_eta {A P} (p : { a : A | P a }) + : p = exist _ (proj1_sig p) (proj2_sig p). +Proof. destruct p; reflexivity. Defined. + +Definition sigT2_eta {A P Q} (p : { a : A & P a & Q a }) + : p = existT2 _ _ (projT1 (sigT_of_sigT2 p)) (projT2 (sigT_of_sigT2 p)) (projT3 p). +Proof. destruct p; reflexivity. Defined. + +Definition sig2_eta {A P Q} (p : { a : A | P a & Q a }) + : p = exist2 _ _ (proj1_sig (sig_of_sig2 p)) (proj2_sig (sig_of_sig2 p)) (proj3_sig p). +Proof. destruct p; reflexivity. Defined. + (** [sumbool] is a boolean type equipped with the justification of their value *) @@ -263,10 +280,10 @@ Section Dependent_choice_lemmas. (forall x:X, {y | R x y}) -> forall x0, {f : nat -> X | f O = x0 /\ forall n, R (f n) (f (S n))}. Proof. - intros H x0. + intros H x0. set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end). exists f. - split. reflexivity. + split. reflexivity. induction n; simpl; apply proj2_sig. Defined. diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 1420a000b..07e8b6ef8 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -22,7 +22,16 @@ description principles - AC! = functional relation reification (known as axiom of unique choice in topos theory, sometimes called principle of definite description in - the context of constructive type theory) + the context of constructive type theory, sometimes + called axiom of no choice) + +- AC_fun_repr = functional choice of a representative in an equivalence class +- AC_fun_setoid_gen = functional form of the general form of the (so-called + extensional) axiom of choice over setoids +- AC_fun_setoid = functional form of the (so-called extensional) axiom of + choice from setoids +- AC_fun_setoid_simple = functional form of the (so-called extensional) axiom of + choice from setoids on locally compatible relations - GAC_rel = guarded relational form of the (non extensional) axiom of choice - GAC_fun = guarded functional form of the (non extensional) axiom of choice @@ -45,6 +54,11 @@ description principles independence of premises) - Drinker = drinker's paradox (small form) (called Ex in Bell [[Bell]]) +- EM = excluded-middle + +- Ext_pred_repr = choice of a representative among extensional predicates +- Ext_pred = extensionality of predicates +- Ext_fun_prop_repr = choice of a representative among extensional functions to Prop We let also @@ -76,6 +90,10 @@ Table of contents 8. Choice -> Dependent choice -> Countable choice +9.1. AC_fun_ext = AC_fun + Ext_fun_repr + EM + +9.2. AC_fun_ext = AC_fun + Ext_prop_fun_repr + PI + References: [[Bell]] John L. Bell, Choice principles in intuitionistic set theory, @@ -84,8 +102,13 @@ unpublished. [[Bell93]] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic Type Theories, Mathematical Logic Quarterly, volume 39, 1993. +[[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent to +AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004. + [[Carlström05]] Jesper Carlström, Interpreting descriptions in intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005. + +[[Werner97]] Benjamin Werner, Sets in Types, Types in Sets, TACS, 1997. *) Set Implicit Arguments. @@ -108,8 +131,6 @@ Variables A B :Type. Variable P:A->Prop. -Variable R:A->B->Prop. - (** ** Constructive choice and description *) (** AC_rel *) @@ -121,6 +142,10 @@ Definition RelationalChoice_on := (** AC_fun *) +(* Note: This is called Type-Theoretic Description Axiom (TTDA) in + [[Werner97]] (using a non-standard meaning of "description"). This + is called intensional axiom of choice (AC_int) in [[Carlström04]] *) + Definition FunctionalChoice_on := forall R:A->B->Prop, (forall x : A, exists y : B, R x y) -> @@ -148,6 +173,55 @@ Definition FunctionalRelReification_on := (forall x : A, exists! y : B, R x y) -> (exists f : A->B, forall x : A, R x (f x)). +(** AC_fun_repr *) + +(* Note: This is called Type-Theoretic Choice Axiom (TTCA) in + [[Werner97]] (by reference to the extensional set-theoretic + formulation of choice); Note also a typo in its intended + formulation in [[Werner97]]. *) + +Require Import RelationClasses Logic. + +Definition RepresentativeFunctionalChoice_on := + forall R:A->A->Prop, + (Equivalence R) -> + (exists f : A->A, forall x : A, (R x (f x)) /\ forall x', R x x' -> f x = f x'). + +(** AC_fun_setoid *) + +Definition SetoidFunctionalChoice_on := + forall R : A -> A -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + (forall x x' y, R x x' -> T x y -> T x' y) -> + (forall x, exists y, T x y) -> + exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). + +(** AC_fun_setoid_gen *) + +(* Note: This is called extensional axiom of choice (AC_ext) in + [[Carlström04]]. *) + +Definition GeneralizedSetoidFunctionalChoice_on := + forall R : A -> A -> Prop, + forall S : B -> B -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + Equivalence S -> + (forall x x' y y', R x x' -> S y y' -> T x y -> T x' y') -> + (forall x, exists y, T x y) -> + exists f : A -> B, + forall x : A, T x (f x) /\ (forall x' : A, R x x' -> S (f x) (f x')). + +(** AC_fun_setoid_simple *) + +Definition SimpleSetoidFunctionalChoice_on A B := + forall R : A -> A -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + (forall x, exists y, forall x', R x x' -> T x' y) -> + exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). + (** ID_epsilon (constructive version of indefinite description; combined with proof-irrelevance, it may be connected to Carlström's type theory with a constructive indefinite description @@ -234,6 +308,14 @@ Notation FunctionalChoiceOnInhabitedSet := (forall A B : Type, inhabited B -> FunctionalChoice_on A B). Notation FunctionalRelReification := (forall A B : Type, FunctionalRelReification_on A B). +Notation RepresentativeFunctionalChoice := + (forall A : Type, RepresentativeFunctionalChoice_on A). +Notation SetoidFunctionalChoice := + (forall A B: Type, SetoidFunctionalChoice_on A B). +Notation GeneralizedSetoidFunctionalChoice := + (forall A B : Type, GeneralizedSetoidFunctionalChoice_on A B). +Notation SimpleSetoidFunctionalChoice := + (forall A B : Type, SimpleSetoidFunctionalChoice_on A B). Notation GuardedRelationalChoice := (forall A B : Type, GuardedRelationalChoice_on A B). @@ -271,6 +353,26 @@ Definition SmallDrinker'sParadox := forall (A:Type) (P:A -> Prop), inhabited A -> exists x, (exists x, P x) -> P x. +Definition ExcludedMiddle := + forall P:Prop, P \/ ~ P. + +(** Extensional schemes *) + +Local Notation ExtensionalPropositionRepresentative := + (forall (A:Type), + exists h : Prop -> Prop, + forall P : Prop, (P <-> h P) /\ forall Q, (P <-> Q) -> h P = h Q). + +Local Notation ExtensionalPredicateRepresentative := + (forall (A:Type), + exists h : (A->Prop) -> (A->Prop), + forall (P : A -> Prop), (forall x, P x <-> h P x) /\ forall Q, (forall x, P x <-> Q x) -> h P = h Q). + +Local Notation ExtensionalFunctionRepresentative := + (forall (A B:Type), + exists h : (A->B) -> (A->B), + forall (f : A -> B), (forall x, f x = h f x) /\ forall g, (forall x, f x = g x) -> h f = h g). + (**********************************************************************) (** * AC_rel + AC! = AC_fun @@ -284,7 +386,7 @@ Definition SmallDrinker'sParadox := relational formulation) without known inconsistency with classical logic, though functional relation reification conflicts with classical logic *) -Lemma description_rel_choice_imp_funct_choice : +Lemma functional_rel_reification_and_rel_choice_imp_fun_choice : forall A B : Type, FunctionalRelReification_on A B -> RelationalChoice_on A B -> FunctionalChoice_on A B. Proof. @@ -298,7 +400,10 @@ Proof. apply HR'R; assumption. Qed. -Lemma funct_choice_imp_rel_choice : +Notation description_rel_choice_imp_funct_choice := + functional_rel_reification_and_rel_choice_imp_fun_choice (compat "8.6"). + +Lemma fun_choice_imp_rel_choice : forall A B : Type, FunctionalChoice_on A B -> RelationalChoice_on A B. Proof. intros A B FunCh R H. @@ -311,7 +416,9 @@ Proof. trivial. Qed. -Lemma funct_choice_imp_description : +Notation funct_choice_imp_rel_choice := fun_choice_imp_rel_choice (compat "8.6"). + +Lemma fun_choice_imp_functional_rel_reification : forall A B : Type, FunctionalChoice_on A B -> FunctionalRelReification_on A B. Proof. intros A B FunCh R H. @@ -324,17 +431,21 @@ Proof. exists f; exact H0. Qed. -Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr : +Notation funct_choice_imp_description := fun_choice_imp_functional_rel_reification (compat "8.6"). + +Corollary fun_choice_iff_rel_choice_and_functional_rel_reification : forall A B : Type, FunctionalChoice_on A B <-> RelationalChoice_on A B /\ FunctionalRelReification_on A B. Proof. intros A B. split. intro H; split; - [ exact (funct_choice_imp_rel_choice H) - | exact (funct_choice_imp_description H) ]. - intros [H H0]; exact (description_rel_choice_imp_funct_choice H0 H). + [ exact (fun_choice_imp_rel_choice H) + | exact (fun_choice_imp_functional_rel_reification H) ]. + intros [H H0]; exact (functional_rel_reification_and_rel_choice_imp_fun_choice H0 H). Qed. +Notation FunChoice_Equiv_RelChoice_and_ParamDefinDescr := + fun_choice_iff_rel_choice_and_functional_rel_reification (compat "8.6"). (**********************************************************************) (** * Connection between the guarded, non guarded and omniscient choices *) @@ -862,3 +973,334 @@ Proof. rewrite Heq in HR. assumption. Qed. + +(**********************************************************************) +(** * About the axiom of choice over setoids *) + +Require Import ClassicalFacts PropExtensionalityFacts. + +(**********************************************************************) +(** ** Consequences of the choice of a representative in an equivalence class *) + +Theorem repr_fun_choice_imp_ext_prop_repr : + RepresentativeFunctionalChoice -> ExtensionalPropositionRepresentative. +Proof. + intros ReprFunChoice A. + pose (R P Q := P <-> Q). + assert (Hequiv:Equivalence R) by (split; firstorder). + apply (ReprFunChoice _ R Hequiv). +Qed. + +Theorem repr_fun_choice_imp_ext_pred_repr : + RepresentativeFunctionalChoice -> ExtensionalPredicateRepresentative. +Proof. + intros ReprFunChoice A. + pose (R P Q := forall x : A, P x <-> Q x). + assert (Hequiv:Equivalence R) by (split; firstorder). + apply (ReprFunChoice _ R Hequiv). +Qed. + +Theorem repr_fun_choice_imp_ext_function_repr : + RepresentativeFunctionalChoice -> ExtensionalFunctionRepresentative. +Proof. + intros ReprFunChoice A B. + pose (R (f g : A -> B) := forall x : A, f x = g x). + assert (Hequiv:Equivalence R). + { split; try easy. firstorder using eq_trans. } + apply (ReprFunChoice _ R Hequiv). +Qed. + +(** *** This is a variant of Diaconescu and Goodman-Myhill theorems *) + +Theorem repr_fun_choice_imp_excluded_middle : + RepresentativeFunctionalChoice -> ExcludedMiddle. +Proof. + intros ReprFunChoice. + apply representative_boolean_partition_imp_excluded_middle, ReprFunChoice. +Qed. + +Theorem repr_fun_choice_imp_relational_choice : + RepresentativeFunctionalChoice -> RelationalChoice. +Proof. + intros ReprFunChoice A B T Hexists. + pose (D := (A*B)%type). + pose (R (z z':D) := + let x := fst z in + let x' := fst z' in + let y := snd z in + let y' := snd z' in + x = x' /\ (T x y -> y = y' \/ T x y') /\ (T x y' -> y = y' \/ T x y)). + assert (Hequiv : Equivalence R). + { split. + - split. easy. firstorder. + - intros (x,y) (x',y') (H1,(H2,H2')). split. easy. simpl fst in *. simpl snd in *. + subst x'. split; intro H. + + destruct (H2' H); firstorder. + + destruct (H2 H); firstorder. + - intros (x,y) (x',y') (x'',y'') (H1,(H2,H2')) (H3,(H4,H4')). + simpl fst in *. simpl snd in *. subst x'' x'. split. easy. split; intro H. + + simpl fst in *. simpl snd in *. destruct (H2 H) as [<-|H0]. + * destruct (H4 H); firstorder. + * destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder. + + simpl fst in *. simpl snd in *. destruct (H4' H) as [<-|H0]. + * destruct (H2' H); firstorder. + * destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder. } + destruct (ReprFunChoice D R Hequiv) as (g,Hg). + set (T' x y := T x y /\ exists y', T x y' /\ g (x,y') = (x,y)). + exists T'. split. + - intros x y (H,_); easy. + - intro x. destruct (Hexists x) as (y,Hy). + exists (snd (g (x,y))). + destruct (Hg (x,y)) as ((Heq1,(H',H'')),Hgxyuniq); clear Hg. + destruct (H' Hy) as [Heq2|Hgy]; clear H'. + + split. split. + * rewrite <- Heq2. assumption. + * exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1, Heq2. subst; easy. + * intros y' (Hy',(y'',(Hy'',Heq))). + rewrite (Hgxyuniq (x,y'')), Heq. easy. split. easy. + split; right; easy. + + split. split. + * assumption. + * exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1. subst x'; easy. + * intros y' (Hy',(y'',(Hy'',Heq))). + rewrite (Hgxyuniq (x,y'')), Heq. easy. split. easy. + split; right; easy. +Qed. + +(**********************************************************************) +(** ** AC_fun_setoid = AC_fun_setoid_gen = AC_fun_setoid_simple *) + +Theorem gen_setoid_fun_choice_imp_setoid_fun_choice : + forall A B, GeneralizedSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B. +Proof. + intros A B GenSetoidFunChoice R T Hequiv Hcompat Hex. + apply GenSetoidFunChoice; try easy. + apply eq_equivalence. + intros * H <-. firstorder. +Qed. + +Theorem setoid_fun_choice_imp_gen_setoid_fun_choice : + forall A B, SetoidFunctionalChoice_on A B -> GeneralizedSetoidFunctionalChoice_on A B. +Proof. + intros A B SetoidFunChoice R S T HequivR HequivS Hcompat Hex. + destruct SetoidFunChoice with (R:=R) (T:=T) as (f,Hf); try easy. + { intros; apply (Hcompat x x' y y); try easy. } + exists f. intros x; specialize Hf with x as (Hf,Huniq). intuition. now erewrite Huniq. +Qed. + +Corollary setoid_fun_choice_iff_gen_setoid_fun_choice : + forall A B, SetoidFunctionalChoice_on A B <-> GeneralizedSetoidFunctionalChoice_on A B. +Proof. + split; auto using gen_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_gen_setoid_fun_choice. +Qed. + +Theorem setoid_fun_choice_imp_simple_setoid_fun_choice : + forall A B, SetoidFunctionalChoice_on A B -> SimpleSetoidFunctionalChoice_on A B. +Proof. + intros A B SetoidFunChoice R T Hequiv Hexists. + pose (T' x y := forall x', R x x' -> T x' y). + assert (Hcompat : forall (x x' : A) (y : B), R x x' -> T' x y -> T' x' y) by firstorder. + destruct (SetoidFunChoice R T' Hequiv Hcompat Hexists) as (f,Hf). + exists f. firstorder. +Qed. + +Theorem simple_setoid_fun_choice_imp_setoid_fun_choice : + forall A B, SimpleSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B. +Proof. + intros A B SimpleSetoidFunChoice R T Hequiv Hcompat Hexists. + destruct (SimpleSetoidFunChoice R T Hequiv) as (f,Hf); firstorder. +Qed. + +Corollary setoid_fun_choice_iff_simple_setoid_fun_choice : + forall A B, SetoidFunctionalChoice_on A B <-> SimpleSetoidFunctionalChoice_on A B. +Proof. + split; auto using simple_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_simple_setoid_fun_choice. +Qed. + +(**********************************************************************) +(** ** AC_fun_setoid = AC! + AC_fun_repr *) + +Theorem setoid_fun_choice_imp_fun_choice : + forall A B, SetoidFunctionalChoice_on A B -> FunctionalChoice_on A B. +Proof. + intros A B SetoidFunChoice T Hexists. + destruct SetoidFunChoice with (R:=@eq A) (T:=T) as (f,Hf). + - apply eq_equivalence. + - now intros * ->. + - assumption. + - exists f. firstorder. +Qed. + +Corollary setoid_fun_choice_imp_functional_rel_reification : + forall A B, SetoidFunctionalChoice_on A B -> FunctionalRelReification_on A B. +Proof. + intros A B SetoidFunChoice. + apply fun_choice_imp_functional_rel_reification. + now apply setoid_fun_choice_imp_fun_choice. +Qed. + +Theorem setoid_fun_choice_imp_repr_fun_choice : + SetoidFunctionalChoice -> RepresentativeFunctionalChoice . +Proof. + intros SetoidFunChoice A R Hequiv. + apply SetoidFunChoice; firstorder. +Qed. + +Theorem functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice : + FunctionalRelReification -> RepresentativeFunctionalChoice -> SetoidFunctionalChoice. +Proof. + intros FunRelReify ReprFunChoice A B R T Hequiv Hcompat Hexists. + assert (FunChoice : FunctionalChoice). + { intros A' B'. apply functional_rel_reification_and_rel_choice_imp_fun_choice. + - apply FunRelReify. + - now apply repr_fun_choice_imp_relational_choice. } + destruct (FunChoice _ _ T Hexists) as (f,Hf). + destruct (ReprFunChoice A R Hequiv) as (g,Hg). + exists (fun a => f (g a)). + intro x. destruct (Hg x) as (Hgx,HRuniq). + split. + - eapply Hcompat. symmetry. apply Hgx. apply Hf. + - intros y Hxy. f_equal. auto. +Qed. + +Theorem functional_rel_reification_and_repr_fun_choice_iff_setoid_fun_choice : + FunctionalRelReification /\ RepresentativeFunctionalChoice <-> SetoidFunctionalChoice. +Proof. + split; intros. + - now apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. + - split. + + now intros A B; apply setoid_fun_choice_imp_functional_rel_reification. + + now apply setoid_fun_choice_imp_repr_fun_choice. +Qed. + +(** Note: What characterization to give of +RepresentativeFunctionalChoice? A formulation of it as a functional +relation would certainly be equivalent to the formulation of +SetoidFunctionalChoice as a functional relation, but in their +functional forms, SetoidFunctionalChoice seems strictly stronger *) + +(**********************************************************************) +(** * AC_fun_setoid = AC_fun + Ext_fun_repr + EM *) + +Import EqNotations. + +(** ** This is the main theorem in [[Carlström04]] *) + +(** Note: all ingredients have a computational meaning when taken in + separation. However, to compute with the functional choice, + existential quantification has to be thought as a strong + existential, which is incompatible with the computational content of + excluded-middle *) + +Theorem fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice : + FunctionalChoice -> ExtensionalFunctionRepresentative -> ExcludedMiddle -> RepresentativeFunctionalChoice. +Proof. + intros FunChoice SetoidFunRepr EM A R (Hrefl,Hsym,Htrans). + assert (H:forall P:Prop, exists b, b = true <-> P). + { intros P. destruct (EM P). + - exists true; firstorder. + - exists false; easy. } + destruct (FunChoice _ _ _ H) as (c,Hc). + pose (class_of a y := c (R a y)). + pose (isclass f := exists x:A, f x = true). + pose (class := {f:A -> bool | isclass f}). + pose (contains (c:class) (a:A) := proj1_sig c a = true). + destruct (FunChoice class A contains) as (f,Hf). + - intros f. destruct (proj2_sig f) as (x,Hx). + exists x. easy. + - destruct (SetoidFunRepr A bool) as (h,Hh). + assert (Hisclass:forall a, isclass (h (class_of a))). + { intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa). + rewrite <- Ha. apply Hc. apply Hrefl. } + pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class). + exists (fun a => f (f' a)). + intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split. + + specialize Hf with (f' x). unfold contains in Hf. simpl in Hf. rewrite <- Hx in Hf. apply Hc. assumption. + + intros y Hxy. + f_equal. + assert (Heq1: h (class_of x) = h (class_of y)). + { apply Huniqx. intro z. unfold class_of. + destruct (c (R x z)) eqn:Hxz. + - symmetry. apply Hc. apply -> Hc in Hxz. firstorder. + - destruct (c (R y z)) eqn:Hyz. + + apply -> Hc in Hyz. rewrite <- Hxz. apply Hc. firstorder. + + easy. } + assert (Heq2:rew Heq1 in Hisclass x = Hisclass y). + { apply proof_irrelevance_cci, EM. } + unfold f'. + rewrite <- Heq2. + rewrite <- Heq1. + reflexivity. +Qed. + +Theorem setoid_functional_choice_first_characterization : + FunctionalChoice /\ ExtensionalFunctionRepresentative /\ ExcludedMiddle <-> SetoidFunctionalChoice. +Proof. + split. + - intros (FunChoice & SetoidFunRepr & EM). + apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. + + intros A B. apply fun_choice_imp_functional_rel_reification, FunChoice. + + now apply fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice. + - intro SetoidFunChoice. repeat split. + + now intros A B; apply setoid_fun_choice_imp_fun_choice. + + apply repr_fun_choice_imp_ext_function_repr. + now apply setoid_fun_choice_imp_repr_fun_choice. + + apply repr_fun_choice_imp_excluded_middle. + now apply setoid_fun_choice_imp_repr_fun_choice. +Qed. + +(**********************************************************************) +(** ** AC_fun_setoid = AC_fun + Ext_pred_repr + PI *) + +(** Note: all ingredients have a computational meaning when taken in + separation. However, to compute with the functional choice, + existential quantification has to be thought as a strong + existential, which is incompatible with proof-irrelevance which + requires existential quantification to be truncated *) + +Theorem fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice : + FunctionalChoice -> ExtensionalPredicateRepresentative -> ProofIrrelevance -> RepresentativeFunctionalChoice. +Proof. + intros FunChoice PredExtRepr PI A R (Hrefl,Hsym,Htrans). + pose (isclass P := exists x:A, P x). + pose (class := {P:A -> Prop | isclass P}). + pose (contains (c:class) (a:A) := proj1_sig c a). + pose (class_of a := R a). + destruct (FunChoice class A contains) as (f,Hf). + - intros c. apply proj2_sig. + - destruct (PredExtRepr A) as (h,Hh). + assert (Hisclass:forall a, isclass (h (class_of a))). + { intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa). + rewrite <- Ha; apply Hrefl. } + pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class). + exists (fun a => f (f' a)). + intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split. + + specialize Hf with (f' x). simpl in Hf. rewrite <- Hx in Hf. assumption. + + intros y Hxy. + f_equal. + assert (Heq1: h (class_of x) = h (class_of y)). + { apply Huniqx. intro z. unfold class_of. firstorder. } + assert (Heq2:rew Heq1 in Hisclass x = Hisclass y). + { apply PI. } + unfold f'. + rewrite <- Heq2. + rewrite <- Heq1. + reflexivity. +Qed. + +Theorem setoid_functional_choice_second_characterization : + FunctionalChoice /\ ExtensionalPredicateRepresentative /\ ProofIrrelevance <-> SetoidFunctionalChoice. +Proof. + split. + - intros (FunChoice & ExtPredRepr & PI). + apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. + + intros A B. now apply fun_choice_imp_functional_rel_reification. + + now apply fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice. + - intro SetoidFunChoice. repeat split. + + now intros A B; apply setoid_fun_choice_imp_fun_choice. + + apply repr_fun_choice_imp_ext_pred_repr. + now apply setoid_fun_choice_imp_repr_fun_choice. + + red. apply proof_irrelevance_cci. + apply repr_fun_choice_imp_excluded_middle. + now apply setoid_fun_choice_imp_repr_fun_choice. +Qed. diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index afd64efdf..021408a37 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -34,8 +34,11 @@ Table of contents: 3 3. Independence of general premises and drinker's paradox -4. Classical logic and principle of unrestricted minimization +4. Principles equivalent to classical logic +4.1 Classical logic = principle of unrestricted minimization + +4.2 Classical logic = choice of representatives in a partition of bool *) (************************************************************************) @@ -94,12 +97,14 @@ Qed. (** A weakest form of propositional extensionality: extensionality for provable propositions only *) +Require Import PropExtensionalityFacts. + Definition provable_prop_extensionality := forall A:Prop, A -> A = True. Lemma provable_prop_ext : prop_extensionality -> provable_prop_extensionality. Proof. - intros Ext A Ha; apply Ext; split; trivial. + exact PropExt_imp_ProvPropExt. Qed. (************************************************************************) @@ -516,7 +521,7 @@ End Weak_proof_irrelevance_CCI. (** ** Weak excluded-middle *) (** The weak classical logic based on [~~A \/ ~A] is referred to with - name KC in {[ChagrovZakharyaschev97]] + name KC in [[ChagrovZakharyaschev97]] [[ChagrovZakharyaschev97]] Alexander Chagrov and Michael Zakharyaschev, "Modal Logic", Clarendon Press, 1997. @@ -661,6 +666,8 @@ Proof. exists x0; exact Hnot. Qed. +(** * Axioms equivalent to classical logic *) + (** ** Principle of unrestricted minimization *) Require Import Coq.Arith.PeanoNat. @@ -736,3 +743,56 @@ Section Example_of_undecidable_predicate_with_the_minimization_property. Qed. End Example_of_undecidable_predicate_with_the_minimization_property. + +(** ** Choice of representatives in a partition of bool *) + +(** This is similar to Bell's "weak extensional selection principle" in [[Bell]] + + [[Bell]] John L. Bell, Choice principles in intuitionistic set theory, unpublished. +*) + +Require Import RelationClasses. + +Local Notation representative_boolean_partition := + (forall R:bool->bool->Prop, + Equivalence R -> exists f, forall x, R x (f x) /\ forall y, R x y -> f x = f y). + +Theorem representative_boolean_partition_imp_excluded_middle : + representative_boolean_partition -> excluded_middle. +Proof. + intros ReprFunChoice P. + pose (R (b1 b2 : bool) := b1 = b2 \/ P). + assert (Equivalence R). + { split. + - now left. + - destruct 1. now left. now right. + - destruct 1, 1; try now right. left; now transitivity y. } + destruct (ReprFunChoice R H) as (f,Hf). clear H. + destruct (Bool.bool_dec (f true) (f false)) as [Heq|Hneq]. + + left. + destruct (Hf false) as ([Hfalse|HP],_); try easy. + destruct (Hf true) as ([Htrue|HP],_); try easy. + congruence. + + right. intro HP. + destruct (Hf true) as (_,H). apply Hneq, H. now right. +Qed. + +Theorem excluded_middle_imp_representative_boolean_partition : + excluded_middle -> representative_boolean_partition. +Proof. + intros EM R H. + destruct (EM (R true false)). + - exists (fun _ => true). + intros []; firstorder. + - exists (fun b => b). + intro b. split. + + reflexivity. + + destruct b, y; intros HR; easy || now symmetry in HR. +Qed. + +Theorem excluded_middle_iff_representative_boolean_partition : + excluded_middle <-> representative_boolean_partition. +Proof. + split; auto using excluded_middle_imp_representative_boolean_partition, + representative_boolean_partition_imp_excluded_middle. +Qed. diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 23af5afc6..896be7c33 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -8,9 +8,9 @@ (************************************************************************) (** Diaconescu showed that the Axiom of Choice entails Excluded-Middle - in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show + in topoi [[Diaconescu75]]. Lacas and Werner adapted the proof to show that the axiom of choice in equivalence classes entails - Excluded-Middle in Type Theory [LacasWerner99]. + Excluded-Middle in Type Theory [[LacasWerner99]]. Three variants of Diaconescu's result in type theory are shown below. @@ -23,22 +23,22 @@ Benjamin Werner) C. A proof that extensional Hilbert epsilon's description operator - entails excluded-middle (taken from Bell [Bell93]) + entails excluded-middle (taken from Bell [[Bell93]]) - See also [Carlström] for a discussion of the connection between the + See also [[Carlström04]] for a discussion of the connection between the Extensional Axiom of Choice and Excluded-Middle - [Diaconescu75] Radu Diaconescu, Axiom of Choice and Complementation, + [[Diaconescu75]] Radu Diaconescu, Axiom of Choice and Complementation, in Proceedings of AMS, vol 51, pp 176-178, 1975. - [LacasWerner99] Samuel Lacas, Benjamin Werner, Which Choices imply + [[LacasWerner99]] Samuel Lacas, Benjamin Werner, Which Choices imply the excluded middle?, preprint, 1999. - [Bell93] John L. Bell, Hilbert's epsilon operator and classical + [[Bell93]] John L. Bell, Hilbert's epsilon operator and classical logic, Journal of Philosophical Logic, 22: 1-18, 1993 - [Carlström04] Jesper Carlström, EM + Ext_ + AC_int <-> AC_ext, - Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004. + [[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent + to AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004. *) (**********************************************************************) @@ -263,7 +263,7 @@ End ProofIrrel_RelChoice_imp_EqEM. (**********************************************************************) (** * Extensional Hilbert's epsilon description operator -> Excluded-Middle *) -(** Proof sketch from Bell [Bell93] (with thanks to P. Castéran) *) +(** Proof sketch from Bell [[Bell93]] (with thanks to P. Castéran) *) Local Notation inhabited A := A (only parsing). diff --git a/theories/Logic/ExtensionalFunctionRepresentative.v b/theories/Logic/ExtensionalFunctionRepresentative.v new file mode 100644 index 000000000..a9da68e16 --- /dev/null +++ b/theories/Logic/ExtensionalFunctionRepresentative.v @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** This module states a limited form axiom of functional + extensionality which selects a canonical representative in each + class of extensional functions *) + +(** Its main interest is that it is the needed ingredient to provide + axiom of choice on setoids (a.k.a. axiom of extensional choice) + when combined with classical logic and axiom of (intensonal) + choice *) + +(** It provides extensionality of functions while still supporting (a + priori) an intensional interpretation of equality *) + +Axiom extensional_function_representative : + forall A B, exists repr, forall (f : A -> B), + (forall x, f x = repr f x) /\ + (forall g, (forall x, f x = g x) -> repr f = repr g). diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v index 04d9a6704..9551fea1a 100644 --- a/theories/Logic/FunctionalExtensionality.v +++ b/theories/Logic/FunctionalExtensionality.v @@ -56,6 +56,78 @@ Proof. apply functional_extensionality in H. destruct H. reflexivity. Defined. +(** A version of [functional_extensionality_dep] which is provably + equal to [eq_refl] on [fun _ => eq_refl] *) +Definition functional_extensionality_dep_good + {A} {B : A -> Type} + (f g : forall x : A, B x) + (H : forall x, f x = g x) + : f = g + := eq_trans (eq_sym (functional_extensionality_dep f f (fun _ => eq_refl))) + (functional_extensionality_dep f g H). + +Lemma functional_extensionality_dep_good_refl {A B} f + : @functional_extensionality_dep_good A B f f (fun _ => eq_refl) = eq_refl. +Proof. + unfold functional_extensionality_dep_good; edestruct functional_extensionality_dep; reflexivity. +Defined. + +Opaque functional_extensionality_dep_good. + +Lemma forall_sig_eq_rect + {A B} (f : forall a : A, B a) + (P : { g : _ | (forall a, f a = g a) } -> Type) + (k : P (exist (fun g => forall a, f a = g a) f (fun a => eq_refl))) + g +: P g. +Proof. + destruct g as [g1 g2]. + set (g' := fun x => (exist _ (g1 x) (g2 x))). + change g2 with (fun x => proj2_sig (g' x)). + change g1 with (fun x => proj1_sig (g' x)). + clearbody g'; clear g1 g2. + cut (forall x, (exist _ (f x) eq_refl) = g' x). + { intro H'. + apply functional_extensionality_dep_good in H'. + destruct H'. + exact k. } + { intro x. + destruct (g' x) as [g'x1 g'x2]. + destruct g'x2. + reflexivity. } +Defined. + +Definition forall_eq_rect + {A B} (f : forall a : A, B a) + (P : forall g, (forall a, f a = g a) -> Type) + (k : P f (fun a => eq_refl)) + g H + : P g H + := @forall_sig_eq_rect A B f (fun g => P (proj1_sig g) (proj2_sig g)) k (exist _ g H). + +Definition forall_eq_rect_comp {A B} f P k + : @forall_eq_rect A B f P k f (fun _ => eq_refl) = k. +Proof. + unfold forall_eq_rect, forall_sig_eq_rect; simpl. + rewrite functional_extensionality_dep_good_refl; reflexivity. +Qed. + +Definition f_equal__functional_extensionality_dep_good + {A B f g} H a + : f_equal (fun h => h a) (@functional_extensionality_dep_good A B f g H) = H a. +Proof. + apply forall_eq_rect with (H := H); clear H g. + change (eq_refl (f a)) with (f_equal (fun h => h a) (eq_refl f)). + apply f_equal, functional_extensionality_dep_good_refl. +Defined. + +Definition f_equal__functional_extensionality_dep_good__fun + {A B f g} H + : (fun a => f_equal (fun h => h a) (@functional_extensionality_dep_good A B f g H)) = H. +Proof. + apply functional_extensionality_dep_good; intro a; apply f_equal__functional_extensionality_dep_good. +Defined. + (** Apply [functional_extensionality], introducing variable x. *) Tactic Notation "extensionality" ident(x) := @@ -68,6 +140,87 @@ Tactic Notation "extensionality" ident(x) := apply forall_extensionality) ; intro x end. +(** Iteratively apply [functional_extensionality] on an hypothesis + until finding an equality statement *) +(* Note that you can write [Ltac extensionality_in_checker tac ::= tac tt.] to get a more informative error message. *) +Ltac extensionality_in_checker tac := + first [ tac tt | fail 1 "Anomaly: Unexpected error in extensionality tactic. Please report." ]. +Tactic Notation "extensionality" "in" hyp(H) := + let rec check_is_extensional_equality H := + lazymatch type of H with + | _ = _ => constr:(Prop) + | forall a : ?A, ?T + => let Ha := fresh in + constr:(forall a : A, match H a with Ha => ltac:(let v := check_is_extensional_equality Ha in exact v) end) + end in + let assert_is_extensional_equality H := + first [ let dummy := check_is_extensional_equality H in idtac + | fail 1 "Not an extensional equality" ] in + let assert_not_intensional_equality H := + lazymatch type of H with + | _ = _ => fail "Already an intensional equality" + | _ => idtac + end in + let enforce_no_body H := + (tryif (let dummy := (eval unfold H in H) in idtac) + then clearbody H + else idtac) in + let rec extensionality_step_make_type H := + lazymatch type of H with + | forall a : ?A, ?f = ?g + => constr:({ H' | (fun a => f_equal (fun h => h a) H') = H }) + | forall a : ?A, _ + => let H' := fresh in + constr:(forall a : A, match H a with H' => ltac:(let ret := extensionality_step_make_type H' in exact ret) end) + end in + let rec eta_contract T := + lazymatch (eval cbv beta in T) with + | context T'[fun a : ?A => ?f a] + => let T'' := context T'[f] in + eta_contract T'' + | ?T => T + end in + let rec lift_sig_extensionality H := + lazymatch type of H with + | sig _ => H + | forall a : ?A, _ + => let Ha := fresh in + let ret := constr:(fun a : A => match H a with Ha => ltac:(let v := lift_sig_extensionality Ha in exact v) end) in + lazymatch type of ret with + | forall a : ?A, sig (fun b : ?B => @?f a b = @?g a b) + => eta_contract (exist (fun b : (forall a : A, B) => (fun a : A => f a (b a)) = (fun a : A => g a (b a))) + (fun a : A => proj1_sig (ret a)) + (@functional_extensionality_dep_good _ _ _ _ (fun a : A => proj2_sig (ret a)))) + end + end in + let extensionality_pre_step H H_out Heq := + let T := extensionality_step_make_type H in + let H' := fresh in + assert (H' : T) by (intros; eexists; apply f_equal__functional_extensionality_dep_good__fun); + let H''b := lift_sig_extensionality H' in + case H''b; clear H'; + intros H_out Heq in + let rec extensionality_rec H H_out Heq := + lazymatch type of H with + | forall a, _ = _ + => extensionality_pre_step H H_out Heq + | _ + => let pre_H_out' := fresh H_out in + let H_out' := fresh pre_H_out' in + extensionality_pre_step H H_out' Heq; + let Heq' := fresh Heq in + extensionality_rec H_out' H_out Heq'; + subst H_out' + end in + first [ assert_is_extensional_equality H | fail 1 "Not an extensional equality" ]; + first [ assert_not_intensional_equality H | fail 1 "Already an intensional equality" ]; + (tryif enforce_no_body H then idtac else clearbody H); + let H_out := fresh in + let Heq := fresh "Heq" in + extensionality_in_checker ltac:(fun tt => extensionality_rec H H_out Heq); + (* If we [subst H], things break if we already have another equation of the form [_ = H] *) + destruct Heq; rename H_out into H. + (** Eta expansion follows from extensionality. *) Lemma eta_expansion_dep {A} {B : A -> Type} (f : forall x : A, B x) : diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index 841f843c0..a10c180cc 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -360,13 +360,12 @@ Module NoRetractToModalProposition. Section Paradox. Variable M : Prop -> Prop. -Hypothesis unit : forall A:Prop, A -> M A. -Hypothesis join : forall A:Prop, M (M A) -> M A. Hypothesis incr : forall A B:Prop, (A->B) -> M A -> M B. Lemma strength: forall A (P:A->Prop), M(forall x:A,P x) -> forall x:A,M(P x). Proof. - eauto. + intros A P h x. + eapply incr in h; eauto. Qed. (** ** The universe of modal propositions *) @@ -470,7 +469,7 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). Theorem paradox : forall B:NProp, El B. Proof. intros B. - unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). + exact (fun P => ~~P). + exact bool. + exact p2b. @@ -480,8 +479,6 @@ Proof. + cbn. auto. + cbn. auto. + cbn. auto. - + auto. - + auto. Qed. End Paradox. @@ -516,7 +513,7 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). Theorem mparadox : forall B:NProp, El B. Proof. intros B. - unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). + exact (fun P => P). + exact bool. + exact p2b. @@ -526,8 +523,6 @@ Proof. + cbn. auto. + cbn. auto. + cbn. auto. - + auto. - + auto. Qed. End MParadox. @@ -562,7 +557,7 @@ End Paradox. End NoRetractFromSmallPropositionToProp. -(** * Large universes are no retracts of [Prop]. *) +(** * Large universes are not retracts of [Prop]. *) (** The existence in the Calculus of Constructions with universes of a retract from some [Type] universe into [Prop] is inconsistent. *) diff --git a/printing/ppvernacsig.mli b/theories/Logic/PropExtensionality.v index 5e5e4bcf4..796c60273 100644 --- a/printing/ppvernacsig.mli +++ b/theories/Logic/PropExtensionality.v @@ -6,15 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -module type Pp = sig +(** This module states propositional extensionality and draws + consequences of it *) - (** Prints a fixpoint body *) - val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) -> Pp.std_ppcmds +Axiom propositional_extensionality : + forall (P Q : Prop), (P <-> Q) -> P = Q. - (** Prints a vernac expression *) - val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds +Require Import ClassicalFacts. - (** Prints a vernac expression and closes it with a dot. *) - val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds +Theorem proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2. +Proof. + apply ext_prop_dep_proof_irrel_cic. + exact propositional_extensionality. +Qed. -end diff --git a/theories/Logic/PropExtensionalityFacts.v b/theories/Logic/PropExtensionalityFacts.v new file mode 100644 index 000000000..7e455dfa1 --- /dev/null +++ b/theories/Logic/PropExtensionalityFacts.v @@ -0,0 +1,109 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Some facts and definitions about propositional and predicate extensionality + +We investigate the relations between the following extensionality principles + +- Proposition extensionality +- Predicate extensionality +- Propositional functional extensionality +- Provable-proposition extensionality +- Refutable-proposition extensionality +- Extensional proposition representatives +- Extensional predicate representatives +- Extensional propositional function representatives + +Table of contents + +1. Definitions + +2.1 Predicate extensionality <-> Proposition extensionality + Propositional functional extensionality + +2.2 Propositional extensionality -> Provable propositional extensionality + +2.3 Propositional extensionality -> Refutable propositional extensionality + +*) + +Set Implicit Arguments. + +(**********************************************************************) +(** * Definitions *) + +(** Propositional extensionality *) + +Local Notation PropositionalExtensionality := + (forall A B : Prop, (A <-> B) -> A = B). + +(** Provable-proposition extensionality *) + +Local Notation ProvablePropositionExtensionality := + (forall A:Prop, A -> A = True). + +(** Refutable-proposition extensionality *) + +Local Notation RefutablePropositionExtensionality := + (forall A:Prop, ~A -> A = False). + +(** Predicate extensionality *) + +Local Notation PredicateExtensionality := + (forall (A:Type) (P Q : A -> Prop), (forall x, P x <-> Q x) -> P = Q). + +(** Propositional functional extensionality *) + +Local Notation PropositionalFunctionalExtensionality := + (forall (A:Type) (P Q : A -> Prop), (forall x, P x = Q x) -> P = Q). + +(**********************************************************************) +(** * Propositional and predicate extensionality *) + +(**********************************************************************) +(** ** Predicate extensionality <-> Propositional extensionality + Propositional functional extensionality *) + +Lemma PredExt_imp_PropExt : PredicateExtensionality -> PropositionalExtensionality. +Proof. + intros Ext A B Equiv. + change A with ((fun _ => A) I). + now rewrite Ext with (P := fun _ : True =>A) (Q := fun _ => B). +Qed. + +Lemma PredExt_imp_PropFunExt : PredicateExtensionality -> PropositionalFunctionalExtensionality. +Proof. + intros Ext A P Q Eq. apply Ext. intros x. now rewrite (Eq x). +Qed. + +Lemma PropExt_and_PropFunExt_imp_PredExt : + PropositionalExtensionality -> PropositionalFunctionalExtensionality -> PredicateExtensionality. +Proof. + intros Ext FunExt A P Q Equiv. + apply FunExt. intros x. now apply Ext. +Qed. + +Theorem PropExt_and_PropFunExt_iff_PredExt : + PropositionalExtensionality /\ PropositionalFunctionalExtensionality <-> PredicateExtensionality. +Proof. + firstorder using PredExt_imp_PropExt, PredExt_imp_PropFunExt, PropExt_and_PropFunExt_imp_PredExt. +Qed. + +(**********************************************************************) +(** ** Propositional extensionality and provable proposition extensionality *) + +Lemma PropExt_imp_ProvPropExt : PropositionalExtensionality -> ProvablePropositionExtensionality. +Proof. + intros Ext A Ha; apply Ext; split; trivial. +Qed. + +(**********************************************************************) +(** ** Propositional extensionality and refutable proposition extensionality *) + +Lemma PropExt_imp_RefutPropExt : PropositionalExtensionality -> RefutablePropositionExtensionality. +Proof. + intros Ext A Ha; apply Ext; split; easy. +Qed. diff --git a/theories/Logic/SetoidChoice.v b/theories/Logic/SetoidChoice.v new file mode 100644 index 000000000..84432dda1 --- /dev/null +++ b/theories/Logic/SetoidChoice.v @@ -0,0 +1,60 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** This module states the functional form of the axiom of choice over + setoids, commonly called extensional axiom of choice [[Carlström04]], + [[Martin-Löf05]]. This is obtained by a decomposition of the axiom + into the following components: + + - classical logic + - relational axiom of choice + - axiom of unique choice + - a limited form of functional extensionality + + Among other results, it entails: + - proof irrelevance + - choice of a representative in equivalence classes + + [[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent to + AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004. + + [[Martin-Löf05] Per Martin-Löf, 100 years of Zermelo’s axiom of + choice: what was the problem with it?, lecture notes for KTH/SU + colloquium, 2005. + +*) + +Require Export ClassicalChoice. (* classical logic, relational choice, unique choice *) +Require Export ExtensionalFunctionRepresentative. + +Require Import ChoiceFacts. +Require Import ClassicalFacts. +Require Import RelationClasses. + +Theorem setoid_choice : + forall A B, + forall R : A -> A -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + (forall x x' y, R x x' -> T x y -> T x' y) -> + (forall x, exists y, T x y) -> + exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). +Proof. + apply setoid_functional_choice_first_characterization. split; [|split]. + - exact choice. + - exact extensional_function_representative. + - exact classic. +Qed. + +Theorem representative_choice : + forall A (R:A->A->Prop), (Equivalence R) -> + exists f : A->A, forall x : A, R x (f x) /\ forall x', R x x' -> f x = f x'. +Proof. + apply setoid_fun_choice_imp_repr_fun_choice. + exact setoid_choice. +Qed. diff --git a/theories/Logic/vo.itarget b/theories/Logic/vo.itarget index 323597395..8b0aa6691 100644 --- a/theories/Logic/vo.itarget +++ b/theories/Logic/vo.itarget @@ -1,4 +1,5 @@ Berardi.vo +PropExtensionalityFacts.vo ChoiceFacts.vo ClassicalChoice.vo ClassicalDescription.vo @@ -20,11 +21,14 @@ WeakFan.vo WKL.vo FunctionalExtensionality.vo ExtensionalityFacts.vo +ExtensionalFunctionRepresentative.vo Hurkens.vo IndefiniteDescription.vo JMeq.vo ProofIrrelevanceFacts.vo ProofIrrelevance.vo +PropExtensionality.vo RelationalChoice.vo SetIsType.vo -FinFun.vo
\ No newline at end of file +SetoidChoice.vo +FinFun.vo diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index 7baf102aa..d6385ee31 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -813,6 +813,34 @@ Proof. rewrite compare_cont_spec. unfold ge. destruct (p ?= q); easy'. Qed. +Lemma compare_cont_Lt_not_Lt p q : + compare_cont Lt p q <> Lt <-> p > q. +Proof. + rewrite compare_cont_Lt_Lt. + unfold gt, le, compare. + now destruct compare_cont; split; try apply comparison_eq_stable. +Qed. + +Lemma compare_cont_Lt_not_Gt p q : + compare_cont Lt p q <> Gt <-> p <= q. +Proof. + apply not_iff_compat, compare_cont_Lt_Gt. +Qed. + +Lemma compare_cont_Gt_not_Lt p q : + compare_cont Gt p q <> Lt <-> p >= q. +Proof. + apply not_iff_compat, compare_cont_Gt_Lt. +Qed. + +Lemma compare_cont_Gt_not_Gt p q : + compare_cont Gt p q <> Gt <-> p < q. +Proof. + rewrite compare_cont_Gt_Gt. + unfold ge, lt, compare. + now destruct compare_cont; split; try apply comparison_eq_stable. +Qed. + (** We can express recursive equations for [compare] *) Lemma compare_xO_xO p q : (p~0 ?= q~0) = (p ?= q). diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index a98d529fa..0e1608a32 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -78,7 +78,7 @@ Proof. ring. discrR. discrR. - pattern 1 at 3; replace 1 with (/ 1); + replace 1 with (/ 1); [ apply tech7; discrR | apply Rinv_1 ]. replace (An (S x)) with (An (S x + 0)%nat). apply (tech6 (fun i:nat => An (S x + i)%nat) (/ 2)). diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index 6fca9c8ad..67584f775 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -143,7 +143,7 @@ Proof. assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl; cut (0 < y). intro; unfold Rminus; - replace (- ((IZR (up (x / y)) + -1) * y)) with ((1 - IZR (up (x / y))) * y); + replace (- ((IZR (up (x / y)) + -(1)) * y)) with ((1 - IZR (up (x / y))) * y); [ idtac | ring ]. split. apply Rmult_le_reg_l with (/ y). diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index 4e2a7c3c6..05911cd53 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -31,9 +31,6 @@ Ltac discrR := try match goal with | |- (?X1 <> ?X2) => - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || @@ -52,9 +49,6 @@ Ltac prove_sup0 := end. Ltac omega_sup := - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; @@ -72,9 +66,6 @@ Ltac prove_sup := end. Ltac Rcompute := - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index 569518f7b..e9de24898 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -439,20 +439,16 @@ Proof. repeat rewrite <- Rmult_assoc. rewrite <- Rinv_r_sym. rewrite Rmult_1_l. - replace (INR N * INR N) with (Rsqr (INR N)); [ idtac | reflexivity ]. - rewrite Rmult_assoc. - rewrite Rmult_comm. - replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ]. + change 4 with (Rsqr 2). rewrite <- Rsqr_mult. apply Rsqr_incr_1. - replace 2 with (INR 2). - rewrite <- mult_INR; apply H1. - reflexivity. + change 2 with (INR 2). + rewrite Rmult_comm, <- mult_INR; apply H1. left; apply lt_INR_0; apply H. left; apply Rmult_lt_0_compat. - prove_sup0. apply lt_INR_0; apply div2_not_R0. apply lt_n_S; apply H. + now apply IZR_lt. cut (1 < S N)%nat. intro; unfold Rsqr; apply prod_neq_R0; apply not_O_INR; intro; assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4; diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v index 19db476fd..2d2385703 100644 --- a/theories/Reals/Machin.v +++ b/theories/Reals/Machin.v @@ -53,7 +53,7 @@ assert (-(PI/4) <= atan x). destruct xm1 as [xm1 | xm1]. rewrite <- atan_1, <- atan_opp; apply Rlt_le, atan_increasing. assumption. - solve[rewrite <- xm1, atan_opp, atan_1; apply Rle_refl]. + solve[rewrite <- xm1; change (-1) with (-(1)); rewrite atan_opp, atan_1; apply Rle_refl]. assert (-(PI/4) < atan y). rewrite <- atan_1, <- atan_opp; apply atan_increasing. assumption. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 379fee6f4..dd2108159 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -1743,24 +1743,40 @@ Proof. intros z; idtac; apply Z_of_nat_complete; assumption. Qed. +Lemma INR_IPR : forall p, INR (Pos.to_nat p) = IPR p. +Proof. + assert (H: forall p, 2 * INR (Pos.to_nat p) = IPR_2 p). + induction p as [p|p|] ; simpl IPR_2. + rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- IHp. + now rewrite (Rplus_comm (2 * _)). + now rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. + apply Rmult_1_r. + intros [p|p|] ; unfold IPR. + rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H. + apply Rplus_comm. + now rewrite Pos2Nat.inj_xO, mult_INR, <- H. + easy. +Qed. + (**********) Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z.of_nat n). Proof. - simple induction n; auto with real. - intros; simpl; rewrite SuccNat2Pos.id_succ; - auto with real. + intros [|n]. + easy. + simpl Z.of_nat. unfold IZR. + now rewrite <- INR_IPR, SuccNat2Pos.id_succ. Qed. Lemma plus_IZR_NEG_POS : forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q). Proof. intros p q; simpl. rewrite Z.pos_sub_spec. - case Pos.compare_spec; intros H; simpl. + case Pos.compare_spec; intros H; unfold IZR. subst. ring. - rewrite Pos2Nat.inj_sub by trivial. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial. rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt). ring. - rewrite Pos2Nat.inj_sub by trivial. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial. rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt). ring. Qed. @@ -1769,26 +1785,18 @@ Qed. Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m. Proof. intro z; destruct z; intro t; destruct t; intros; auto with real. - simpl; intros; rewrite Pos2Nat.inj_add; auto with real. + simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add. apply plus_INR. apply plus_IZR_NEG_POS. rewrite Z.add_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS. - simpl; intros; rewrite Pos2Nat.inj_add; rewrite plus_INR; - auto with real. + simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR. + apply Ropp_plus_distr. Qed. (**********) Lemma mult_IZR : forall n m:Z, IZR (n * m) = IZR n * IZR m. Proof. - intros z t; case z; case t; simpl; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - rewrite Rmult_comm. - rewrite Ropp_mult_distr_l_reverse; auto with real. - apply Ropp_eq_compat; rewrite mult_comm; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - rewrite Ropp_mult_distr_l_reverse; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - rewrite Rmult_opp_opp; auto with real. + intros z t; case z; case t; simpl; auto with real; + unfold IZR; intros m n; rewrite <- 3!INR_IPR, Pos2Nat.inj_mul, mult_INR; ring. Qed. Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Z.pow z (Z.of_nat n)). @@ -1804,13 +1812,13 @@ Qed. (**********) Lemma succ_IZR : forall n:Z, IZR (Z.succ n) = IZR n + 1. Proof. - intro; change 1 with (IZR 1); unfold Z.succ; apply plus_IZR. + intro; unfold Z.succ; apply plus_IZR. Qed. (**********) Lemma opp_IZR : forall n:Z, IZR (- n) = - IZR n. Proof. - intro z; case z; simpl; auto with real. + intros [|z|z]; unfold IZR; simpl; auto with real. Qed. Definition Ropp_Ropp_IZR := opp_IZR. @@ -1833,10 +1841,12 @@ Qed. Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. Proof. intro z; case z; simpl; intros. - absurd (0 < 0); auto with real. - unfold Z.lt; simpl; trivial. - case Rlt_not_le with (1 := H). - replace 0 with (-0); auto with real. + elim (Rlt_irrefl _ H). + easy. + elim (Rlt_not_le _ _ H). + unfold IZR. + rewrite <- INR_IPR. + auto with real. Qed. (**********) @@ -1852,9 +1862,12 @@ Qed. Lemma eq_IZR_R0 : forall n:Z, IZR n = 0 -> n = 0%Z. Proof. intro z; destruct z; simpl; intros; auto with zarith. - case (Rlt_not_eq 0 (INR (Pos.to_nat p))); auto with real. - case (Rlt_not_eq (- INR (Pos.to_nat p)) 0); auto with real. - apply Ropp_lt_gt_0_contravar. unfold Rgt; apply pos_INR_nat_of_P. + elim Rgt_not_eq with (2 := H). + unfold IZR. rewrite <- INR_IPR. + apply lt_0_INR, Pos2Nat.is_pos. + elim Rlt_not_eq with (2 := H). + unfold IZR. rewrite <- INR_IPR. + apply Ropp_lt_gt_0_contravar, lt_0_INR, Pos2Nat.is_pos. Qed. (**********) @@ -2003,6 +2016,31 @@ Proof. [ apply not_0_INR; discriminate | unfold INR; ring ]. Qed. +Lemma R_rm : ring_morph + R0 R1 Rplus Rmult Rminus Ropp eq + 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool IZR. +Proof. +constructor ; try easy. +exact plus_IZR. +exact minus_IZR. +exact mult_IZR. +exact opp_IZR. +intros x y H. +apply f_equal. +now apply Zeq_bool_eq. +Qed. + +Lemma Zeq_bool_IZR x y : + IZR x = IZR y -> Zeq_bool x y = true. +Proof. +intros H. +apply Zeq_is_eq_bool. +now apply eq_IZR. +Qed. + +Add Field RField : Rfield + (completeness Zeq_bool_IZR, morphism R_rm, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]). + (*********************************************************) (** ** Other rules about < and <= *) (*********************************************************) @@ -2017,42 +2055,18 @@ Qed. Lemma le_epsilon : forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2. Proof. - intros x y; intros; elim (Rtotal_order x y); intro. - left; assumption. - elim H0; intro. - right; assumption. - clear H0; generalize (Rgt_minus x y H1); intro H2; change (0 < x - y) in H2. - cut (0 < 2). - intro. - generalize (Rmult_lt_0_compat (x - y) (/ 2) H2 (Rinv_0_lt_compat 2 H0)); - intro H3; generalize (H ((x - y) * / 2) H3); - replace (y + (x - y) * / 2) with ((y + x) * / 2). - intro H4; - generalize (Rmult_le_compat_l 2 x ((y + x) * / 2) (Rlt_le 0 2 H0) H4); - rewrite <- (Rmult_comm ((y + x) * / 2)); rewrite Rmult_assoc; - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; replace (2 * x) with (x + x). - rewrite (Rplus_comm y); intro H5; apply Rplus_le_reg_l with x; assumption. - ring. - replace 2 with (INR 2); [ apply not_0_INR; discriminate | reflexivity ]. - pattern y at 2; replace y with (y / 2 + y / 2). - unfold Rminus, Rdiv. - repeat rewrite Rmult_plus_distr_r. - ring. - cut (forall z:R, 2 * z = z + z). - intro. - rewrite <- (H4 (y / 2)). - unfold Rdiv. - rewrite <- Rmult_assoc; apply Rinv_r_simpl_m. - replace 2 with (INR 2). - apply not_0_INR. - discriminate. - unfold INR; reflexivity. - intro; ring. - cut (0%nat <> 2%nat); - [ intro H0; generalize (lt_0_INR 2 (neq_O_lt 2 H0)); unfold INR; - intro; assumption - | discriminate ]. + intros x y H. + destruct (Rle_or_lt x y) as [H1|H1]. + exact H1. + apply Rplus_le_reg_r with x. + replace (y + x) with (2 * (y + (x - y) * / 2)) by field. + replace (x + x) with (2 * x) by ring. + apply Rmult_le_compat_l. + now apply (IZR_le 0 2). + apply H. + apply Rmult_lt_0_compat. + now apply Rgt_minus. + apply Rinv_0_lt_compat, Rlt_0_2. Qed. (**********) diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index b6d072837..e9b1762af 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -112,21 +112,12 @@ Lemma base_Int_part : Proof. intro; unfold Int_part; elim (archimed r); intros. split; rewrite <- (Z_R_minus (up r) 1); simpl. - generalize (Rle_minus (IZR (up r) - r) 1 H0); intro; unfold Rminus in H1; - rewrite (Rplus_assoc (IZR (up r)) (- r) (-1)) in H1; - rewrite (Rplus_comm (- r) (-1)) in H1; - rewrite <- (Rplus_assoc (IZR (up r)) (-1) (- r)) in H1; - fold (IZR (up r) - 1) in H1; fold (IZR (up r) - 1 - r) in H1; - apply Rminus_le; auto with zarith real. - generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro; - rewrite (Rplus_comm (-1) (IZR (up r))) in H1; - generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1); - intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2; - fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2; - rewrite (Rplus_comm (- r) (-1 + r)) in H2; - rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2; - elim (Rplus_ne (-1)); intros a b; rewrite a in H2; - clear a b; auto with zarith real. + apply Rminus_le. + replace (IZR (up r) - 1 - r) with (IZR (up r) - r - 1) by ring. + now apply Rle_minus. + apply Rminus_gt. + replace (IZR (up r) - 1 - r - -1) with (IZR (up r) - r) by ring. + now apply Rgt_minus. Qed. (**********) @@ -240,7 +231,6 @@ Proof. clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; cut (1 = IZR 1); auto with zarith real. - intro; rewrite H1 in H; clear H1; rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H; generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); intros; clear H H0; unfold Int_part at 1; @@ -324,12 +314,12 @@ Proof. rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0; elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; clear a b; rewrite <- (Rplus_opp_l 1) in H0; - rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1) + rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-(1)) 1) in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; - cut (1 = IZR 1); auto with zarith real. - intro; rewrite H1 in H; rewrite H1 in H0; clear H1; + auto with zarith real. + change (_ + -1) with (IZR (Int_part r1 - Int_part r2) - 1) in H; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0; rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0; @@ -442,9 +432,9 @@ Proof. in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0; elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; clear a b; + change 2 with (1 + 1) in H0; rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0; - cut (1 = IZR 1); auto with zarith real. - intro; rewrite H1 in H0; rewrite H1 in H; clear H1; + auto with zarith real. rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H; @@ -509,7 +499,6 @@ Proof. intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1); auto with zarith real. - intro; rewrite H in H1; clear H; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1; @@ -536,7 +525,7 @@ Proof. rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))); unfold Rminus; rewrite - (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-1)) + (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-(1))) ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1); trivial with zarith real. Qed. diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index 445ffcb21..a8937e36f 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -296,56 +296,9 @@ Lemma canonical_Rsqr : a * Rsqr (x + b / (2 * a)) + (4 * a * c - Rsqr b) / (4 * a). Proof. intros. - rewrite Rsqr_plus. - repeat rewrite Rmult_plus_distr_l. - repeat rewrite Rplus_assoc. - apply Rplus_eq_compat_l. - unfold Rdiv, Rminus. - replace (2 * 1 + 2 * 1) with 4; [ idtac | ring ]. - rewrite (Rmult_plus_distr_r (4 * a * c) (- Rsqr b) (/ (4 * a))). - rewrite Rsqr_mult. - repeat rewrite Rinv_mult_distr. - repeat rewrite (Rmult_comm a). - repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite (Rmult_comm (/ 2)). - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite (Rmult_comm a). - repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - repeat rewrite Rplus_assoc. - rewrite (Rplus_comm (Rsqr b * (Rsqr (/ a * / 2) * a))). - repeat rewrite Rplus_assoc. - rewrite (Rmult_comm x). - apply Rplus_eq_compat_l. - rewrite (Rmult_comm (/ a)). - unfold Rsqr; repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - ring. - apply (cond_nonzero a). - discrR. - apply (cond_nonzero a). - discrR. - discrR. - apply (cond_nonzero a). - discrR. - discrR. - discrR. - apply (cond_nonzero a). - discrR. - apply (cond_nonzero a). + unfold Rsqr. + field. + apply a. Qed. Lemma Rsqr_eq : forall x y:R, Rsqr x = Rsqr y -> x = y \/ x = - y. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index a6b1a26e0..0c1e0b7e8 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -359,107 +359,22 @@ Lemma Rsqr_sol_eq_0_1 : x = sol_x1 a b c \/ x = sol_x2 a b c -> a * Rsqr x + b * x + c = 0. Proof. intros; elim H0; intro. - unfold sol_x1 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv; - repeat rewrite Rsqr_mult; rewrite Rsqr_plus; rewrite <- Rsqr_neg; - rewrite Rsqr_sqrt. - rewrite Rsqr_inv. - unfold Rsqr; repeat rewrite Rinv_mult_distr. - repeat rewrite Rmult_assoc; rewrite (Rmult_comm a). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite Rmult_plus_distr_r. - repeat rewrite Rmult_assoc. - pattern 2 at 2; rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite - (Rmult_plus_distr_r (- b) (sqrt (b * b - 2 * (2 * (a * c)))) (/ 2 * / a)) - . - rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc. - replace - (- b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + - (b * (- b * (/ 2 * / a)) + - (b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + c))) with - (b * (- b * (/ 2 * / a)) + c). - unfold Rminus; repeat rewrite <- Rplus_assoc. - replace (b * b + b * b) with (2 * (b * b)). - rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc. - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; repeat rewrite Rmult_assoc. - rewrite (Rmult_comm a); rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite <- Rmult_opp_opp. - ring. - apply (cond_nonzero a). - discrR. - discrR. - discrR. - ring. - ring. - discrR. - apply (cond_nonzero a). - discrR. - apply (cond_nonzero a). - apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. - apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. - apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. - assumption. - unfold sol_x2 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv; - repeat rewrite Rsqr_mult; rewrite Rsqr_minus; rewrite <- Rsqr_neg; - rewrite Rsqr_sqrt. - rewrite Rsqr_inv. - unfold Rsqr; repeat rewrite Rinv_mult_distr; - repeat rewrite Rmult_assoc. - rewrite (Rmult_comm a); repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; unfold Rminus; rewrite Rmult_plus_distr_r. - rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc; - pattern 2 at 2; rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; - rewrite - (Rmult_plus_distr_r (- b) (- sqrt (b * b + - (2 * (2 * (a * c))))) - (/ 2 * / a)). - rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc. - rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_involutive. - replace - (b * (sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) + - (b * (- b * (/ 2 * / a)) + - (b * (- sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) + c))) with - (b * (- b * (/ 2 * / a)) + c). - repeat rewrite <- Rplus_assoc; replace (b * b + b * b) with (2 * (b * b)). - rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; - rewrite <- Rinv_l_sym. - rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc. - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc. - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; repeat rewrite Rmult_assoc; rewrite (Rmult_comm a); - rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite <- Rmult_opp_opp; ring. - apply (cond_nonzero a). - discrR. - discrR. - discrR. - ring. - ring. - discrR. - apply (cond_nonzero a). - discrR. - discrR. - apply (cond_nonzero a). - apply prod_neq_R0; discrR || apply (cond_nonzero a). - apply prod_neq_R0; discrR || apply (cond_nonzero a). - apply prod_neq_R0; discrR || apply (cond_nonzero a). - assumption. + rewrite H1. + unfold sol_x1, Delta, Rsqr. + field_simplify. + rewrite <- (Rsqr_pow2 (sqrt _)), Rsqr_sqrt. + field. + apply a. + apply H. + apply a. + rewrite H1. + unfold sol_x2, Delta, Rsqr. + field_simplify. + rewrite <- (Rsqr_pow2 (sqrt _)), Rsqr_sqrt. + field. + apply a. + apply H. + apply a. Qed. Lemma Rsqr_sol_eq_0_0 : @@ -505,10 +420,10 @@ Proof. rewrite (Rmult_comm (/ a)). rewrite Rmult_assoc. rewrite <- Rinv_mult_distr. - replace (2 * (2 * a) * a) with (Rsqr (2 * a)). + replace (4 * a * a) with (Rsqr (2 * a)). reflexivity. ring_Rsqr. - rewrite <- Rmult_assoc; apply prod_neq_R0; + apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. apply (cond_nonzero a). assumption. diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index 0254218c4..27cb356a0 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -88,17 +88,11 @@ Proof. right; unfold Rdiv. repeat rewrite Rabs_mult. rewrite Rabs_Rinv; discrR. - replace (Rabs 8) with 8. - replace 8 with 8; [ idtac | ring ]. - rewrite Rinv_mult_distr; [ idtac | discrR | discrR ]. - replace (2 * / Rabs (f2 x) * (Rabs eps * Rabs (f2 x) * (/ 2 * / 4))) with - (Rabs eps * / 4 * (2 * / 2) * (Rabs (f2 x) * / Rabs (f2 x))); - [ idtac | ring ]. - replace (Rabs eps) with eps. - repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption). - ring. - symmetry ; apply Rabs_right; left; assumption. - symmetry ; apply Rabs_right; left; prove_sup. + rewrite (Rabs_pos_eq 8) by now apply IZR_le. + rewrite (Rabs_pos_eq eps). + field. + now apply Rabs_no_R0. + now apply Rlt_le. Qed. Lemma maj_term2 : diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v index 4e88714d6..d4597aeba 100644 --- a/theories/Reals/Ranalysis3.v +++ b/theories/Reals/Ranalysis3.v @@ -201,8 +201,8 @@ Proof. apply Rabs_pos_lt. unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc. repeat apply prod_neq_R0; try assumption. - red; intro; rewrite H15 in H6; elim (Rlt_irrefl _ H6). - apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption. + now apply Rgt_not_eq. + apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. apply H13. split. apply D_x_no_cond; assumption. @@ -213,8 +213,7 @@ Proof. red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6). assumption. assumption. - apply Rinv_neq_0_compat; repeat apply prod_neq_R0; - [ discrR | discrR | discrR | assumption ]. + apply Rinv_neq_0_compat; apply prod_neq_R0; [discrR | assumption]. (***********************************) (* Third case *) (* (f1 x)<>0 l1=0 l2=0 *) @@ -224,11 +223,11 @@ Proof. elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); [ idtac | apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc; - repeat apply prod_neq_R0; + repeat apply prod_neq_R0 ; [ assumption | assumption - | red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6) - | apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption ] ]. + | now apply Rgt_not_eq + | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. intros alp_f2d H12. cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)). intro. @@ -295,8 +294,10 @@ Proof. elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); [ idtac | apply Rabs_pos_lt; unfold Rsqr, Rdiv; - repeat rewrite Rinv_mult_distr; repeat apply prod_neq_R0; - try assumption || discrR ]. + repeat apply prod_neq_R0 ; + [ assumption.. + | now apply Rgt_not_eq + | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. intros alp_f2d H11. assert (H12 := derivable_continuous_pt _ _ X). unfold continuity_pt in H12. @@ -380,15 +381,9 @@ Proof. repeat apply prod_neq_R0; try assumption. red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; assumption. apply Rinv_neq_0_compat; assumption. discrR. - discrR. - discrR. - discrR. - discrR. apply prod_neq_R0; [ discrR | assumption ]. elim H13; intros. apply H19. @@ -408,16 +403,9 @@ Proof. repeat apply prod_neq_R0; try assumption. red; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; assumption. apply Rinv_neq_0_compat; assumption. apply prod_neq_R0; [ discrR | assumption ]. - red; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6). - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; assumption. (***********************************) (* Fifth case *) (* (f1 x)<>0 l1<>0 l2=0 *) diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v index 661bc8c76..23daedb8b 100644 --- a/theories/Reals/Ranalysis4.v +++ b/theories/Reals/Ranalysis4.v @@ -130,15 +130,8 @@ Proof. intro; exists (mkposreal (- x) H1); intros. rewrite (Rabs_left x). rewrite (Rabs_left (x + h)). - rewrite Rplus_comm. - rewrite Ropp_plus_distr. - unfold Rminus; rewrite Ropp_involutive; rewrite Rplus_assoc; - rewrite Rplus_opp_l. - rewrite Rplus_0_r; unfold Rdiv. - rewrite Ropp_mult_distr_l_reverse. - rewrite <- Rinv_r_sym. - rewrite Ropp_involutive; rewrite Rplus_opp_l; rewrite Rabs_R0; apply H0. - apply H2. + replace ((-(x + h) - - x) / h - -1) with 0 by now field. + rewrite Rabs_R0; apply H0. destruct (Rcase_abs h) as [Hlt|Hgt]. apply Ropp_lt_cancel. rewrite Ropp_0; rewrite Ropp_plus_distr; apply Rplus_lt_0_compat. diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index d172139f5..f9da88aad 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -249,8 +249,10 @@ assert (Sublemma : forall x y lb ub, lb <= x <= ub /\ lb <= y <= ub -> lb <= (x+ split. replace lb with ((lb + lb) * /2) by field. unfold Rdiv ; apply Rmult_le_compat_r ; intuition. + now apply Rlt_le, Rinv_0_lt_compat, IZR_lt. replace ub with ((ub + ub) * /2) by field. unfold Rdiv ; apply Rmult_le_compat_r ; intuition. + now apply Rlt_le, Rinv_0_lt_compat, IZR_lt. intros x y P N x_lt_y. induction N. simpl ; intuition. @@ -1030,6 +1032,7 @@ intros x ub lb lb_lt_x x_lt_ub. assert (T : 0 < ub - lb). fourier. unfold Rdiv ; apply Rlt_mult_inv_pos ; intuition. +now apply IZR_lt. Qed. Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb<x) (x_lt_ub:x<ub) : posreal. @@ -1102,7 +1105,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg. replace (- (fn N (x + h) - fn N x)) with (fn N x - fn N (x + h)) by field. assumption. - solve[apply Rlt_not_eq ; intuition]. + now apply Rlt_not_eq, IZR_lt. rewrite <- Hc'; clear Hc Hc'. replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c). replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field. diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v index e13ef1f2c..e438750df 100644 --- a/theories/Reals/Ratan.v +++ b/theories/Reals/Ratan.v @@ -132,7 +132,7 @@ intros [ | N] Npos n decr to0 cv nN. unfold Rminus; apply Rplus_le_compat_l, Ropp_le_contravar. solve[apply Rge_le, (growing_prop _ _ _ (CV_ALT_step0 f decr) dist)]. unfold Rminus; rewrite tech5, Ropp_plus_distr, <- Rplus_assoc. - unfold tg_alt at 2; rewrite pow_1_odd, Ropp_mult_distr_l_reverse; fourier. + unfold tg_alt at 2; rewrite pow_1_odd; fourier. rewrite Nodd; destruct (alternated_series_ineq _ _ p decr to0 cv) as [B _]. destruct (alternated_series_ineq _ _ (S p) decr to0 cv) as [_ C]. assert (keep : (2 * S p = S (S ( 2 * p)))%nat) by ring. @@ -161,7 +161,6 @@ clear WLOG; intros Hyp [ | n] decr to0 cv _. generalize (alternated_series_ineq f l 0 decr to0 cv). unfold R_dist, tg_alt; simpl; rewrite !Rmult_1_l, !Rmult_1_r. assert (f 1%nat <= f 0%nat) by apply decr. - rewrite Ropp_mult_distr_l_reverse. intros [A B]; rewrite Rabs_pos_eq; fourier. apply Rle_trans with (f 1%nat). apply (Hyp 1%nat (le_n 1) (S n) decr to0 cv). @@ -320,31 +319,12 @@ apply PI2_lower_bound;[split; fourier | ]. destruct (pre_cos_bound (3/2) 1) as [t _]; [fourier | fourier | ]. apply Rlt_le_trans with (2 := t); clear t. unfold cos_approx; simpl; unfold cos_term. -simpl mult; replace ((-1)^ 0) with 1 by ring; replace ((-1)^2) with 1 by ring; - replace ((-1)^4) with 1 by ring; replace ((-1)^1) with (-1) by ring; - replace ((-1)^3) with (-1) by ring; replace 3 with (IZR 3) by (simpl; ring); - replace 2 with (IZR 2) by (simpl; ring); simpl Z.of_nat; - rewrite !INR_IZR_INZ, Ropp_mult_distr_l_reverse, Rmult_1_l. -match goal with |- _ < ?a => -replace a with ((- IZR 3 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 4)) + - IZR 3 ^ 4 * IZR 2 ^ 2 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 6)) - - IZR 3 ^ 2 * IZR 2 ^ 4 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 4)) * - IZR (Z.of_nat (fact 6)) + - IZR 2 ^ 6 * IZR (Z.of_nat (fact 2)) * IZR (Z.of_nat (fact 4)) * - IZR (Z.of_nat (fact 6))) / - (IZR 2 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 4)) * IZR (Z.of_nat (fact 6))));[ | field; - repeat apply conj;((rewrite <- INR_IZR_INZ; apply INR_fact_neq_0) || - (apply Rgt_not_eq; apply (IZR_lt 0); reflexivity)) ] -end. -rewrite !fact_simpl, !Nat2Z.inj_mul; simpl Z.of_nat. -unfold Rdiv; apply Rmult_lt_0_compat. -unfold Rminus; rewrite !pow_IZR, <- !opp_IZR, <- !mult_IZR, <- !opp_IZR, - <- !plus_IZR; apply (IZR_lt 0); reflexivity. -apply Rinv_0_lt_compat; rewrite !pow_IZR, <- !mult_IZR; apply (IZR_lt 0). -reflexivity. +rewrite !INR_IZR_INZ. +simpl. +field_simplify. +unfold Rdiv. +rewrite Rmult_0_l. +apply Rdiv_lt_0_compat ; now apply IZR_lt. Qed. Lemma PI2_1 : 1 < PI/2. @@ -502,11 +482,11 @@ split. rewrite (Rmult_comm (-1)); simpl ((/(Rabs y + 1)) ^ 0). unfold Rdiv; rewrite Rinv_1, !Rmult_assoc, <- !Rmult_plus_distr_l. apply tmp;[assumption | ]. - rewrite Rplus_assoc, Rmult_1_l; pattern 1 at 3; rewrite <- Rplus_0_r. + rewrite Rplus_assoc, Rmult_1_l; pattern 1 at 2; rewrite <- Rplus_0_r. apply Rplus_lt_compat_l. rewrite <- Rmult_assoc. match goal with |- (?a * (-1)) + _ < 0 => - rewrite <- (Rplus_opp_l a), Ropp_mult_distr_r_reverse, Rmult_1_r + rewrite <- (Rplus_opp_l a); change (-1) with (-(1)); rewrite Ropp_mult_distr_r_reverse, Rmult_1_r end. apply Rplus_lt_compat_l. assert (0 < u ^ 2) by (apply pow_lt; assumption). @@ -853,6 +833,8 @@ intros x Hx eps Heps. apply Rlt_trans with (2 := H). apply Rinv_0_lt_compat. exact Heps. + unfold N. + rewrite INR_IZR_INZ, positive_nat_Z. exact HN. apply lt_INR. omega. @@ -1076,8 +1058,9 @@ apply Rlt_not_eq; apply Rle_lt_trans with 0;[ | apply Rlt_0_1]. assert (t := pow2_ge_0 x); fourier. replace (1 + x ^ 2) with (1 - - (x ^ 2)) by ring; rewrite <- (tech3 _ n dif). apply sum_eq; unfold tg_alt, Datan_seq; intros i _. -rewrite pow_mult, <- Rpow_mult_distr, Ropp_mult_distr_l_reverse, Rmult_1_l. -reflexivity. +rewrite pow_mult, <- Rpow_mult_distr. +f_equal. +ring. Qed. Lemma Datan_seq_increasing : forall x y n, (n > 0)%nat -> 0 <= x < y -> Datan_seq x n < Datan_seq y n. @@ -1165,6 +1148,7 @@ assert (tool : forall a b, a / b - /b = (-1 + a) /b). reflexivity. set (u := 1 + x ^ 2); rewrite tool; unfold Rminus; rewrite <- Rplus_assoc. unfold Rdiv, u. +change (-1) with (-(1)). rewrite Rplus_opp_l, Rplus_0_l, Ropp_mult_distr_l_reverse, Rabs_Ropp. rewrite Rabs_mult; clear tool u. assert (tool : forall k, Rabs ((-x ^ 2) ^ k) = Rabs ((x ^ 2) ^ k)). diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 9fbda92a2..7f9db3b18 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -115,19 +115,6 @@ Arguments INR n%nat. (**********************************************************) -(** * Injection from [Z] to [R] *) -(**********************************************************) - -(**********) -Definition IZR (z:Z) : R := - match z with - | Z0 => 0 - | Zpos n => INR (Pos.to_nat n) - | Zneg n => - INR (Pos.to_nat n) - end. -Arguments IZR z%Z. - -(**********************************************************) (** * [R] Archimedean *) (**********************************************************) diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index c889d7347..df1662497 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -451,20 +451,16 @@ Qed. Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x. Proof. - intro; cut (- x = -1 * x). - intros; rewrite H. + intro; replace (-x) with (-1 * x) by ring. rewrite Rabs_mult. - cut (Rabs (-1) = 1). - intros; rewrite H0. - ring. + replace (Rabs (-1)) with 1. + apply Rmult_1_l. unfold Rabs; case (Rcase_abs (-1)). intro; ring. - intro H0; generalize (Rge_le (-1) 0 H0); intros. - generalize (Ropp_le_ge_contravar 0 (-1) H1). - rewrite Ropp_involutive; rewrite Ropp_0. - intro; generalize (Rgt_not_le 1 0 Rlt_0_1); intro; generalize (Rge_le 0 1 H2); - intro; exfalso; auto. - ring. + rewrite <- Ropp_0. + intro H0; apply Ropp_ge_cancel in H0. + elim (Rge_not_lt _ _ H0). + apply Rlt_0_1. Qed. (*********) @@ -613,11 +609,12 @@ Qed. Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Z.abs z). Proof. - intros z; case z; simpl; auto with real. - apply Rabs_right; auto with real. - intros p0; apply Rabs_right; auto with real zarith. + intros z; case z; unfold Zabs. + apply Rabs_R0. + now intros p0; apply Rabs_pos_eq, (IZR_le 0). + unfold IZR at 1. intros p0; rewrite Rabs_Ropp. - apply Rabs_right; auto with real zarith. + now apply Rabs_pos_eq, (IZR_le 0). Qed. Lemma abs_IZR : forall z, IZR (Z.abs z) = Rabs (IZR z). diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index f3f8f7409..cb5dea93a 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -69,3 +69,32 @@ Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope. Notation "x <= y < z" := (x <= y /\ y < z) : R_scope. Notation "x < y < z" := (x < y /\ y < z) : R_scope. Notation "x < y <= z" := (x < y /\ y <= z) : R_scope. + +(**********************************************************) +(** * Injection from [Z] to [R] *) +(**********************************************************) + +(* compact representation for 2*p *) +Fixpoint IPR_2 (p:positive) : R := + match p with + | xH => R1 + R1 + | xO p => (R1 + R1) * IPR_2 p + | xI p => (R1 + R1) * (R1 + IPR_2 p) + end. + +Definition IPR (p:positive) : R := + match p with + | xH => R1 + | xO p => IPR_2 p + | xI p => R1 + IPR_2 p + end. +Arguments IPR p%positive : simpl never. + +(**********) +Definition IZR (z:Z) : R := + match z with + | Z0 => R0 + | Zpos n => IPR n + | Zneg n => - IPR n + end. +Arguments IZR z%Z : simpl never. diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index bd330ac9b..5fb6bd2b7 100644 --- a/theories/Reals/Rderiv.v +++ b/theories/Reals/Rderiv.v @@ -296,14 +296,10 @@ Proof. intros; generalize (H0 eps H1); clear H0; intro; elim H0; clear H0; intros; elim H0; clear H0; simpl; intros; split with x; split; auto. - intros; generalize (H2 x1 H3); clear H2; intro; - rewrite Ropp_mult_distr_l_reverse in H2; - rewrite Ropp_mult_distr_l_reverse in H2; - rewrite Ropp_mult_distr_l_reverse in H2; - rewrite (let (H1, H2) := Rmult_ne (f x1) in H2) in H2; - rewrite (let (H1, H2) := Rmult_ne (f x0) in H2) in H2; - rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2; - assumption. + intros; generalize (H2 x1 H3); clear H2; intro. + replace (- f x1 - - f x0) with (-1 * f x1 - -1 * f x0) by ring. + replace (- df x0) with (-1 * df x0) by ring. + exact H2. Qed. (*********) diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index 0a49d4983..99acdd0a1 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -416,8 +416,9 @@ Proof. simpl; apply Rabs_R1. replace (S n) with (n + 1)%nat; [ rewrite pow_add | ring ]. rewrite Rabs_mult. - rewrite Hrecn; rewrite Rmult_1_l; simpl; rewrite Rmult_1_r; - rewrite Rabs_Ropp; apply Rabs_R1. + rewrite Hrecn; rewrite Rmult_1_l; simpl; rewrite Rmult_1_r. + change (-1) with (-(1)). + rewrite Rabs_Ropp; apply Rabs_R1. Qed. Lemma pow_mult : forall (x:R) (n1 n2:nat), x ^ (n1 * n2) = (x ^ n1) ^ n2. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index e424a732a..f07140752 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -407,8 +407,7 @@ Proof. generalize (Rplus_lt_compat (R_dist (f x2) l) eps (R_dist (f x2) l') eps H H0); unfold R_dist; intros; rewrite (Rabs_minus_sym (f x2) l) in H1; - rewrite (Rmult_comm 2 eps); rewrite (Rmult_plus_distr_l eps 1 1); - elim (Rmult_ne eps); intros a b; rewrite a; clear a b; + rewrite (Rmult_comm 2 eps); replace (eps *2) with (eps + eps) by ring; generalize (R_dist_tri l l' (f x2)); unfold R_dist; intros; apply diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v index 791718a45..f331bb203 100644 --- a/theories/Reals/Rpow_def.v +++ b/theories/Reals/Rpow_def.v @@ -10,6 +10,6 @@ Require Import Rdefinitions. Fixpoint pow (r:R) (n:nat) : R := match n with - | O => R1 + | O => 1 | S n => Rmult r (pow r n) end. diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index b3ce6fa33..f62ed2a6c 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -55,25 +55,8 @@ Proof. simpl in H0. replace (/ 3) with (1 * / 1 + -1 * 1 * / 1 + -1 * (-1 * 1) * / 2 + - -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)). + -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)) by field. apply H0. - repeat rewrite Rinv_1; repeat rewrite Rmult_1_r; - rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l; - rewrite Ropp_involutive; rewrite Rplus_opp_r; rewrite Rmult_1_r; - rewrite Rplus_0_l; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 6. - rewrite Rmult_plus_distr_l; replace (2 + 1 + 1 + 1 + 1) with 6. - rewrite <- (Rmult_comm (/ 6)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym. - rewrite Rmult_1_l; replace 6 with 6. - do 2 rewrite Rmult_assoc; rewrite <- Rinv_r_sym. - rewrite Rmult_1_r; rewrite (Rmult_comm 3); rewrite <- Rmult_assoc; - rewrite <- Rinv_r_sym. - ring. - discrR. - discrR. - ring. - discrR. - ring. - discrR. apply H. unfold Un_decreasing; intros; apply Rmult_le_reg_l with (INR (fact n)). @@ -505,12 +488,9 @@ Proof. rewrite Rinv_r. apply exp_lt_inv. apply Rle_lt_trans with (1 := exp_le_3). - change (3 < 2 ^R 2). + change (3 < 2 ^R (1 + 1)). repeat rewrite Rpower_plus; repeat rewrite Rpower_1. - repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l; - repeat rewrite Rmult_1_l. - pattern 3 at 1; rewrite <- Rplus_0_r; replace (2 + 2) with (3 + 1); - [ apply Rplus_lt_compat_l; apply Rlt_0_1 | ring ]. + now apply (IZR_lt 3 4). prove_sup0. discrR. Qed. @@ -732,7 +712,7 @@ Definition arcsinh x := ln (x + sqrt (x ^ 2 + 1)). Lemma arcsinh_sinh : forall x, arcsinh (sinh x) = x. intros x; unfold sinh, arcsinh. assert (Rminus_eq_0 : forall r, r - r = 0) by (intros; ring). -pattern 1 at 5; rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus. +rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus. rewrite exp_plus. match goal with |- context[sqrt ?a] => replace a with (((exp x + exp(-x))/2)^2) by field diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index 744fd6641..c6b0c3f37 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -207,7 +207,7 @@ Section sequence. assert (Rabs (/2) < 1). rewrite Rabs_pos_eq. - rewrite <- Rinv_1 at 3. + rewrite <- Rinv_1. apply Rinv_lt_contravar. rewrite Rmult_1_l. now apply (IZR_lt 0 2). diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index 4d2418639..17b9677ef 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -182,13 +182,10 @@ destruct (pre_cos_bound _ 0 lo up) as [_ upper]. apply Rle_lt_trans with (1 := upper). apply Rlt_le_trans with (2 := lower). unfold cos_approx, sin_approx. -simpl sum_f_R0; replace 7 with (IZR 7) by (simpl; field). -replace 8 with (IZR 8) by (simpl; field). +simpl sum_f_R0. unfold cos_term, sin_term; simpl fact; rewrite !INR_IZR_INZ. -simpl plus; simpl mult. -field_simplify; - try (repeat apply conj; apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity). -unfold Rminus; rewrite !pow_IZR, <- !mult_IZR, <- !opp_IZR, <- ?plus_IZR. +simpl plus; simpl mult; simpl Z_of_nat. +field_simplify. match goal with |- IZR ?a / ?b < ?c / ?d => apply Rmult_lt_reg_r with d;[apply (IZR_lt 0); reflexivity | @@ -198,7 +195,7 @@ match goal with end. unfold Rdiv; rewrite !Rmult_assoc, Rinv_l, Rmult_1_r; [ | apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity]. -repeat (rewrite <- !plus_IZR || rewrite <- !mult_IZR). +rewrite <- !mult_IZR. apply IZR_lt; reflexivity. Qed. @@ -323,6 +320,7 @@ Lemma sin_PI : sin PI = 0. Proof. assert (H := sin2_cos2 PI). rewrite cos_PI in H. + change (-1) with (-(1)) in H. rewrite <- Rsqr_neg in H. rewrite Rsqr_1 in H. cut (Rsqr (sin PI) = 0). @@ -533,9 +531,8 @@ Qed. Lemma sin_PI_x : forall x:R, sin (PI - x) = sin x. Proof. - intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI; rewrite Rmult_0_l; - unfold Rminus in |- *; rewrite Rplus_0_l; rewrite Ropp_mult_distr_l_reverse; - rewrite Ropp_involutive; apply Rmult_1_l. + intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI. + ring. Qed. Lemma sin_period : forall (x:R) (k:nat), sin (x + 2 * INR k * PI) = sin x. @@ -593,9 +590,9 @@ Proof. generalize (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1) (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); - rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0; + rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0. generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; + repeat rewrite <- Rplus_assoc; change (-1) with (-(1)); rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); @@ -603,6 +600,7 @@ Proof. auto with real. cut (sin x < -1). intro; generalize (Ropp_lt_gt_contravar (sin x) (-1) H); + change (-1) with (-(1)); rewrite Ropp_involutive; clear H; intro; generalize (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1) @@ -610,7 +608,7 @@ Proof. rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; rewrite sin2 in H0; unfold Rminus in H0; generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; + rewrite <- Rplus_assoc; change (-1) with (-(1)); rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); @@ -712,17 +710,16 @@ Proof. do 2 rewrite fact_simpl; do 2 rewrite mult_INR. repeat rewrite <- Rmult_assoc. rewrite <- (Rmult_comm (INR (fact (2 * n + 1)))). - rewrite Rmult_assoc. apply Rmult_lt_compat_l. apply lt_INR_0; apply neq_O_lt. assert (H2 := fact_neq_0 (2 * n + 1)). red in |- *; intro; elim H2; symmetry in |- *; assumption. do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; set (x := INR n); unfold INR in |- *. - replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6); + replace (((1 + 1) * x + 1 + 1 + 1) * ((1 + 1) * x + 1 + 1)) with (4 * x * x + 10 * x + 6); [ idtac | ring ]. - apply Rplus_lt_reg_l with (-4); rewrite Rplus_opp_l; - replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2); + apply Rplus_lt_reg_l with (-(4)); rewrite Rplus_opp_l; + replace (-(4) + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2); [ idtac | ring ]. apply Rplus_le_lt_0_compat. cut (0 <= x). @@ -767,7 +764,7 @@ Proof. unfold Rdiv in |- *; pattern PI at 2 in |- *; rewrite <- Rmult_1_r. apply Rmult_lt_compat_l. apply PI_RGT_0. - pattern 1 at 3 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar. + rewrite <- Rinv_1; apply Rinv_lt_contravar. rewrite Rmult_1_l; prove_sup0. pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1. @@ -1260,44 +1257,22 @@ Proof. intros x y H1 H2 H3 H4; rewrite <- (cos_neg x); rewrite <- (cos_neg y); rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1); unfold INR in |- *; - replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))). - replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))). + replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))) by field. + replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))) by field. repeat rewrite cos_shift; intro H5; generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1); generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2); generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3); generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4). - replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)). - replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)). - replace (-3 * (PI / 2) + 2 * PI) with (PI / 2). - replace (-3 * (PI / 2) + PI) with (- (PI / 2)). + replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring. + replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring. + replace (-3 * (PI / 2) + 2 * PI) with (PI / 2) by field. + replace (-3 * (PI / 2) + PI) with (- (PI / 2)) by field. clear H1 H2 H3 H4; intros H1 H2 H3 H4; apply Rplus_lt_reg_l with (-3 * (PI / 2)); - replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)). - replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)). + replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring. + replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring. apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5). - unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. - unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. - pattern PI at 3 in |- *; rewrite double_var. - ring. - rewrite double; pattern PI at 3 4 in |- *; rewrite double_var. - ring. - unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. - unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. - rewrite Rmult_1_r. - rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var. - ring. - rewrite Rmult_1_r. - rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var. - ring. Qed. Lemma cos_increasing_1 : @@ -1737,7 +1712,7 @@ Proof. rewrite H5. rewrite mult_INR. simpl in |- *. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. apply sin_0. rewrite H5. @@ -1747,7 +1722,7 @@ Proof. rewrite Rmult_1_l; rewrite sin_plus. rewrite sin_PI. rewrite Rmult_0_r. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. apply le_IZR. @@ -1769,7 +1744,7 @@ Proof. rewrite H5. rewrite mult_INR. simpl in |- *. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. rewrite H5. @@ -1779,7 +1754,7 @@ Proof. rewrite Rmult_1_l; rewrite sin_plus. rewrite sin_PI. rewrite Rmult_0_r. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. apply le_IZR. @@ -1858,7 +1833,7 @@ Proof. - right; left; auto. - left. clear Hi. subst. - replace 0 with (IZR 0 * PI) by (simpl; ring). f_equal. f_equal. + replace 0 with (IZR 0 * PI) by apply Rmult_0_l. f_equal. f_equal. apply one_IZR_lt1. split. + apply Rlt_le_trans with 0; diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index a5092d22d..092bc30d0 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -320,7 +320,7 @@ Proof. (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)). unfold Rminus; rewrite Ropp_plus_distr; rewrite Ropp_involutive; repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1); - rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; + rewrite (Rplus_comm (-(1))); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp; rewrite Ropp_plus_distr; rewrite Ropp_involutive; unfold Rminus in H6; apply H6. @@ -367,10 +367,10 @@ Proof. reflexivity. ring. intro; elim H2; intros; split. - apply Rplus_le_reg_l with (-1). + apply Rplus_le_reg_l with (-(1)). rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite (Rplus_comm (-1)); apply H3. - apply Rplus_le_reg_l with (-1). + apply Rplus_le_reg_l with (-(1)). rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite (Rplus_comm (-1)); apply H4. unfold cos_term; simpl; unfold Rdiv; rewrite Rinv_1; diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index 9ba14ee73..53056cabd 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -32,48 +32,22 @@ Proof. Qed. Lemma sin_cos_PI4 : sin (PI / 4) = cos (PI / 4). -Proof with trivial. - rewrite cos_sin... - replace (PI / 2 + PI / 4) with (- (PI / 4) + PI)... - rewrite neg_sin; rewrite sin_neg; ring... - cut (PI = PI / 2 + PI / 2); [ intro | apply double_var ]... - pattern PI at 2 3; rewrite H; pattern PI at 2 3; rewrite H... - assert (H0 : 2 <> 0); - [ discrR | unfold Rdiv; rewrite Rinv_mult_distr; try ring ]... +Proof. + rewrite cos_sin. + replace (PI / 2 + PI / 4) with (- (PI / 4) + PI) by field. + rewrite neg_sin, sin_neg; ring. Qed. Lemma sin_PI3_cos_PI6 : sin (PI / 3) = cos (PI / 6). -Proof with trivial. - replace (PI / 6) with (PI / 2 - PI / 3)... - rewrite cos_shift... - assert (H0 : 6 <> 0); [ discrR | idtac ]... - assert (H1 : 3 <> 0); [ discrR | idtac ]... - assert (H2 : 2 <> 0); [ discrR | idtac ]... - apply Rmult_eq_reg_l with 6... - rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)... - unfold Rdiv; repeat rewrite Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym... - rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r; - repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym... - ring... +Proof. + replace (PI / 6) with (PI / 2 - PI / 3) by field. + now rewrite cos_shift. Qed. Lemma sin_PI6_cos_PI3 : cos (PI / 3) = sin (PI / 6). -Proof with trivial. - replace (PI / 6) with (PI / 2 - PI / 3)... - rewrite sin_shift... - assert (H0 : 6 <> 0); [ discrR | idtac ]... - assert (H1 : 3 <> 0); [ discrR | idtac ]... - assert (H2 : 2 <> 0); [ discrR | idtac ]... - apply Rmult_eq_reg_l with 6... - rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)... - unfold Rdiv; repeat rewrite Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym... - rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r; - repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym... - ring... +Proof. + replace (PI / 6) with (PI / 2 - PI / 3) by field. + now rewrite sin_shift. Qed. Lemma PI6_RGT_0 : 0 < PI / 6. @@ -90,29 +64,20 @@ Proof. Qed. Lemma sin_PI6 : sin (PI / 6) = 1 / 2. -Proof with trivial. - assert (H : 2 <> 0); [ discrR | idtac ]... - apply Rmult_eq_reg_l with (2 * cos (PI / 6))... +Proof. + apply Rmult_eq_reg_l with (2 * cos (PI / 6)). replace (2 * cos (PI / 6) * sin (PI / 6)) with - (2 * sin (PI / 6) * cos (PI / 6))... - rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3)... - rewrite sin_PI3_cos_PI6... - unfold Rdiv; rewrite Rmult_1_l; rewrite Rmult_assoc; - pattern 2 at 2; rewrite (Rmult_comm 2); rewrite Rmult_assoc; - rewrite <- Rinv_l_sym... - rewrite Rmult_1_r... - unfold Rdiv; rewrite Rinv_mult_distr... - rewrite (Rmult_comm (/ 2)); rewrite (Rmult_comm 2); - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r... - discrR... - ring... - apply prod_neq_R0... + (2 * sin (PI / 6) * cos (PI / 6)) by ring. + rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3) by field. + rewrite sin_PI3_cos_PI6. + field. + apply prod_neq_R0. + discrR. cut (0 < cos (PI / 6)); [ intro H1; auto with real | apply cos_gt_0; [ apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0) - | apply PI6_RLT_PI2 ] ]... + | apply PI6_RLT_PI2 ] ]. Qed. Lemma sqrt2_neq_0 : sqrt 2 <> 0. @@ -188,20 +153,13 @@ Proof with trivial. apply Rinv_0_lt_compat; apply Rlt_sqrt2_0... rewrite Rsqr_div... rewrite Rsqr_1; rewrite Rsqr_sqrt... - assert (H : 2 <> 0); [ discrR | idtac ]... unfold Rsqr; pattern (cos (PI / 4)) at 1; rewrite <- sin_cos_PI4; replace (sin (PI / 4) * cos (PI / 4)) with - (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4)))... - rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2)... + (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4))) by field. + rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2) by field. rewrite sin_PI2... - apply Rmult_1_r... - unfold Rdiv; rewrite (Rmult_comm 2); rewrite Rinv_mult_distr... - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r... - unfold Rdiv; rewrite Rmult_1_l; repeat rewrite <- Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite Rmult_1_l... + field. left; prove_sup... apply sqrt2_neq_0... Qed. @@ -219,24 +177,17 @@ Proof. Qed. Lemma cos3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2. -Proof with trivial. - replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))... - rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4... - unfold Rdiv; rewrite Ropp_mult_distr_l_reverse... - unfold Rminus; rewrite Ropp_involutive; pattern PI at 1; - rewrite double_var; unfold Rdiv; rewrite Rmult_plus_distr_r; - repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr; - [ ring | discrR | discrR ]... +Proof. + replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field. + rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4. + unfold Rdiv. + ring. Qed. Lemma sin3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2. -Proof with trivial. - replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))... - rewrite sin_shift; rewrite cos_neg; rewrite cos_PI4... - unfold Rminus; rewrite Ropp_involutive; pattern PI at 1; - rewrite double_var; unfold Rdiv; rewrite Rmult_plus_distr_r; - repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr; - [ ring | discrR | discrR ]... +Proof. + replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field. + now rewrite sin_shift, cos_neg, cos_PI4. Qed. Lemma cos_PI6 : cos (PI / 6) = sqrt 3 / 2. @@ -248,19 +199,11 @@ Proof with trivial. left; apply (Rmult_lt_0_compat (sqrt 3) (/ 2))... apply Rlt_sqrt3_0... apply Rinv_0_lt_compat; prove_sup0... - assert (H : 2 <> 0); [ discrR | idtac ]... - assert (H1 : 4 <> 0); [ apply prod_neq_R0 | idtac ]... rewrite Rsqr_div... rewrite cos2; unfold Rsqr; rewrite sin_PI6; rewrite sqrt_def... - unfold Rdiv; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4... - rewrite Rmult_minus_distr_l; rewrite (Rmult_comm 3); - repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym... - rewrite Rmult_1_l; rewrite Rmult_1_r... - rewrite <- (Rmult_comm (/ 2)); repeat rewrite <- Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite Rmult_1_l; rewrite <- Rinv_r_sym... - ring... - left; prove_sup0... + field. + left ; prove_sup0. + discrR. Qed. Lemma tan_PI6 : tan (PI / 6) = 1 / sqrt 3. @@ -306,56 +249,32 @@ Proof. Qed. Lemma cos_2PI3 : cos (2 * (PI / 3)) = -1 / 2. -Proof with trivial. - assert (H : 2 <> 0); [ discrR | idtac ]... - assert (H0 : 4 <> 0); [ apply prod_neq_R0 | idtac ]... - rewrite double; rewrite cos_plus; rewrite sin_PI3; rewrite cos_PI3; - unfold Rdiv; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4... - rewrite Rmult_minus_distr_l; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2)... - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite <- Rinv_r_sym... - pattern 2 at 4; rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; - rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite Ropp_mult_distr_r_reverse; rewrite Rmult_1_r... - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite (Rmult_comm 2); rewrite (Rmult_comm (/ 2))... - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite sqrt_def... - ring... - left; prove_sup... +Proof. + rewrite cos_2a, sin_PI3, cos_PI3. + replace (sqrt 3 / 2 * (sqrt 3 / 2)) with ((sqrt 3 * sqrt 3) / 4) by field. + rewrite sqrt_sqrt. + field. + left ; prove_sup0. Qed. Lemma tan_2PI3 : tan (2 * (PI / 3)) = - sqrt 3. -Proof with trivial. - assert (H : 2 <> 0); [ discrR | idtac ]... - unfold tan; rewrite sin_2PI3; rewrite cos_2PI3; unfold Rdiv; - rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l; - rewrite <- Ropp_inv_permute... - rewrite Rinv_involutive... - rewrite Rmult_assoc; rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_l_sym... - ring... - apply Rinv_neq_0_compat... +Proof. + unfold tan; rewrite sin_2PI3, cos_2PI3. + field. Qed. Lemma cos_5PI4 : cos (5 * (PI / 4)) = -1 / sqrt 2. -Proof with trivial. - replace (5 * (PI / 4)) with (PI / 4 + PI)... - rewrite neg_cos; rewrite cos_PI4; unfold Rdiv; - rewrite Ropp_mult_distr_l_reverse... - pattern PI at 2; rewrite double_var; pattern PI at 2 3; - rewrite double_var; assert (H : 2 <> 0); - [ discrR | unfold Rdiv; repeat rewrite Rinv_mult_distr; try ring ]... +Proof. + replace (5 * (PI / 4)) with (PI / 4 + PI) by field. + rewrite neg_cos; rewrite cos_PI4; unfold Rdiv. + ring. Qed. Lemma sin_5PI4 : sin (5 * (PI / 4)) = -1 / sqrt 2. -Proof with trivial. - replace (5 * (PI / 4)) with (PI / 4 + PI)... - rewrite neg_sin; rewrite sin_PI4; unfold Rdiv; - rewrite Ropp_mult_distr_l_reverse... - pattern PI at 2; rewrite double_var; pattern PI at 2 3; - rewrite double_var; assert (H : 2 <> 0); - [ discrR | unfold Rdiv; repeat rewrite Rinv_mult_distr; try ring ]... +Proof. + replace (5 * (PI / 4)) with (PI / 4 + PI) by field. + rewrite neg_sin; rewrite sin_PI4; unfold Rdiv. + ring. Qed. Lemma sin_cos5PI4 : cos (5 * (PI / 4)) = sin (5 * (PI / 4)). diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index eed612d94..d9c18d358 100644 --- a/theories/Reals/Rtrigo_reg.v +++ b/theories/Reals/Rtrigo_reg.v @@ -251,6 +251,7 @@ Proof. exists delta; intros. rewrite Rplus_0_l; replace (cos h - cos 0) with (-2 * Rsqr (sin (h / 2))). unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. + change (-2) with (-(2)). unfold Rdiv; do 2 rewrite Ropp_mult_distr_l_reverse. rewrite Rabs_Ropp. replace (2 * Rsqr (sin (h * / 2)) * / h) with @@ -266,7 +267,7 @@ Proof. apply Rabs_pos. assert (H9 := SIN_bound (h / 2)). unfold Rabs; case (Rcase_abs (sin (h / 2))); intro. - pattern 1 at 3; rewrite <- (Ropp_involutive 1). + rewrite <- (Ropp_involutive 1). apply Ropp_le_contravar. elim H9; intros; assumption. elim H9; intros; assumption. @@ -395,15 +396,8 @@ Proof. apply Rlt_le_trans with alp. apply H7. unfold alp; apply Rmin_l. - rewrite sin_plus; unfold Rminus, Rdiv; - repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l; - repeat rewrite Rmult_assoc; repeat rewrite Rplus_assoc; - apply Rplus_eq_compat_l. - rewrite (Rplus_comm (sin x * (-1 * / h))); repeat rewrite Rplus_assoc; - apply Rplus_eq_compat_l. - rewrite Ropp_mult_distr_r_reverse; rewrite Ropp_mult_distr_l_reverse; - rewrite Rmult_1_r; rewrite Rmult_1_l; rewrite Ropp_mult_distr_r_reverse; - rewrite <- Ropp_mult_distr_l_reverse; apply Rplus_comm. + rewrite sin_plus. + now field. unfold alp; unfold Rmin; case (Rle_dec alp1 alp2); intro. apply (cond_pos alp1). apply (cond_pos alp2). diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v index d43baee8c..12d5cbbf0 100644 --- a/theories/Reals/Sqrt_reg.v +++ b/theories/Reals/Sqrt_reg.v @@ -21,6 +21,7 @@ Proof. destruct (total_order_T h 0) as [[Hlt|Heq]|Hgt]. repeat rewrite Rabs_left. unfold Rminus; do 2 rewrite <- (Rplus_comm (-1)). + change (-1) with (-(1)). do 2 rewrite Ropp_plus_distr; rewrite Ropp_involutive; apply Rplus_le_compat_l. apply Ropp_le_contravar; apply sqrt_le_1. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 5aa397f8a..1e3ab6687 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1367,7 +1367,7 @@ Lemma inj_testbit a n : 0<=n -> Z.testbit (Z.pos a) n = N.testbit (N.pos a) (Z.to_N n). Proof. apply Z.testbit_Zpos. Qed. -(** Some results concerning Z.neg *) +(** Some results concerning Z.neg and Z.pos *) Lemma inj_neg p q : Z.neg p = Z.neg q -> p = q. Proof. now injection 1. Qed. @@ -1375,18 +1375,54 @@ Proof. now injection 1. Qed. Lemma inj_neg_iff p q : Z.neg p = Z.neg q <-> p = q. Proof. split. apply inj_neg. intros; now f_equal. Qed. +Lemma inj_pos p q : Z.pos p = Z.pos q -> p = q. +Proof. now injection 1. Qed. + +Lemma inj_pos_iff p q : Z.pos p = Z.pos q <-> p = q. +Proof. split. apply inj_pos. intros; now f_equal. Qed. + Lemma neg_is_neg p : Z.neg p < 0. Proof. reflexivity. Qed. Lemma neg_is_nonpos p : Z.neg p <= 0. Proof. easy. Qed. +Lemma pos_is_pos p : 0 < Z.pos p. +Proof. reflexivity. Qed. + +Lemma pos_is_nonneg p : 0 <= Z.pos p. +Proof. easy. Qed. + +Lemma neg_le_pos p q : Zneg p <= Zpos q. +Proof. easy. Qed. + +Lemma neg_lt_pos p q : Zneg p < Zpos q. +Proof. easy. Qed. + +Lemma neg_le_neg p q : (q <= p)%positive -> Zneg p <= Zneg q. +Proof. intros; unfold Z.le; simpl. now rewrite <- Pos.compare_antisym. Qed. + +Lemma neg_lt_neg p q : (q < p)%positive -> Zneg p < Zneg q. +Proof. intros; unfold Z.lt; simpl. now rewrite <- Pos.compare_antisym. Qed. + +Lemma pos_le_pos p q : (p <= q)%positive -> Zpos p <= Zpos q. +Proof. easy. Qed. + +Lemma pos_lt_pos p q : (p < q)%positive -> Zpos p < Zpos q. +Proof. easy. Qed. + Lemma neg_xO p : Z.neg p~0 = 2 * Z.neg p. Proof. reflexivity. Qed. Lemma neg_xI p : Z.neg p~1 = 2 * Z.neg p - 1. Proof. reflexivity. Qed. +Lemma pos_xO p : Z.pos p~0 = 2 * Z.pos p. +Proof. reflexivity. Qed. + +Lemma pos_xI p : Z.pos p~1 = 2 * Z.pos p + 1. +Proof. reflexivity. Qed. + Lemma opp_neg p : - Z.neg p = Z.pos p. Proof. reflexivity. Qed. @@ -1402,6 +1438,9 @@ Proof. reflexivity. Qed. Lemma add_neg_pos p q : Z.neg p + Z.pos q = Z.pos_sub q p. Proof. reflexivity. Qed. +Lemma add_pos_pos p q : Z.pos p + Z.pos q = Z.pos (p+q). +Proof. reflexivity. Qed. + Lemma divide_pos_neg_r n p : (n|Z.pos p) <-> (n|Z.neg p). Proof. apply Z.divide_Zpos_Zneg_r. Qed. @@ -1412,6 +1451,10 @@ Lemma testbit_neg a n : 0<=n -> Z.testbit (Z.neg a) n = negb (N.testbit (Pos.pred_N a) (Z.to_N n)). Proof. apply Z.testbit_Zneg. Qed. +Lemma testbit_pos a n : 0<=n -> + Z.testbit (Z.pos a) n = N.testbit (N.pos a) (Z.to_N n). +Proof. apply Z.testbit_Zpos. Qed. + End Pos2Z. Module Z2Pos. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 73dee0cf2..18915216a 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -339,7 +339,7 @@ Notation Zle_0_1 := Z.le_0_1 (compat "8.3"). Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q. Proof. - easy. + exact Pos2Z.neg_le_pos. Qed. Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0. @@ -350,12 +350,12 @@ Qed. (* weaker but useful (in [Z.pow] for instance) *) Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p. Proof. - easy. + exact Pos2Z.pos_is_nonneg. Qed. Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0. Proof. - easy. + exact Pos2Z.neg_is_neg. Qed. Lemma Zle_0_nat : forall n:nat, 0 <= Z.of_nat n. diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 294575e0a..22b1408c0 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -50,9 +50,9 @@ let section s = let lib_dirs = ["kernel"; "lib"; "library"; "parsing"; "pretyping"; "interp"; "printing"; "intf"; - "proofs"; "tactics"; "tools"; "ltacprof"; - "toplevel"; "stm"; "grammar"; "config"; - "ltac"; "engine"] + "proofs"; "tactics"; "tools"; + "vernac"; "stm"; "toplevel"; "grammar"; "config"; + "engine"] let usage () = @@ -125,12 +125,9 @@ let physical_dir_of_logical_dir ldir = let le = String.length ldir - 1 in let pdir = if le >= 0 && ldir.[le] = '.' then String.sub ldir 0 (le - 1) - else String.copy ldir + else ldir in - for i = 0 to le - 1 do - if pdir.[i] = '.' then pdir.[i] <- '/'; - done; - pdir + String.map (fun c -> if c = '.' then '/' else c) pdir let standard opt = print "byte:\n"; @@ -524,10 +521,10 @@ 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?=$(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 "CAMLC?=$(OCAMLFIND) ocamlc -c -rectypes -thread -safe-string\n"; + print "CAMLOPTC?=$(OCAMLFIND) opt -c -rectypes -thread -safe-string\n"; + print "CAMLLINK?=$(OCAMLFIND) ocamlc -rectypes -thread -safe-string\n"; + print "CAMLOPTLINK?=$(OCAMLFIND) opt -rectypes -thread -safe-string\n"; print "CAMLDEP?=$(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack\n"; print "CAMLLIB?=$(shell $(OCAMLFIND) printconf stdlib)\n"; print "GRAMMARS?=grammar.cma\n"; @@ -768,9 +765,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$(OCAMLFIND) ocamldoc -html -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; + print "\t$(OCAMLFIND) ocamldoc -html -safe-string -rectypes -d $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; print "all-mli.tex: $(MLIFILES:.mli=.cmi)\n"; - print "\t$(OCAMLFIND) ocamldoc -latex -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; + print "\t$(OCAMLFIND) ocamldoc -latex -safe-string -rectypes -o $@ -m A $(ZDEBUG) $(ZFLAGS) $(^:.cmi=.mli)\n\n"; end; if !some_vfile then begin @@ -886,7 +883,7 @@ let check_overlapping_include (_,inc_i,inc_r) = *) let merlin targets (ml_inc,_,_) = print ".merlin:\n"; - print "\t@echo 'FLG -rectypes' > .merlin\n" ; + print "\t@echo 'FLG -rectypes -safe-string' > .merlin\n" ; List.iter (fun c -> printf "\t@echo \"B $(COQLIB)%s\" >> .merlin\n" c) lib_dirs ; diff --git a/tools/coqdep.ml b/tools/coqdep.ml index a7c32e1d6..a9f1b7376 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -526,5 +526,5 @@ let _ = try coqdep () with CErrors.UserError(s,p) -> - let pp = if s <> "_" then Pp.(str s ++ str ": " ++ p) else p in + let pp = (match s with | None -> p | Some s -> Pp.(str s ++ str ": " ++ p)) in Feedback.msg_error pp diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml index f817ed5a2..3d92c9356 100644 --- a/tools/coqdoc/alpha.ml +++ b/tools/coqdoc/alpha.ml @@ -26,12 +26,7 @@ let norm_char c = if !latin1 then norm_char_latin1 c else Char.uppercase c -let norm_string s = - let u = String.copy s in - for i = 0 to String.length s - 1 do - u.[i] <- norm_char s.[i] - done; - u +let norm_string = String.map (fun s -> norm_char s) let compare_char c1 c2 = match norm_char c1, norm_char c2 with | ('A'..'Z' as c1), ('A'..'Z' as c2) -> compare c1 c2 diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 9be791a8d..34108eff4 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -197,7 +197,7 @@ let prepare_entry s = function let h = try String.index_from s 0 ':' with _ -> err () in let i = try String.index_from s (h+1) ':' with _ -> err () in let sc = String.sub s (h+1) (i-h-1) in - let ntn = String.make (String.length s - i) ' ' in + let ntn = Bytes.make (String.length s - i) ' ' in let k = ref 0 in let j = ref (i+1) in let quoted = ref false in @@ -205,22 +205,22 @@ let prepare_entry s = function while !j <= l do if not !quoted then begin (match s.[!j] with - | '_' -> ntn.[!k] <- ' '; incr k - | 'x' -> ntn.[!k] <- '_'; incr k + | '_' -> Bytes.set ntn !k ' '; incr k + | 'x' -> Bytes.set ntn !k '_'; incr k | '\'' -> quoted := true | _ -> assert false) end else if s.[!j] = '\'' then if (!j = l || s.[!j+1] = '_') then quoted := false - else (incr j; ntn.[!k] <- s.[!j]; incr k) + else (incr j; Bytes.set ntn !k s.[!j]; incr k) else begin - ntn.[!k] <- s.[!j]; + Bytes.set ntn !k s.[!j]; incr k end; incr j done; - let ntn = String.sub ntn 0 !k in + let ntn = Bytes.sub_string ntn 0 !k in if sc = "" then ntn else ntn ^ " (" ^ sc ^ ")" | _ -> s diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml index eaf938e8c..645b3665e 100644 --- a/tools/coqmktop.ml +++ b/tools/coqmktop.ml @@ -75,6 +75,7 @@ let std_includes basedir = let rebase d = match basedir with None -> d | Some base -> base / d in ["-I"; rebase "."; "-I"; rebase "lib"; + "-I"; rebase "vernac"; (* For Mltop *) "-I"; rebase "toplevel"; "-I"; rebase "kernel/byterun"; "-I"; Envars.camlp4lib () ] @ diff --git a/tools/coqworkmgr.ml b/tools/coqworkmgr.ml index d7bdf907a..b8e69d6c6 100644 --- a/tools/coqworkmgr.ml +++ b/tools/coqworkmgr.ml @@ -72,10 +72,13 @@ let really_read_fd fd s off len = let raw_input_line fd = try let b = Buffer.create 80 in - let s = String.make 1 '\000' in - while s <> "\n" do + let s = Bytes.make 1 '\000' in + let endl = Bytes.of_string "\n" in + let endr = Bytes.of_string "\r" in + while Bytes.compare s endl <> 0 do really_read_fd fd s 0 1; - if s <> "\n" && s <> "\r" then Buffer.add_string b s; + if Bytes.compare s endl <> 0 && Bytes.compare s endr <> 0 + then Buffer.add_bytes b s; done; Buffer.contents b with Unix.Unix_error _ -> raise End_of_file diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index 8fcca535d..932097607 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -12,24 +12,15 @@ let error s = prerr_endline ("fake_id: error: "^s); exit 1 +let pperr_endline pp = Format.eprintf "@[%a@]\n%!" Pp.pp_with pp + type coqtop = { xml_printer : Xml_printer.t; xml_parser : Xml_parser.t; } -let print_xml chan xml = - let rec print = function - | Xml_datatype.PCData s -> output_string chan s - | Xml_datatype.Element (_, _, children) -> List.iter print children - in - print xml - -let error_xml s = - Printf.eprintf "fake_id: error: %a\n%!" print_xml s; - exit 1 - -let logger level content = - Printf.eprintf "%a\n%! " print_xml (Richpp.repr content) +let print_error msg = + Format.eprintf "fake_id: error: @[%a@]\n%!" Pp.pp_with msg let base_eval_call ?(print=true) ?(fail=true) call coqtop = if print then prerr_endline (Xmlprotocol.pr_call call); @@ -37,20 +28,15 @@ let base_eval_call ?(print=true) ?(fail=true) call coqtop = Xml_printer.print coqtop.xml_printer xml_query; let rec loop () = let xml = Xml_parser.parse coqtop.xml_parser in - match Xmlprotocol.is_message xml with - | Some (level, _loc, content) -> - logger level content; + if Xmlprotocol.is_feedback xml then loop () - | None -> - if Xmlprotocol.is_feedback xml then - loop () - else Xmlprotocol.to_answer call xml + else Xmlprotocol.to_answer call xml in let res = loop () in if print then prerr_endline (Xmlprotocol.pr_full_value call res); match res with - | Interface.Fail (_,_,s) when fail -> error_xml (Richpp.repr s) - | Interface.Fail (_,_,s) as x -> Printf.eprintf "%a\n%!" print_xml (Richpp.repr s); x + | Interface.Fail (_,_,s) when fail -> print_error s; exit 1 + | Interface.Fail (_,_,s) as x -> print_error s; x | x -> x let eval_call c q = ignore(base_eval_call c q) @@ -186,7 +172,7 @@ let print_document () = Str.global_replace (Str.regexp "^[\n ]*") "" (if String.length s > 20 then String.sub s 0 17 ^ "..." else s) in - prerr_endline (Pp.string_of_ppcmds + pperr_endline ( (Document.print doc (fun b state_id { name; text } -> Pp.str (Printf.sprintf "%s[%10s, %3s] %s" @@ -199,7 +185,7 @@ let print_document () = module GUILogic = struct let after_add = function - | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) + | Interface.Fail (_,_,s) -> print_error s; exit 1 | Interface.Good (id, (Util.Inl (), _)) -> Document.assign_tip_id doc id | Interface.Good (id, (Util.Inr tip, _)) -> @@ -211,7 +197,7 @@ module GUILogic = struct let at id id' _ = Stateid.equal id' id let after_edit_at (id,need_unfocus) = function - | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) + | Interface.Fail (_,_,s) -> print_error s; exit 1 | Interface.Good (Util.Inl ()) -> if need_unfocus then Document.unfocus doc; ignore(Document.cut_at doc id); @@ -310,11 +296,12 @@ let main = Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> prerr_endline "Broken Pipe (coqtop died ?)"; exit 1)); + let def_args = ["--xml_format=Ppcmds"; "-ideslave"] in let coqtop_name, coqtop_args, input_file = match Sys.argv with - | [| _; f |] -> "coqtop",[|"-ideslave"|], f + | [| _; f |] -> "coqtop", Array.of_list def_args, f | [| _; f; ct |] -> let ct = Str.split (Str.regexp " ") ct in - List.hd ct, Array.of_list ("-ideslave" :: List.tl ct), f + List.hd ct, Array.of_list (def_args @ List.tl ct), f | _ -> usage () in let inc = if input_file = "-" then stdin else open_in input_file in let coq = @@ -334,7 +321,7 @@ let main = let finish () = match base_eval_call (Xmlprotocol.status true) coq with | Interface.Good _ -> exit 0 - | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) in + | Interface.Fail (_,_,s) -> print_error s; exit 1 in (* The main loop *) init (); while true do diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index acbf909cc..98f60924b 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -130,13 +130,14 @@ let init_ocaml_path () = [ "grammar" ]; [ "ide" ]; [ "ltac" ]; ] let get_compat_version = function - | "8.6" -> Flags.Current + | "8.7" -> Flags.Current + | "8.6" -> Flags.V8_6 | "8.5" -> Flags.V8_5 | "8.4" -> Flags.V8_4 | "8.3" -> Flags.V8_3 | "8.2" -> Flags.V8_2 | ("8.1" | "8.0") as s -> - CErrors.errorlabstrm "get_compat_version" + CErrors.user_err ~hdr:"get_compat_version" (str "Compatibility with version " ++ str s ++ str " not supported.") - | s -> CErrors.errorlabstrm "get_compat_version" + | s -> CErrors.user_err ~hdr:"get_compat_version" (str "Unknown compatibility version \"" ++ str s ++ str "\".") diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index e9771cfa4..0cc6ca317 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -13,14 +13,15 @@ open Flags open Vernac open Pcoq -let top_stderr x = msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft x +let top_stderr x = + Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with x (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) type input_buffer = { mutable prompt : unit -> string; - mutable str : string; (* buffer of already read characters *) + mutable str : Bytes.t; (* buffer of already read characters *) mutable len : int; (* number of chars in the buffer *) mutable bols : int list; (* offsets in str of beginning of lines *) mutable tokens : Gram.coq_parsable; (* stream of tokens *) @@ -28,9 +29,9 @@ type input_buffer = { (* Double the size of the buffer. *) -let resize_buffer ibuf = - let nstr = String.create (2 * String.length ibuf.str + 1) in - String.blit ibuf.str 0 nstr 0 (String.length ibuf.str); +let resize_buffer ibuf = let open Bytes in + let nstr = create (2 * length ibuf.str + 1) in + blit ibuf.str 0 nstr 0 (length ibuf.str); ibuf.str <- nstr (* Delete all irrelevant lines of the input buffer. Keep the last line @@ -40,7 +41,7 @@ let resynch_buffer ibuf = match ibuf.bols with | ll::_ -> let new_len = ibuf.len - ll in - String.blit ibuf.str ll ibuf.str 0 new_len; + Bytes.blit ibuf.str ll ibuf.str 0 new_len; ibuf.len <- new_len; ibuf.bols <- []; ibuf.start <- ibuf.start + ll @@ -65,8 +66,8 @@ let prompt_char ic ibuf count = try let c = input_char ic in if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols; - if ibuf.len == String.length ibuf.str then resize_buffer ibuf; - ibuf.str.[ibuf.len] <- c; + if ibuf.len == Bytes.length ibuf.str then resize_buffer ibuf; + Bytes.set ibuf.str ibuf.len c; ibuf.len <- ibuf.len + 1; Some c with End_of_file -> @@ -75,7 +76,7 @@ let prompt_char ic ibuf count = (* Reinitialize the char stream (after a Drop) *) let reset_input_buffer ic ibuf = - ibuf.str <- ""; + ibuf.str <- Bytes.empty; ibuf.len <- 0; ibuf.bols <- []; ibuf.tokens <- Gram.parsable (Stream.from (prompt_char ic ibuf)); @@ -109,19 +110,19 @@ let dotted_location (b,e) = else (String.make (e-b-1) '.', " ") -let blanch_utf8_string s bp ep = - let s' = String.make (ep-bp) ' ' in +let blanch_utf8_string s bp ep = let open Bytes in + let s' = make (ep-bp) ' ' in let j = ref 0 in for i = bp to ep - 1 do - let n = Char.code s.[i] in + let n = Char.code (get s i) in (* Heuristic: assume utf-8 chars are printed using a single fixed-size char and therefore contract all utf-8 code into one space; in any case, preserve tabulation so that its effective interpretation in terms of spacing is preserved *) - if s.[i] == '\t' then s'.[!j] <- '\t'; + if get s i == '\t' then set s' !j '\t'; if n < 0x80 || 0xC0 <= n then incr j done; - String.sub s' 0 !j + Bytes.sub_string s' 0 !j let print_highlight_location ib loc = let (bp,ep) = Loc.unloc loc in @@ -132,17 +133,17 @@ let print_highlight_location ib loc = | ([],(bl,el)) -> let shift = blanch_utf8_string ib.str bl bp in let span = String.length (blanch_utf8_string ib.str bp ep) in - (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++ + (str"> " ++ str(Bytes.sub_string ib.str bl (el-bl-1)) ++ fnl () ++ str"> " ++ str(shift) ++ str(String.make span '^')) | ((b1,e1)::ml,(bn,en)) -> let (d1,s1) = dotted_location (b1,bp) in let (dn,sn) = dotted_location (ep,en) in let l1 = (str"> " ++ str d1 ++ str s1 ++ - str(String.sub ib.str bp (e1-bp))) in + str(Bytes.sub_string ib.str bp (e1-bp))) in let li = prlist (fun (bi,ei) -> - (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in - let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++ + (str"> " ++ str(Bytes.sub_string ib.str bi (ei-bi)))) ml in + let ln = (str"> " ++ str(Bytes.sub_string ib.str bn (ep-bn)) ++ str sn ++ str dn) in (l1 ++ li ++ ln) in @@ -220,7 +221,7 @@ let top_buffer = ^ emacs_prompt_endstring() in { prompt = pr; - str = ""; + str = Bytes.empty; len = 0; bols = []; tokens = Gram.parsable (Stream.of_list []); @@ -251,7 +252,8 @@ let print_toplevel_error (e, info) = else mt () else print_location_in_file loc in - locmsg ++ CErrors.iprint (e, info) + let hdr msg = hov 0 (Topfmt.err_hdr ++ msg) in + locmsg ++ hdr (CErrors.iprint (e, info)) (* Read the input stream until a dot is encountered *) let parse_to_dot = @@ -283,6 +285,33 @@ let read_sentence input = discard_to_dot (); iraise reraise +(** Coqloop Console feedback handler *) +let coqloop_feed (fb : Feedback.feedback) = let open Feedback in + match fb.contents with + | Processed -> () + | Incomplete -> () + | Complete -> () + | ProcessingIn _ -> () + | InProgress _ -> () + | WorkerStatus (_,_) -> () + | AddedAxiom -> () + | GlobRef (_,_,_,_,_) -> () + | GlobDef (_,_,_,_) -> () + | FileDependency (_,_) -> () + | FileLoaded (_,_) -> () + | Custom (_,_,_) -> () + | Message (Error,loc,msg) -> + (* We ignore errors here as we (still) have a different error + printer for the toplevel. It is hard to solve due the many + error paths presents, and the different compromise of feedback + error forwaring in the stm depending on the mode *) + () + | Message (lvl,loc,msg) -> + if !Flags.print_emacs then + Topfmt.emacs_logger ?loc lvl msg + else + Topfmt.std_logger ?loc lvl msg + (** [do_vernac] reads and executes a toplevel phrase, and print error messages when an exception is raised, except for the following: - Drop: kill the Coq toplevel, going down to the Caml toplevel if it exists. @@ -305,12 +334,13 @@ let do_vernac () = top_stderr (fnl ()); raise CErrors.Quit | CErrors.Drop -> (* Last chance *) if Mltop.is_ocaml_top() then raise CErrors.Drop - else Feedback.msg_error (str"There is no ML toplevel.") + else top_stderr (str "There is no ML toplevel.") | any -> + (** Main error printer, note that this didn't it the "emacs" + legacy path. *) let any = CErrors.push any in let msg = print_toplevel_error any ++ fnl () in - pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft msg; - Format.pp_print_flush !Pp_control.std_ft () + top_stderr msg (** Main coq loop : read vernacular expressions until Drop is entered. Ctrl-C is handled internally as Sys.Break instead of aborting Coq. @@ -318,22 +348,13 @@ let do_vernac () = exit the loop are Drop and Quit. Any other exception there indicates an issue with [print_toplevel_error] above. *) -(* -let feed_emacs = function - | { Interface.id = Interface.State id; - Interface.content = Interface.GlobRef (_,a,_,c,_) } -> - prerr_endline ("<info>" ^"<id>"^Stateid.to_string id ^"</id>" - ^a^" "^c^ "</info>") - | _ -> () -*) - (* Flush in a compatible order with 8.5 *) (* This mimics the semantics of the old Pp.flush_all *) let loop_flush_all () = Pervasives.flush stderr; Pervasives.flush stdout; - Format.pp_print_flush !Pp_control.std_ft (); - Format.pp_print_flush !Pp_control.err_ft () + Format.pp_print_flush !Topfmt.std_ft (); + Format.pp_print_flush !Topfmt.err_ft () let rec loop () = Sys.catch_break true; @@ -346,9 +367,9 @@ let rec loop () = | CErrors.Drop -> () | CErrors.Quit -> exit 0 | any -> - Feedback.msg_error (str"Anomaly: main loop exited with exception: " ++ - str (Printexc.to_string any) ++ - fnl() ++ - str"Please report" ++ - strbrk" at " ++ str Coq_config.wwwbugtracker ++ str "."); + top_stderr (str"Anomaly: main loop exited with exception: " ++ + str (Printexc.to_string any) ++ + fnl() ++ + str"Please report" ++ + strbrk" at " ++ str Coq_config.wwwbugtracker ++ str "."); loop () diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index e40353e0f..eb61084e0 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -15,7 +15,7 @@ open Pp type input_buffer = { mutable prompt : unit -> string; - mutable str : string; (** buffer of already read characters *) + mutable str : Bytes.t; (** buffer of already read characters *) mutable len : int; (** number of chars in the buffer *) mutable bols : int list; (** offsets in str of begining of lines *) mutable tokens : Pcoq.Gram.coq_parsable; (** stream of tokens *) @@ -32,6 +32,8 @@ val set_prompt : (unit -> string) -> unit val print_toplevel_error : Exninfo.iexn -> std_ppcmds +val coqloop_feed : Feedback.feedback -> unit + (** Parse and execute one vernac command. *) val do_vernac : unit -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index d9f8ed881..0cd5498fe 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -61,15 +61,15 @@ let init_color () = match colors with | None -> (** Default colors *) - Feedback.init_color_output () + Topfmt.init_color_output () | Some "" -> (** No color output *) () | Some s -> (** Overwrite all colors *) - Ppstyle.clear_styles (); - Ppstyle.parse_config s; - Feedback.init_color_output () + Topfmt.clear_styles (); + Topfmt.parse_color_config s; + Topfmt.init_color_output () end let toploop_init = ref begin fun x -> @@ -78,15 +78,27 @@ let toploop_init = ref begin fun x -> x end -let toploop_run = ref (fun () -> +(* Feedback received in the init stage, this is different as the STM + will not be generally be initialized, thus stateid, etc... may be + bogus. For now we just print to the console too *) +let coqtop_init_feed = Coqloop.coqloop_feed + +(* Default toplevel loop *) +let console_toploop_run () = + (* We initialize the console only if we run the toploop_run *) + let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in if Dumpglob.dump () then begin if_verbose warning "Dumpglob cannot be used in interactive mode."; Dumpglob.noglob () end; Coqloop.loop(); + (* We remove the feeder but it could be ok not to do so *) + Feedback.del_feeder tl_feed; (* Initialise and launch the Ocaml toplevel *) Coqinit.init_ocaml_path(); - Mltop.ocaml_toploop()) + Mltop.ocaml_toploop() + +let toploop_run = ref console_toploop_run let output_context = ref false @@ -122,11 +134,10 @@ let engage () = let set_batch_mode () = batch_mode := true let toplevel_default_name = DirPath.make [Id.of_string "Top"] -let toplevel_name = ref (Some toplevel_default_name) +let toplevel_name = ref toplevel_default_name let set_toplevel_name dir = if DirPath.is_empty dir then error "Need a non empty toplevel module name"; - toplevel_name := Some dir -let unset_toplevel_name () = toplevel_name := None + toplevel_name := dir let remove_top_ml () = Mltop.remove () @@ -228,7 +239,6 @@ let compile_files () = if !compile_list == [] then () else let init_state = States.freeze ~marshallable:`No in - Feedback.(add_feeder debug_feeder); List.iter (fun vf -> States.unfreeze init_state; compile_file vf) @@ -240,7 +250,6 @@ let set_emacs () = if not (Option.is_empty !toploop) then error "Flag -emacs is incompatible with a custom toplevel loop"; Flags.print_emacs := true; - Feedback.(set_logger emacs_logger); Vernacentries.qed_display_script := false; color := `OFF @@ -298,24 +307,16 @@ let usage () = let print_style_tags () = let () = init_color () in - let tags = Ppstyle.dump () in + let tags = Topfmt.dump_tags () in let iter (t, st) = - let st = match st with Some st -> st | None -> Terminal.make () in - let opt = - Terminal.eval st ^ - String.concat "." (Ppstyle.repr t) ^ - Terminal.reset ^ "\n" - in + let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in print_string opt in - let make (t, st) = match st with - | None -> None - | Some st -> + let make (t, st) = let tags = List.map string_of_int (Terminal.repr st) in - let t = String.concat "." (Ppstyle.repr t) in - Some (t ^ "=" ^ String.concat ";" tags) + (t ^ "=" ^ String.concat ";" tags) in - let repr = List.map_filter make tags in + let repr = List.map make tags in let () = Printf.printf "COQ_COLORS=\"%s\"\n" (String.concat ":" repr) in let () = List.iter iter tags in flush_all () @@ -431,6 +432,13 @@ let get_native_name s = Nativelib.output_dir; Library.native_name_from_filename s] with _ -> "" +(** Prints info which is either an error or an anomaly and then exits + with the appropriate error code *) +let fatal_error info anomaly = + let msg = info ++ fnl () in + Format.fprintf !Topfmt.err_ft "@[%a@]%!" pp_with msg; + exit (if anomaly then 129 else 1) + let parse_args arglist = let args = ref arglist in let extras = ref [] in @@ -556,7 +564,6 @@ let parse_args arglist = if Coq_config.no_native_compiler then warning "Native compilation was disabled at configure time." else native_compiler := true - |"-notop" -> unset_toplevel_name () |"-output-context" -> output_context := true |"-profile-ltac" -> Flags.profile_ltac := true |"-q" -> no_load_rc () @@ -595,16 +602,15 @@ let parse_args arglist = parse () with | UserError(_, s) as e -> - if is_empty s then exit 1 + if ismt s then exit 1 else fatal_error (CErrors.print e) false | any -> fatal_error (CErrors.print any) (CErrors.is_anomaly any) let init_toplevel arglist = init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) + let init_feeder = Feedback.add_feeder coqtop_init_feed in Lib.init(); - (* Default Proofb Mode starts with an alternative default. *) - Goptions.set_string_option_value ["Default";"Proof";"Mode"] "Classic"; begin try let extras = parse_args arglist in @@ -630,7 +636,7 @@ let init_toplevel arglist = engage (); if (not !batch_mode || List.is_empty !compile_list) && Global.env_is_initial () - then Option.iter Declaremods.start_library !toplevel_name; + then Declaremods.start_library !toplevel_name; init_library_roots (); load_vernac_obj (); require (); @@ -658,7 +664,8 @@ let init_toplevel arglist = Feedback.msg_notice (with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); Profile.print_profile (); exit 0 - end + end; + Feedback.del_feeder init_feeder let start () = let () = init_toplevel (List.tl (Array.to_list Sys.argv)) in diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index d68922363..10bf48647 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -1,19 +1,3 @@ -Himsg -ExplainErr -Class -Locality -Metasyntax -Auto_ind_decl -Search -Indschemes -Obligations -Command -Classes -Record -Assumptions -Vernacinterp -Mltop -Vernacentries Vernac Usage Coqloop diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 38ceacf5e..66f782ffb 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -30,7 +30,6 @@ let print_usage_channel co command = \n -R dir coqdir recursively map physical dir to logical coqdir\ \n -Q dir coqdir map physical dir to logical coqdir\ \n -top coqdir set the toplevel name to be coqdir instead of Top\ -\n -notop set the toplevel name to be the empty logical path\ \n -exclude-dir f exclude subdirectories named f for option -R\ \n\ \n -noinit start without loading the Init library\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index bfdae85d5..06908abb6 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -18,7 +18,7 @@ open Vernacexpr Use the module Coqtoplevel, which catches these exceptions (the exceptions are explained only at the toplevel). *) -let user_error loc s = CErrors.user_err_loc (loc,"_",str s) +let user_error loc s = CErrors.user_err ~loc (str s) (* Navigation commands are allowed in a coqtop session but not in a .v file *) @@ -105,10 +105,10 @@ let verbose_phrase verbch loc = match verbch with | Some ch -> let len = snd loc - fst loc in - let s = String.create len in + let s = Bytes.create len in seek_in ch (fst loc); really_input ch s 0 len; - Feedback.msg_notice (str s) + Feedback.msg_notice (str (Bytes.to_string s)) | None -> () exception End_of_input @@ -126,7 +126,7 @@ let chan_beautify = ref stdout let beautify_suffix = ".beautified" let set_formatter_translator ch = - let out s b e = output ch s b e in + let out s b e = output_substring ch s b e in Format.set_formatter_output_functions out (fun () -> flush ch); Format.set_max_boxes max_int @@ -143,7 +143,8 @@ let pr_new_syntax_in_context loc chan_beautify ocom = | None -> mt() in let after = comment (CLexer.extract_comments (snd loc)) in if !beautify_file then - Pp.msg_with !Pp_control.std_ft (hov 0 (before ++ com ++ after)) + (Pp.pp_with !Topfmt.std_ft (hov 0 (before ++ com ++ after)); + Format.pp_print_flush !Topfmt.std_ft ()) else Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); States.unfreeze fs; @@ -161,13 +162,11 @@ let pr_new_syntax po loc chan_beautify ocom = let pp_cmd_header loc com = let shorten s = try (String.sub s 0 30)^"..." with _ -> s in - let noblank s = - for i = 0 to String.length s - 1 do - match s.[i] with - | ' ' | '\n' | '\t' | '\r' -> s.[i] <- '~' - | _ -> () - done; - s + let noblank s = String.map (fun c -> + match c with + | ' ' | '\n' | '\t' | '\r' -> '~' + | x -> x + ) s in let (start,stop) = Loc.unloc loc in let safe_pr_vernac x = @@ -180,9 +179,10 @@ let pp_cmd_header loc com = (* This is a special case where we assume we are in console batch mode and take control of the console. *) +(* FIXME *) let print_cmd_header loc com = - Pp.pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft (pp_cmd_header loc com); - Format.pp_print_flush !Pp_control.std_ft () + Pp.pp_with !Topfmt.std_ft (pp_cmd_header loc com); + Format.pp_print_flush !Topfmt.std_ft () let rec interp_vernac po chan_beautify checknav (loc,com) = let interp = function @@ -343,7 +343,7 @@ let compile verbosely f = let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in Library.save_library_raw lfdv sum lib univs proofs -let compile v f = +let compile v f = ignore(CoqworkmgrApi.get 1); compile v f; CoqworkmgrApi.giveback 1 diff --git a/toplevel/assumptions.ml b/vernac/assumptions.ml index 45c539e22..8865cd646 100644 --- a/toplevel/assumptions.ml +++ b/vernac/assumptions.ml @@ -25,6 +25,8 @@ open Globnames open Printer open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + (** For a constant c in a module sealed by an interface (M:T and not M<:T), [Global.lookup_constant] may return a [constant_body] without body. We fix this by looking in the implementation @@ -144,7 +146,7 @@ let label_of = function let rec traverse current ctx accu t = match kind_of_term t with | Var id -> - let body () = Global.lookup_named id |> get_value in + let body () = id |> Global.lookup_named |> NamedDecl.get_value in traverse_object accu body (VarRef id) | Const (kn, _) -> let body () = Global.body_of_constant_body (lookup_constant kn) in diff --git a/toplevel/assumptions.mli b/vernac/assumptions.mli index 072675783..072675783 100644 --- a/toplevel/assumptions.mli +++ b/vernac/assumptions.mli diff --git a/toplevel/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index c8adf9465..6d71601cc 100644 --- a/toplevel/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -25,7 +25,8 @@ open Tactics open Ind_tables open Misctypes open Proofview.Notations -open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration let out_punivs = Univ.out_punivs @@ -151,14 +152,14 @@ let build_beq_scheme mode kn = ( fun a b decl -> (* mkLambda(n,b,a) ) *) (* here I leave the Naming thingy so that the type of the function is more readable for the user *) - mkNamedLambda (eqName (get_name decl)) b a ) + mkNamedLambda (eqName (RelDecl.get_name decl)) b a ) c (List.rev eqs_typ) lnamesparrec in List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *) (* Same here , hoping the auto renaming will do something good ;) *) mkNamedLambda - (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (get_type decl) a) eq_input lnamesparrec + (match RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_type decl) a) eq_input lnamesparrec in let make_one_eq cur = let u = Univ.Instance.empty in @@ -256,7 +257,7 @@ let build_beq_scheme mode kn = | 0 -> Lazy.force tt | _ -> let eqs = Array.make nb_cstr_args (Lazy.force tt) in for ndx = 0 to nb_cstr_args-1 do - let cc = get_type (List.nth constrsi.(i).cs_args ndx) in + let cc = RelDecl.get_type (List.nth constrsi.(i).cs_args ndx) in let eqA, eff' = compute_A_equality rel_list nparrec (nparrec+3+2*nb_cstr_args) @@ -275,14 +276,14 @@ let build_beq_scheme mode kn = (Array.sub eqs 1 (nb_cstr_args - 1)) ) in - (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a)) cc + (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) cc (constrsj.(j).cs_args) ) else ar2.(j) <- (List.fold_left (fun a decl -> - mkLambda (get_name decl, get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) ) + mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) ) done; - ar.(i) <- (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a)) + ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) (mkCase (ci,do_predicate rel_list nb_cstr_args, mkVar (Id.of_string "Y") ,ar2)) (constrsi.(i).cs_args)) @@ -349,7 +350,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = let rec find i = if Id.equal avoid.(n-i) s then avoid.(n-i-x) else (if i<n then find (i+1) - else errorlabstrm "AutoIndDecl.do_replace_lb" + else user_err ~hdr:"AutoIndDecl.do_replace_lb" (str "Var " ++ pr_id s ++ str " seems unknown.") ) in mkVar (find 1) @@ -407,7 +408,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let rec find i = if Id.equal avoid.(n-i) s then avoid.(n-i-x) else (if i<n then find (i+1) - else errorlabstrm "AutoIndDecl.do_replace_bl" + else user_err ~hdr:"AutoIndDecl.do_replace_bl" (str "Var " ++ pr_id s ++ str " seems unknown.") ) in mkVar (find 1) @@ -443,14 +444,14 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = with Not_found -> (* spiwack: the format of this error message should probably be improved. *) - let err_msg = string_of_ppcmds + let err_msg = (str "boolean->Leibniz:" ++ str "You have to declare the" ++ str "decidability over " ++ Printer.pr_constr tt1 ++ str " first.") in - error err_msg + user_err err_msg in let bl_args = Array.append (Array.append (Array.map (fun x -> x) v) @@ -498,7 +499,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = [(in,eq_in,in_bl,in_al),,...,(i1,eq_i1,i1_bl_i1_al )] *) let list_id l = List.fold_left ( fun a decl -> let s' = - match get_name decl with + match RelDecl.get_name decl with Name s -> Id.to_string s | Anonymous -> "A" in (Id.of_string s',Id.of_string ("eq_"^s'), @@ -515,19 +516,22 @@ let eqI ind l = (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) and e, eff = try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff - with Not_found -> errorlabstrm "AutoIndDecl.eqI" + with Not_found -> user_err ~hdr:"AutoIndDecl.eqI" (str "The boolean equality on " ++ pr_mind (fst ind) ++ str " is needed."); in (if Array.equal eq_constr eA [||] then e else mkApp(e,eA)), eff (**********************************************************************) (* Boolean->Leibniz *) +open Namegen + let compute_bl_goal ind lnamesparrec nparrec = let eqI, eff = eqI ind lnamesparrec in let list_id = list_id lnamesparrec in + let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in let create_input c = - let x = Id.of_string "x" and - y = Id.of_string "y" in + let x = next_ident_away (Id.of_string "x") avoid and + y = next_ident_away (Id.of_string "y") avoid in let bl_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( @@ -546,11 +550,11 @@ let compute_bl_goal ind lnamesparrec nparrec = mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a decl -> mkNamedProd - (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (get_type decl) a) eq_input lnamesparrec + (match RelDecl.get_name decl with Name s -> s | Anonymous -> next_ident_away (Id.of_string "A") avoid) + (RelDecl.get_type decl) a) eq_input lnamesparrec in - let n = Id.of_string "x" and - m = Id.of_string "y" in + let n = next_ident_away (Id.of_string "x") avoid and + m = next_ident_away (Id.of_string "y") avoid in let u = Univ.Instance.empty in create_input ( mkNamedProd n (mkFullInd (ind,u) nparrec) ( @@ -642,7 +646,7 @@ let side_effect_of_mode = function let make_bl_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then - errorlabstrm "" + user_err (str "Automatic building of boolean->Leibniz lemmas not supported"); let ind = (mind,0) in let nparams = mib.mind_nparams in @@ -667,10 +671,11 @@ let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in + let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in let eqI, eff = eqI ind lnamesparrec in let create_input c = - let x = Id.of_string "x" and - y = Id.of_string "y" in + let x = next_ident_away (Id.of_string "x") avoid and + y = next_ident_away (Id.of_string "y") avoid in let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( @@ -689,11 +694,11 @@ let compute_lb_goal ind lnamesparrec nparrec = mkNamedProd seq b a ) lb_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a decl -> mkNamedProd - (match (get_name decl) with Name s -> s | Anonymous -> Id.of_string "A") - (get_type decl) a) eq_input lnamesparrec + (match (RelDecl.get_name decl) with Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_type decl) a) eq_input lnamesparrec in - let n = Id.of_string "x" and - m = Id.of_string "y" in + let n = next_ident_away (Id.of_string "x") avoid and + m = next_ident_away (Id.of_string "y") avoid in let u = Univ.Instance.empty in create_input ( mkNamedProd n (mkFullInd (ind,u) nparrec) ( @@ -765,7 +770,7 @@ let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") let make_lb_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then - errorlabstrm "" + user_err (str "Automatic building of Leibniz->boolean lemmas not supported"); let ind = (mind,0) in let nparams = mib.mind_nparams in @@ -796,9 +801,10 @@ let compute_dec_goal ind lnamesparrec nparrec = check_not_is_defined (); let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in let list_id = list_id lnamesparrec in + let avoid = List.fold_right (Nameops.name_fold (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in let create_input c = - let x = Id.of_string "x" and - y = Id.of_string "y" in + let x = next_ident_away (Id.of_string "x") avoid and + y = next_ident_away (Id.of_string "y") avoid in let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( @@ -830,11 +836,11 @@ let compute_dec_goal ind lnamesparrec nparrec = mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a decl -> mkNamedProd - (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (get_type decl) a) eq_input lnamesparrec + (match RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_type decl) a) eq_input lnamesparrec in - let n = Id.of_string "x" and - m = Id.of_string "y" in + let n = next_ident_away (Id.of_string "x") avoid and + m = next_ident_away (Id.of_string "y") avoid in let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in create_input ( mkNamedProd n (mkFullInd ind (2*nparrec)) ( diff --git a/toplevel/auto_ind_decl.mli b/vernac/auto_ind_decl.mli index 60232ba8f..60232ba8f 100644 --- a/toplevel/auto_ind_decl.mli +++ b/vernac/auto_ind_decl.mli diff --git a/toplevel/class.ml b/vernac/class.ml index 6d53ec9d8..0dc799014 100644 --- a/toplevel/class.ml +++ b/vernac/class.ml @@ -98,7 +98,7 @@ let class_of_global = function | IndRef sp -> CL_IND sp | VarRef id -> CL_SECVAR id | ConstructRef _ as c -> - errorlabstrm "class_of_global" + user_err ~hdr:"class_of_global" (str "Constructors, such as " ++ Printer.pr_global c ++ str ", cannot be used as a class.") @@ -177,7 +177,7 @@ let ident_key_of_class = function (* Identity coercion *) let error_not_transparent source = - errorlabstrm "build_id_coercion" + user_err ~hdr:"build_id_coercion" (pr_class source ++ str " must be a transparent constant.") let build_id_coercion idf_opt source poly = @@ -208,7 +208,7 @@ let build_id_coercion idf_opt source poly = (Reductionops.is_conv_leq env sigma (Typing.unsafe_type_of env sigma val_f) typ_f) then - errorlabstrm "" (strbrk + user_err (strbrk "Cannot be defined as coercion (maybe a bad number of arguments).") in let idf = @@ -284,7 +284,7 @@ let add_new_coercion_core coef stre poly source target isid = let try_add_new_coercion_core ref ~local c d e f = try add_new_coercion_core ref (loc_of_bool local) c d e f with CoercionError e -> - errorlabstrm "try_add_new_coercion_core" + user_err ~hdr:"try_add_new_coercion_core" (explain_coercion_error ref e ++ str ".") let try_add_new_coercion ref ~local poly = diff --git a/toplevel/class.mli b/vernac/class.mli index 5f9ae28f6..5f9ae28f6 100644 --- a/toplevel/class.mli +++ b/vernac/class.mli diff --git a/toplevel/classes.ml b/vernac/classes.ml index 1528cbb2f..6512f3def 100644 --- a/toplevel/classes.ml +++ b/vernac/classes.ml @@ -22,6 +22,8 @@ open Constrintern open Constrexpr open Sigma.Notations open Context.Rel.Declaration + +module RelDecl = Context.Rel.Declaration (*i*) open Decl_kinds @@ -75,8 +77,9 @@ let existing_instance glob g info = match class_of_constr r with | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob (*FIXME*) (Flags.use_polymorphic_flag ()) c) - | None -> user_err_loc (loc_of_reference g, "declare_instance", - Pp.str "Constant does not build instances of a declared type class.") + | None -> user_err ~loc:(loc_of_reference g) + ~hdr:"declare_instance" + (Pp.str "Constant does not build instances of a declared type class.") let mismatched_params env n m = mismatched_ctx_inst env Parameters n m let mismatched_props env n m = mismatched_ctx_inst env Properties n m @@ -86,13 +89,13 @@ let mismatched_props env n m = mismatched_ctx_inst env Properties n m let type_ctx_instance evars env ctx inst subst = let rec aux (subst, instctx) l = function decl :: ctx -> - let t' = substl subst (get_type decl) in + let t' = substl subst (RelDecl.get_type decl) in let c', l = match decl with | LocalAssum _ -> interp_casted_constr_evars env evars (List.hd l) t', List.tl l | LocalDef (_,b,_) -> substl subst b, l in - let d = get_name decl, Some c', t' in + let d = RelDecl.get_name decl, Some c', t' in aux (c' :: subst, d :: instctx) l ctx | [] -> subst in aux (subst, []) inst (List.rev ctx) @@ -165,7 +168,6 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p let cl, u = Typeclasses.typeclass_univ_instance k in let _, args = List.fold_right (fun decl (args, args') -> - let open Context.Rel.Declaration in match decl with | LocalAssum _ -> (List.tl args, List.hd args :: args') | LocalDef (_,b,_) -> (args, substl args' b :: args')) @@ -178,7 +180,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p Name id -> let sp = Lib.make_path id in if Nametab.exists_cci sp then - errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists."); + user_err ~hdr:"new_instance" (Nameops.pr_id id ++ Pp.str " already exists."); id | Anonymous -> let i = Nameops.add_suffix (id_of_class k) "_instance_0" in @@ -238,7 +240,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p (fun (props, rest) decl -> if is_local_assum decl then try - let is_id (id', _) = match get_name decl, get_id id' with + let is_id (id', _) = match RelDecl.get_name decl, get_id id' with | Name id, (_, id') -> Id.equal id id' | Anonymous, _ -> false in @@ -356,7 +358,7 @@ let named_of_rel_context l = let acc, ctx = List.fold_right (fun decl (subst, ctx) -> - let id = match get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in + let id = match RelDecl.get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in let d = match decl with | LocalAssum (_,t) -> id, None, substl subst t | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in diff --git a/toplevel/classes.mli b/vernac/classes.mli index d2cb788ea..d2cb788ea 100644 --- a/toplevel/classes.mli +++ b/vernac/classes.mli diff --git a/toplevel/command.ml b/vernac/command.ml index a9f2598e2..4b4f4d271 100644 --- a/toplevel/command.ml +++ b/vernac/command.ml @@ -39,6 +39,8 @@ open Sigma.Notations open Context.Rel.Declaration open Entries +module RelDecl = Context.Rel.Declaration + let do_universe poly l = Declare.do_universe poly l let do_constraint poly l = Declare.do_constraint poly l @@ -57,8 +59,8 @@ let rec complete_conclusion a cs = function | CHole (loc, k, _, _) -> let (has_no_args,name,params) = a in if not has_no_args then - user_err_loc (loc,"", - strbrk"Cannot infer the non constant arguments of the conclusion of " + user_err ~loc + (strbrk"Cannot infer the non constant arguments of the conclusion of " ++ pr_id cs ++ str "."); let args = List.map (fun id -> CRef(Ident(loc,id),None)) params in CAppExpl (loc,(None,Ident(loc,name),None),List.rev args) @@ -79,7 +81,7 @@ let red_constant_entry n ce sigma = function let Sigma (c, _, _) = redfun.e_redfun env sigma c in c in - { ce with const_entry_body = Future.chain ~greedy:true ~pure:true proof_out + { ce with const_entry_body = Future.chain ~pure:true proof_out (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) } let warn_implicits_in_term = @@ -333,7 +335,7 @@ let do_assumptions kind nl l = match l with | (Discharge, _, _) when Lib.sections_are_opened () -> let loc = fst id in let msg = Pp.str "Section variables cannot be polymorphic." in - user_err_loc (loc, "", msg) + user_err ~loc msg | _ -> () in do_assumptions_bound_univs coe kind nl id (Some pl) c @@ -345,7 +347,7 @@ let do_assumptions kind nl l = match l with let loc = fst id in let msg = Pp.str "Assumptions with bound universes can only be defined one at a time." in - user_err_loc (loc, "", msg) + user_err ~loc msg in (coe, (List.map map idl, c)) in @@ -441,7 +443,7 @@ let interp_ind_arity env evdref ind = let t, impls = understand_tcc_evars env evdref ~expected_type:IsType c, imps in let pseudo_poly = check_anonymous_type c in let () = if not (Reduction.is_arity env t) then - user_err_loc (constr_loc ind.ind_arity, "", str "Not an arity") + user_err ~loc:(constr_loc ind.ind_arity) (str "Not an arity") in t, pseudo_poly, impls @@ -460,7 +462,7 @@ let sign_level env evd sign = | LocalDef _ -> lev, push_rel d env | LocalAssum _ -> let s = destSort (Reduction.whd_all env - (nf_evar evd (Retyping.get_type_of env evd (get_type d)))) + (nf_evar evd (Retyping.get_type_of env evd (RelDecl.get_type d)))) in let u = univ_of_sort s in (Univ.sup u lev, push_rel d env)) @@ -554,7 +556,7 @@ let check_named (loc, na) = match na with | Name _ -> () | Anonymous -> let msg = str "Parameters must be named." in - user_err_loc (loc, "", msg) + user_err ~loc msg let check_param = function @@ -577,7 +579,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = (* Names of parameters as arguments of the inductive type (defs removed) *) let assums = List.filter is_local_assum ctx_params in - let params = List.map (fun decl -> out_name (get_name decl)) assums in + let params = List.map (RelDecl.get_name %> out_name) assums in (* Interpret the arities *) let arities = List.map (interp_ind_arity env_params evdref) indl in @@ -910,8 +912,8 @@ let rec telescope = function let ty, tys, (k, constr) = List.fold_left (fun (ty, tys, (k, constr)) decl -> - let t = get_type decl in - let pred = mkLambda (get_name decl, t, ty) in + let t = RelDecl.get_type decl in + let pred = mkLambda (RelDecl.get_name decl, t, ty) in let ty = Universes.constr_of_global (Lazy.force sigT).typ in let intro = Universes.constr_of_global (Lazy.force sigT).intro in let sigty = mkApp (ty, [|t; pred|]) in @@ -921,7 +923,7 @@ let rec telescope = function in let (last, subst) = List.fold_right2 (fun pred decl (prev, subst) -> - let t = get_type decl in + let t = RelDecl.get_type decl in let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in let proj1 = applistc p1 [t; pred; prev] in @@ -955,9 +957,9 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let relty = Typing.unsafe_type_of env !evdref rel in let relargty = let error () = - user_err_loc (constr_loc r, - "Command.build_wellfounded", - Printer.pr_constr_env env !evdref rel ++ str " is not an homogeneous binary relation.") + user_err ~loc:(constr_loc r) + ~hdr:"Command.build_wellfounded" + (Printer.pr_constr_env env !evdref rel ++ str " is not an homogeneous binary relation.") in try let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in @@ -1134,7 +1136,7 @@ let interp_recursive isfix fixl notations = let evd, nf = nf_evars_and_universes evd in let fixdefs = List.map (Option.map nf) fixdefs in let fixtypes = List.map nf fixtypes in - let fixctxnames = List.map (fun (_,ctx) -> List.map get_name ctx) fixctxs in + let fixctxnames = List.map (fun (_,ctx) -> List.map RelDecl.get_name ctx) fixctxs in (* Build the fix declaration block *) (env,rec_sign,all_universes,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxnames fiximps fixannots @@ -1313,7 +1315,7 @@ let do_program_fixpoint local poly l = match n with | Some n -> mkIdentC (snd n) | None -> - errorlabstrm "do_program_fixpoint" + user_err ~hdr:"do_program_fixpoint" (str "Recursive argument required for well-founded fixpoints") in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn @@ -1327,7 +1329,7 @@ let do_program_fixpoint local poly l = do_program_recursive local poly fixkind fixl ntns | _, _ -> - errorlabstrm "do_program_fixpoint" + user_err ~hdr:"do_program_fixpoint" (str "Well-founded fixpoints not allowed in mutually recursive blocks") let check_safe () = diff --git a/toplevel/command.mli b/vernac/command.mli index 616afb91f..616afb91f 100644 --- a/toplevel/command.mli +++ b/vernac/command.mli diff --git a/toplevel/discharge.ml b/vernac/discharge.ml index e24d5e74f..e24d5e74f 100644 --- a/toplevel/discharge.ml +++ b/vernac/discharge.ml diff --git a/toplevel/discharge.mli b/vernac/discharge.mli index 18d1b6776..18d1b6776 100644 --- a/toplevel/discharge.mli +++ b/vernac/discharge.mli diff --git a/toplevel/doc.tex b/vernac/doc.tex index f2550fda1..f2550fda1 100644 --- a/toplevel/doc.tex +++ b/vernac/doc.tex diff --git a/toplevel/explainErr.ml b/vernac/explainErr.ml index 17897460c..f1e0c48f0 100644 --- a/toplevel/explainErr.ml +++ b/vernac/explainErr.ml @@ -45,15 +45,9 @@ let _ = CErrors.register_handler explain_exn_default (** Pre-explain a vernac interpretation error *) -let wrap_vernac_error with_header (exn, info) strm = - if with_header then - let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in - let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in - (e, info) - else - (EvaluatedError (strm, None), info) +let wrap_vernac_error (exn, info) strm = (EvaluatedError (strm, None), info) -let process_vernac_interp_error with_header exn = match fst exn with +let process_vernac_interp_error exn = match fst exn with | Univ.UniverseInconsistency i -> let msg = if !Constrextern.print_universes then @@ -61,40 +55,40 @@ let process_vernac_interp_error with_header exn = match fst exn with Univ.explain_universe_inconsistency Universes.pr_with_global_universes i else mt() in - wrap_vernac_error with_header exn (str "Universe inconsistency" ++ msg ++ str ".") + wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".") | TypeError(ctx,te) -> - wrap_vernac_error with_header exn (Himsg.explain_type_error ctx Evd.empty te) + wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> - wrap_vernac_error with_header exn (Himsg.explain_pretype_error ctx sigma te) + wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> - wrap_vernac_error with_header exn (Himsg.explain_typeclass_error env te) + wrap_vernac_error exn (Himsg.explain_typeclass_error env te) | InductiveError e -> - wrap_vernac_error with_header exn (Himsg.explain_inductive_error e) + wrap_vernac_error exn (Himsg.explain_inductive_error e) | Modops.ModuleTypingError e -> - wrap_vernac_error with_header exn (Himsg.explain_module_error e) + wrap_vernac_error exn (Himsg.explain_module_error e) | Modintern.ModuleInternalizationError e -> - wrap_vernac_error with_header exn (Himsg.explain_module_internalization_error e) + wrap_vernac_error exn (Himsg.explain_module_internalization_error e) | RecursionSchemeError e -> - wrap_vernac_error with_header exn (Himsg.explain_recursion_scheme_error e) + wrap_vernac_error exn (Himsg.explain_recursion_scheme_error e) | Cases.PatternMatchingError (env,sigma,e) -> - wrap_vernac_error with_header exn (Himsg.explain_pattern_matching_error env sigma e) + wrap_vernac_error exn (Himsg.explain_pattern_matching_error env sigma e) | Tacred.ReductionTacticError e -> - wrap_vernac_error with_header exn (Himsg.explain_reduction_tactic_error e) + wrap_vernac_error exn (Himsg.explain_reduction_tactic_error e) | Logic.RefinerError e -> - wrap_vernac_error with_header exn (Himsg.explain_refiner_error e) + wrap_vernac_error exn (Himsg.explain_refiner_error e) | Nametab.GlobalizationError q -> - wrap_vernac_error with_header exn + wrap_vernac_error exn (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ spc () ++ str "was not found" ++ spc () ++ str "in the current" ++ spc () ++ str "environment.") | Refiner.FailError (i,s) -> let s = Lazy.force s in - wrap_vernac_error with_header exn + wrap_vernac_error exn (str "Tactic failure" ++ - (if Pp.is_empty s then s else str ": " ++ s) ++ + (if Pp.ismt s then s else str ": " ++ s) ++ if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").") | AlreadyDeclared msg -> - wrap_vernac_error with_header exn (msg ++ str ".") + wrap_vernac_error exn (msg ++ str ".") | _ -> exn @@ -108,9 +102,9 @@ let additional_error_info = ref [] let register_additional_error_info f = additional_error_info := f :: !additional_error_info -let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, info) = +let process_vernac_interp_error ?(allow_uncaught=true) (exc, info) = let exc = strip_wrapping_exceptions exc in - let e = process_vernac_interp_error with_header (exc, info) in + let e = process_vernac_interp_error (exc, info) in let () = if not allow_uncaught && not (CErrors.handled (fst e)) then let (e, info) = e in diff --git a/toplevel/explainErr.mli b/vernac/explainErr.mli index a67c887af..370ad7e3b 100644 --- a/toplevel/explainErr.mli +++ b/vernac/explainErr.mli @@ -11,7 +11,7 @@ exception EvaluatedError of Pp.std_ppcmds * exn option (** Pre-explain a vernac interpretation error *) -val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> Util.iexn -> Util.iexn +val process_vernac_interp_error : ?allow_uncaught:bool -> Util.iexn -> Util.iexn (** General explain function. Should not be used directly now, see instead function [Errors.print] and variants *) diff --git a/toplevel/himsg.ml b/vernac/himsg.ml index f98505c36..6cff805fc 100644 --- a/toplevel/himsg.ml +++ b/vernac/himsg.ml @@ -25,6 +25,8 @@ open Printer open Evd open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (* This simplifies the typing context of Cases clauses *) (* hope it does not disturb other typing contexts *) let contract env lc = @@ -35,13 +37,10 @@ let contract env lc = l := (Vars.substl !l c') :: !l; env | _ -> - let t' = Vars.substl !l (get_type decl) in - let c' = Option.map (Vars.substl !l) (get_value decl) in - let na' = named_hd env t' (get_name decl) in + let t = Vars.substl !l (RelDecl.get_type decl) in + let decl = decl |> RelDecl.map_name (named_hd env t) |> RelDecl.map_value (Vars.substl !l) |> RelDecl.set_type t in l := (mkRel 1) :: List.map (Vars.lift 1) !l; - match c' with - | None -> push_rel (LocalAssum (na',t')) env - | Some c' -> push_rel (LocalDef (na',c',t')) env + push_rel decl env in let env = process_rel_context contract_context env in (env, List.map (Vars.substl !l) lc) @@ -149,7 +148,7 @@ let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags let pr_db env i = try - match lookup_rel i env |> get_name with + match env |> lookup_rel i |> get_name with | Name id -> pr_id id | Anonymous -> str "<>" with Not_found -> str "UNBOUND_REL_" ++ int i @@ -533,6 +532,8 @@ let pr_trailing_ne_context_of env sigma = else (str " in environment:"++ pr_context_unlimited env sigma) let rec explain_evar_kind env sigma evk ty = function + | Evar_kinds.NamedHole id -> + strbrk "the existential variable named " ++ pr_id id | Evar_kinds.QuestionMark _ -> strbrk "this placeholder of type " ++ ty | Evar_kinds.CasesType false -> diff --git a/toplevel/himsg.mli b/vernac/himsg.mli index ced54fd27..ced54fd27 100644 --- a/toplevel/himsg.mli +++ b/vernac/himsg.mli diff --git a/toplevel/ind_tables.ml b/vernac/ind_tables.ml index 6d57a21dc..85d0b6194 100644 --- a/toplevel/ind_tables.ml +++ b/vernac/ind_tables.ml @@ -87,7 +87,7 @@ let declare_scheme_object s aux f = try let _ = Hashtbl.find scheme_object_table key in (* let aux_msg = if aux="" then "" else " (with key "^aux^")" in*) - errorlabstrm "IndTables.declare_scheme_object" + user_err ~hdr:"IndTables.declare_scheme_object" (str "Scheme object " ++ str key ++ str " already declared.") with Not_found -> Hashtbl.add scheme_object_table key (s,f); diff --git a/toplevel/ind_tables.mli b/vernac/ind_tables.mli index 20f30d6d1..20f30d6d1 100644 --- a/toplevel/ind_tables.mli +++ b/vernac/ind_tables.mli diff --git a/toplevel/indschemes.ml b/vernac/indschemes.ml index 101c2d9bf..f7e3f0d95 100644 --- a/toplevel/indschemes.ml +++ b/vernac/indschemes.ml @@ -199,7 +199,7 @@ let try_declare_scheme what f internal names kn = in match msg with | None -> () - | Some msg -> iraise (UserError ("", msg), snd e) + | Some msg -> iraise (UserError (None, msg), snd e) let beq_scheme_msg mind = let mib = Global.lookup_mind mind in diff --git a/toplevel/indschemes.mli b/vernac/indschemes.mli index e5d79fd51..e5d79fd51 100644 --- a/toplevel/indschemes.mli +++ b/vernac/indschemes.mli diff --git a/stm/lemmas.ml b/vernac/lemmas.ml index 022c89ad9..798a238c7 100644 --- a/stm/lemmas.ml +++ b/vernac/lemmas.ml @@ -33,6 +33,9 @@ open Constrintern open Impargs open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + type 'a declaration_hook = Decl_kinds.locality -> Globnames.global_reference -> 'a let mk_hook hook = hook let call_hook fix_exn hook l c = @@ -45,8 +48,7 @@ let call_hook fix_exn hook l c = let retrieve_first_recthm = function | VarRef id -> - let open Context.Named.Declaration in - (get_value (Global.lookup_named id),variable_opacity id) + (NamedDecl.get_value (Global.lookup_named id),variable_opacity id) | ConstRef cst -> let cb = Global.lookup_constant cst in (Global.body_of_constant_body cb, is_opaque cb) @@ -58,7 +60,7 @@ let adjust_guardness_conditions const = function (* Try all combinations... not optimal *) let env = Global.env() in { const with const_entry_body = - Future.chain ~greedy:true ~pure:true const.const_entry_body + Future.chain ~pure:true const.const_entry_body (fun ((body, ctx), eff) -> match kind_of_term body with | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> @@ -110,7 +112,7 @@ let find_mutually_recursive_statements thms = (Global.env()) hyps in let ind_hyps = List.flatten (List.map_i (fun i decl -> - let t = get_type decl in + let t = RelDecl.get_type decl in match kind_of_term t with | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in @@ -222,7 +224,7 @@ let compute_proof_name locality = function if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) then - user_err_loc (loc,"",pr_id id ++ str " already exists."); + user_err ~loc (pr_id id ++ str " already exists."); id, pl | None -> next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()), None @@ -335,7 +337,7 @@ let get_proof proof do_guard hook opacity = let check_exist = List.iter (fun (loc,id) -> if not (Nametab.exists_cci (Lib.make_path id)) then - user_err_loc (loc,"",pr_id id ++ str " does not exist.") + user_err ~loc (pr_id id ++ str " does not exist.") ) let universe_proof_terminator compute_guard hook = @@ -462,7 +464,7 @@ let start_proof_com ?inference_hook kind thms hook = let flags = all_and_fail_flags in let flags = { flags with use_hook = inference_hook } in evdref := solve_remaining_evars flags env !evdref (Evd.empty,!evdref); - let ids = List.map get_name ctx in + let ids = List.map RelDecl.get_name ctx in (compute_proof_name (pi1 kind) sopt, (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), (ids, imps @ lift_implicits (List.length ids) imps'), diff --git a/stm/lemmas.mli b/vernac/lemmas.mli index 39c089be9..39c089be9 100644 --- a/stm/lemmas.mli +++ b/vernac/lemmas.mli diff --git a/toplevel/locality.ml b/vernac/locality.ml index 154f787ef..03640676e 100644 --- a/toplevel/locality.ml +++ b/vernac/locality.ml @@ -18,7 +18,7 @@ let check_locality locality_flag = match locality_flag with | Some b -> let s = if b then "Local" else "Global" in - CErrors.errorlabstrm "Locality.check_locality" + CErrors.user_err ~hdr:"Locality.check_locality" (str "This command does not support the \"" ++ str s ++ str "\" prefix.") | None -> () diff --git a/toplevel/locality.mli b/vernac/locality.mli index 2ec392eef..2ec392eef 100644 --- a/toplevel/locality.mli +++ b/vernac/locality.mli diff --git a/toplevel/metasyntax.ml b/vernac/metasyntax.ml index e90d638d0..7e98d114a 100644 --- a/toplevel/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -20,10 +20,8 @@ open Extend open Libobject open Constrintern open Vernacexpr -open Pcoq open Libnames open Tok -open Egramcoq open Notation open Nameops @@ -46,12 +44,30 @@ let add_token_obj s = Lib.add_anonymous_leaf (inToken s) let entry_buf = Buffer.create 64 +type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry + +let grammars : any_entry list String.Map.t ref = ref String.Map.empty + +let register_grammar name grams = + grammars := String.Map.add name grams !grammars + let pr_entry e = let () = Buffer.clear entry_buf in let ft = Format.formatter_of_buffer entry_buf in - let () = Gram.entry_print ft e in + let () = Pcoq.Gram.entry_print ft e in str (Buffer.contents entry_buf) +let pr_registered_grammar name = + let gram = try Some (String.Map.find name !grammars) with Not_found -> None in + match gram with + | None -> error "Unknown or unprintable grammar entry." + | Some entries -> + let pr_one (AnyEntry e) = + str "Entry " ++ str (Pcoq.Gram.Entry.name e) ++ str " is" ++ fnl () ++ + pr_entry e + in + prlist pr_one entries + let pr_grammar = function | "constr" | "operconstr" | "binder_constr" -> str "Entry constr is" ++ fnl () ++ @@ -64,15 +80,6 @@ let pr_grammar = function pr_entry Pcoq.Constr.operconstr | "pattern" -> pr_entry Pcoq.Constr.pattern - | "tactic" -> - str "Entry tactic_expr is" ++ fnl () ++ - pr_entry Pcoq.Tactic.tactic_expr ++ - str "Entry binder_tactic is" ++ fnl () ++ - pr_entry Pcoq.Tactic.binder_tactic ++ - str "Entry simple_tactic is" ++ fnl () ++ - pr_entry Pcoq.Tactic.simple_tactic ++ - str "Entry tactic_arg is" ++ fnl () ++ - pr_entry Pcoq.Tactic.tactic_arg | "vernac" -> str "Entry vernac is" ++ fnl () ++ pr_entry Pcoq.Vernac_.vernac ++ @@ -84,7 +91,7 @@ let pr_grammar = function pr_entry Pcoq.Vernac_.gallina ++ str "Entry gallina_ext is" ++ fnl () ++ pr_entry Pcoq.Vernac_.gallina_ext - | _ -> error "Unknown or unprintable grammar entry." + | name -> pr_registered_grammar name (**********************************************************************) (* Parse a format (every terminal starting with a letter or a single @@ -238,7 +245,7 @@ let rec find_pattern nt xl = function | _, Break s :: _ | Break s :: _, _ -> error ("A break occurs on one side of \"..\" but not on the other side.") | _, Terminal s :: _ | Terminal s :: _, _ -> - errorlabstrm "Metasyntax.find_pattern" + user_err ~hdr:"Metasyntax.find_pattern" (str "The token \"" ++ str s ++ str "\" occurs on one side of \"..\" but not on the other side.") | _, [] -> error msg_expected_form_of_recursive_notation @@ -300,7 +307,7 @@ let rec get_notation_vars = function let vars = get_notation_vars sl in if Id.equal id ldots_var then vars else if Id.List.mem id vars then - errorlabstrm "Metasyntax.get_notation_vars" + user_err ~hdr:"Metasyntax.get_notation_vars" (str "Variable " ++ pr_id id ++ str " occurs more than once.") else id::vars @@ -314,7 +321,7 @@ let analyze_notation_tokens l = recvars, List.subtract Id.equal vars (List.map snd recvars), l let error_not_same_scope x y = - errorlabstrm "Metasyntax.error_not_name_scope" + user_err ~hdr:"Metasyntax.error_not_name_scope" (str "Variables " ++ pr_id x ++ str " and " ++ pr_id y ++ str " must be in the same scope.") (**********************************************************************) @@ -390,7 +397,7 @@ let check_open_binder isopen sl m = | _ -> assert false in if isopen && not (List.is_empty sl) then - errorlabstrm "" (str "as " ++ pr_id m ++ + user_err (str "as " ++ pr_id m ++ str " is a non-closed binder, no such \"" ++ prlist_with_sep spc pr_token sl ++ strbrk "\" is allowed to occur.") @@ -661,7 +668,7 @@ let pr_level ntn (from,args) = prlist_with_sep pr_comma (pr_arg_level from) args let error_incompatible_level ntn oldprec prec = - errorlabstrm "" + user_err (str "Notation " ++ str ntn ++ str " is already defined" ++ spc() ++ pr_level ntn oldprec ++ spc() ++ str "while it is now required to be" ++ spc() ++ @@ -729,59 +736,81 @@ let inSyntaxExtension : syntax_extension_obj -> obj = (* Interpreting user-provided modifiers *) -let interp_modifiers modl = - let onlyparsing = ref false in - let onlyprinting = ref false in - let compat = ref None in - let rec interp assoc level etyps format extra = function - | [] -> - (assoc,level,etyps,!onlyparsing,!onlyprinting,!compat,format,extra) +(* XXX: We could move this to the parser itself *) +module NotationMods = struct + +type notation_modifier = { + assoc : gram_assoc option; + level : int option; + etyps : (Id.t * simple_constr_prod_entry_key) list; + + (* common to syn_data below *) + only_parsing : bool; + only_printing : bool; + compat : compat_version option; + format : string Loc.located option; + extra : (string * string) list; +} + +let default = { + assoc = None; + level = None; + etyps = []; + only_parsing = false; + only_printing = false; + compat = None; + format = None; + extra = []; +} + +end + +let interp_modifiers modl = let open NotationMods in + let rec interp acc = function + | [] -> acc | SetEntryType (s,typ) :: l -> let id = Id.of_string s in - if Id.List.mem_assoc id etyps then - errorlabstrm "Metasyntax.interp_modifiers" + if Id.List.mem_assoc id acc.etyps then + user_err ~hdr:"Metasyntax.interp_modifiers" (str s ++ str " is already assigned to an entry or constr level."); - interp assoc level ((id,typ)::etyps) format extra l + interp { acc with etyps = (id,typ) :: acc.etyps; } l | SetItemLevel ([],n) :: l -> - interp assoc level etyps format extra l + interp acc l | SetItemLevel (s::idl,n) :: l -> let id = Id.of_string s in - if Id.List.mem_assoc id etyps then - errorlabstrm "Metasyntax.interp_modifiers" + if Id.List.mem_assoc id acc.etyps then + user_err ~hdr:"Metasyntax.interp_modifiers" (str s ++ str " is already assigned to an entry or constr level."); let typ = ETConstr (n,()) in - interp assoc level ((id,typ)::etyps) format extra (SetItemLevel (idl,n)::l) + interp { acc with etyps = (id,typ)::acc.etyps; } (SetItemLevel (idl,n)::l) | SetLevel n :: l -> - if not (Option.is_empty level) then error "A level is given more than once."; - interp assoc (Some n) etyps format extra l + + interp { acc with level = Some n; } l | SetAssoc a :: l -> - if not (Option.is_empty assoc) then error"An associativity is given more than once."; - interp (Some a) level etyps format extra l - | SetOnlyParsing :: l -> - onlyparsing := true; - interp assoc level etyps format extra l + if not (Option.is_empty acc.assoc) then error "An associativity is given more than once."; + interp { acc with assoc = Some a; } l + | SetOnlyParsing :: l -> + interp { acc with only_parsing = true; } l | SetOnlyPrinting :: l -> - onlyprinting := true; - interp assoc level etyps format extra l + interp { acc with only_printing = true; } l | SetCompatVersion v :: l -> - compat := Some v; - interp assoc level etyps format extra l + interp { acc with compat = Some v; } l | SetFormat ("text",s) :: l -> - if not (Option.is_empty format) then error "A format is given more than once."; - interp assoc level etyps (Some s) extra l + if not (Option.is_empty acc.format) then error "A format is given more than once."; + interp { acc with format = Some s; } l | SetFormat (k,(_,s)) :: l -> - interp assoc level etyps format ((k,s) :: extra) l - in interp None None [] None [] modl + interp { acc with extra = (k,s)::acc.extra; } l + in interp default modl let check_infix_modifiers modifiers = - let (_, _, t, _, _, _, _, _) = interp_modifiers modifiers in + let t = (interp_modifiers modifiers).NotationMods.etyps in if not (List.is_empty t) then error "Explicit entry level or type unexpected in infix notation." let check_useless_entry_types recvars mainvars etyps = let vars = let (l1,l2) = List.split recvars in l1@l2@mainvars in match List.filter (fun (x,etyp) -> not (List.mem x vars)) etyps with - | (x,_)::_ -> errorlabstrm "Metasyntax.check_useless_entry_types" + | (x,_)::_ -> user_err ~hdr:"Metasyntax.check_useless_entry_types" (pr_id x ++ str " is unbound in the notation.") | _ -> () @@ -829,7 +858,7 @@ let join_auxiliary_recursive_types recvars etyps = | None, Some ytyp -> (x,ytyp)::typs | Some xtyp, Some ytyp when Pervasives.(=) xtyp ytyp -> typs (* FIXME *) | Some xtyp, Some ytyp -> - errorlabstrm "" + user_err (strbrk "In " ++ pr_id x ++ str " .. " ++ pr_id y ++ strbrk ", both ends have incompatible types.")) recvars etyps @@ -982,19 +1011,62 @@ let remove_curly_brackets l = | x :: l -> x :: aux false l in aux true l +module SynData = struct + + (* XXX: Document *) + type syn_data = { + + (* Notation name and location *) + info : notation * notation_location; + + (* Fields coming from the vernac-level modifiers *) + only_parsing : bool; + only_printing : bool; + compat : compat_version option; + format : string Loc.located option; + extra : (string * string) list; + + (* XXX: Callback to printing, must remove *) + msgs : ((std_ppcmds -> unit) * std_ppcmds) list; + + (* Fields for internalization *) + recvars : (Id.t * Id.t) list; + mainvars : Id.List.elt list; + intern_typs : notation_var_internalization_type list; + + (* Notation data for parsing *) + + level : int; + syntax_data : (Id.t * (production_level, production_position) constr_entry_key_gen) list * (* typs *) + symbol list; (* symbols *) + not_data : notation * (* notation *) + (int * parenRelation) list * (* precedence *) + bool; (* needs_squash *) + } + +end + let compute_syntax_data df modifiers = - let (assoc,n,etyps,onlyparse,onlyprint,compat,fmt,extra) = interp_modifiers modifiers in + let open SynData in + let open NotationMods in + let mods = interp_modifiers modifiers in + let onlyprint = mods.only_printing in + let onlyparse = mods.only_parsing in if onlyprint && onlyparse then error "A notation cannot be both 'only printing' and 'only parsing'."; - let assoc = match assoc with None -> (* default *) Some NonA | a -> a in + let assoc = Option.append mods.assoc (Some NonA) in let toks = split_notation_string df in - let (recvars,mainvars,symbols) = analyze_notation_tokens toks in - let _ = check_useless_entry_types recvars mainvars etyps in + let recvars,mainvars,symbols = analyze_notation_tokens toks in + let _ = check_useless_entry_types recvars mainvars mods.etyps in + + (* Notations for interp and grammar *) let ntn_for_interp = make_notation_key symbols in let symbols' = remove_curly_brackets symbols in - let need_squash = not (List.equal Notation.symbol_eq symbols symbols') in let ntn_for_grammar = make_notation_key symbols' in if not onlyprint then check_rule_productivity symbols'; - let msgs,n = find_precedence n etyps symbols' in + + (* Misc *) + let need_squash = not (List.equal Notation.symbol_eq symbols symbols') in + let msgs,n = find_precedence mods.level mods.etyps symbols' in let innerlevel = NumLevel 200 in let typs = find_symbols @@ -1003,25 +1075,44 @@ let compute_syntax_data df modifiers = (NumLevel n,BorderProd(Right,assoc)) symbols' in (* To globalize... *) - let etyps = join_auxiliary_recursive_types recvars etyps in + let etyps = join_auxiliary_recursive_types recvars mods.etyps in let sy_typs = List.map (set_entry_type etyps) typs in - let prec = (n,List.map (assoc_of_type n) sy_typs) in + let prec = List.map (assoc_of_type n) sy_typs in let i_typs = set_internalization_type sy_typs in - let sy_data = (n,sy_typs,symbols',fmt) in - let sy_fulldata = (i_typs,ntn_for_grammar,prec,need_squash,sy_data) in + let sy_data = (sy_typs,symbols') in + let sy_fulldata = (ntn_for_grammar,prec,need_squash) in let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in - let i_data = (onlyparse,onlyprint,compat,recvars,mainvars,(ntn_for_interp,df')) in + let i_data = ntn_for_interp, df' in + (* Return relevant data for interpretation and for parsing/printing *) - (msgs,i_data,i_typs,sy_fulldata,extra) + { info = i_data; + + only_parsing = mods.only_parsing; + only_printing = mods.only_printing; + compat = mods.compat; + format = mods.format; + extra = mods.extra; + + msgs; + + recvars; + mainvars; + intern_typs = i_typs; + + level = n; + syntax_data = sy_data; + not_data = sy_fulldata; + } let compute_pure_syntax_data df mods = - let (msgs,(onlyparse,onlyprint,_,_,_,_),_,sy_data,extra) = compute_syntax_data df mods in + let open SynData in + let sd = compute_syntax_data df mods in let msgs = - if onlyparse then + if sd.only_parsing then (Feedback.msg_warning ?loc:None, - strbrk "The only parsing modifier has no effect in Reserved Notation.")::msgs - else msgs in - msgs, sy_data, extra, onlyprint + strbrk "The only parsing modifier has no effect in Reserved Notation.")::sd.msgs + else sd.msgs in + { sd with msgs } (**********************************************************************) (* Registration of notations interpretation *) @@ -1084,7 +1175,7 @@ let with_lib_stk_protection f x = let with_syntax_protection f x = with_lib_stk_protection - (with_grammar_rule_protection + (Pcoq.with_grammar_rule_protection (with_notation_protection f)) x (**********************************************************************) @@ -1138,10 +1229,10 @@ let recover_notation_syntax rawntn = (**********************************************************************) (* Main entry point for building parsing and printing rules *) -let make_pa_rule i_typs (n,typs,symbols,_) ntn onlyprint = +let make_pa_rule i_typs level (typs,symbols) ntn onlyprint = let assoc = recompute_assoc typs in let prod = make_production typs symbols in - { notgram_level = n; + { notgram_level = level; notgram_assoc = assoc; notgram_notation = ntn; notgram_prods = prod; @@ -1149,21 +1240,23 @@ let make_pa_rule i_typs (n,typs,symbols,_) ntn onlyprint = notgram_onlyprinting = onlyprint; } -let make_pp_rule (n,typs,symbols,fmt) = +let make_pp_rule level (typs,symbols) fmt = match fmt with - | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)] - | Some fmt -> hunks_of_format (n, List.split typs) (symbols, parse_format fmt) - -let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) extra onlyprint compat = - let pa_rule = make_pa_rule i_typs sy_data ntn onlyprint in - let pp_rule = make_pp_rule sy_data in + | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols level)] + | Some fmt -> hunks_of_format (level, List.split typs) (symbols, parse_format fmt) + +(* let make_syntax_rules i_typs (ntn,prec,need_squash) sy_data fmt extra onlyprint compat = *) +let make_syntax_rules (sd : SynData.syn_data) = let open SynData in + let ntn, prec, need_squash = sd.not_data in + let pa_rule = make_pa_rule sd.intern_typs sd.level sd.syntax_data ntn sd.only_printing in + let pp_rule = make_pp_rule sd.level sd.syntax_data sd.format in let sy = { - synext_level = prec; + synext_level = (sd.level, prec); synext_notation = ntn; - synext_notgram = pa_rule; + synext_notgram = pa_rule; synext_unparsing = pp_rule; - synext_extra = extra; - synext_compat = compat; + synext_extra = sd.extra; + synext_compat = sd.compat; } in (* By construction, the rule for "{ _ }" is declared, but we need to redeclare it because the file where it is declared needs not be open @@ -1178,39 +1271,39 @@ let to_map l = List.fold_left fold Id.Map.empty l let add_notation_in_scope local df c mods scope = - let (msgs,i_data,i_typs,sy_data,extra) = compute_syntax_data df mods in + let open SynData in + let sd = compute_syntax_data df mods in (* Prepare the interpretation *) - let (onlyparse, onlyprint, compat, recvars,mainvars, df') = i_data in (* Prepare the parsing and printing rules *) - let sy_rules = make_syntax_rules sy_data extra onlyprint compat in - let i_vars = make_internalization_vars recvars mainvars i_typs in + let sy_rules = make_syntax_rules sd in + let i_vars = make_internalization_vars sd.recvars sd.mainvars sd.intern_typs in let nenv = { ninterp_var_type = to_map i_vars; - ninterp_rec_vars = to_map recvars; + ninterp_rec_vars = to_map sd.recvars; } in let (acvars, ac, reversible) = interp_notation_constr nenv c in - let interp = make_interpretation_vars recvars acvars in + let interp = make_interpretation_vars sd.recvars acvars in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse = is_not_printable onlyparse (not reversible) ac in + let onlyparse = is_not_printable sd.only_parsing (not reversible) ac in let notation = { notobj_local = local; notobj_scope = scope; notobj_interp = (List.map_filter map i_vars, ac); (** Order is important here! *) notobj_onlyparse = onlyparse; - notobj_onlyprint = onlyprint; - notobj_compat = compat; - notobj_notation = df'; + notobj_onlyprint = sd.only_printing; + notobj_compat = sd.compat; + notobj_notation = sd.info; } in (* Ready to change the global state *) - Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs; + Flags.if_verbose (List.iter (fun (f,x) -> f x)) sd.msgs; Lib.add_anonymous_leaf (inSyntaxExtension (local, sy_rules)); Lib.add_anonymous_leaf (inNotation notation); - df' + sd.info let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat = let dfs = split_notation_string df in - let (recvars,mainvars,symbs) = analyze_notation_tokens dfs in + let recvars,mainvars,symbs = analyze_notation_tokens dfs in (* Recover types of variables and pa/pp rules; redeclare them if needed *) let i_typs, onlyprint = if not (is_numeral symbs) then begin let i_typs,sy_rules,onlyprint' = recover_notation_syntax (make_notation_key symbs) in @@ -1220,8 +1313,8 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env) i_typs, onlyprint end else [], false in (* Declare interpretation *) - let path = (Lib.library_dp(),Lib.current_dirpath true) in - let df' = (make_notation_key symbs,(path,df)) in + let path = (Lib.library_dp(), Lib.current_dirpath true) in + let df' = (make_notation_key symbs, (path,df)) in let i_vars = make_internalization_vars recvars mainvars i_typs in let nenv = { ninterp_var_type = to_map i_vars; @@ -1246,10 +1339,10 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env) (* Notations without interpretation (Reserved Notation) *) -let add_syntax_extension local ((loc,df),mods) = - let msgs, sy_data, extra, onlyprint = compute_pure_syntax_data df mods in - let sy_rules = make_syntax_rules sy_data extra onlyprint None in - Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs; +let add_syntax_extension local ((loc,df),mods) = let open SynData in + let psd = compute_pure_syntax_data df mods in + let sy_rules = make_syntax_rules {psd with compat = None} in + Flags.if_verbose (List.iter (fun (f,x) -> f x)) psd.msgs; Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)) (* Notations with only interpretation *) @@ -1378,4 +1471,3 @@ let add_syntactic_definition ident (vars,c) local onlyparse = | p -> p in Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) - diff --git a/toplevel/metasyntax.mli b/vernac/metasyntax.mli index 085cc87c8..57c120402 100644 --- a/toplevel/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -7,7 +7,6 @@ (************************************************************************) open Names -open Tacexpr open Vernacexpr open Notation open Constrexpr @@ -55,6 +54,10 @@ val add_syntactic_definition : Id.t -> Id.t list * constr_expr -> val pr_grammar : string -> Pp.std_ppcmds +type any_entry = AnyEntry : 'a Pcoq.Gram.entry -> any_entry + +val register_grammar : string -> any_entry list -> unit + val check_infix_modifiers : syntax_modifier list -> unit val with_syntax_protection : ('a -> 'b) -> 'a -> 'b diff --git a/toplevel/mltop.ml b/vernac/mltop.ml index b6690fe47..2396cf04a 100644 --- a/toplevel/mltop.ml +++ b/vernac/mltop.ml @@ -124,13 +124,13 @@ let ml_load s = | (UserError _ | Failure _ | Not_found as u) -> Exninfo.iraise (u, snd e) | exc -> let msg = report_on_load_obj_error exc in - errorlabstrm "Mltop.load_object" (str"Cannot link ml-object " ++ + user_err ~hdr:"Mltop.load_object" (str"Cannot link ml-object " ++ str s ++ str" to Coq code (" ++ msg ++ str ").")) | WithoutTop -> try Dynlink.loadfile s; s with Dynlink.Error a -> - errorlabstrm "Mltop.load_object" + user_err ~hdr:"Mltop.load_object" (strbrk "while loading " ++ str s ++ strbrk ": " ++ str (Dynlink.error_message a)) @@ -151,7 +151,7 @@ let dir_ml_use s = if Dynlink.is_native then " Loading ML code works only in bytecode." else "" in - errorlabstrm "Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo) + user_err ~hdr:"Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo) (* Adds a path to the ML paths *) let add_ml_dir s = @@ -226,7 +226,7 @@ let get_ml_object_suffix name = let file_of_name name = let suffix = get_ml_object_suffix name in let fail s = - errorlabstrm "Mltop.load_object" + user_err ~hdr:"Mltop.load_object" (str"File not found on loadpath : " ++ str s ++ str"\n" ++ str"Loadpath: " ++ str(String.concat ":" !coq_mlpath_copy)) in if not (Filename.is_relative name) then @@ -360,7 +360,7 @@ let trigger_ml_object verb cache reinit ?path name = add_loaded_module name (known_module_path name); if cache then perform_cache_obj name end else if not has_dynlink then - errorlabstrm "Mltop.trigger_ml_object" + user_err ~hdr:"Mltop.trigger_ml_object" (str "Dynamic link not supported (module " ++ str name ++ str ")") else begin let file = file_of_name (Option.default name path) in diff --git a/toplevel/mltop.mli b/vernac/mltop.mli index 6633cb937..6633cb937 100644 --- a/toplevel/mltop.mli +++ b/vernac/mltop.mli diff --git a/toplevel/obligations.ml b/vernac/obligations.ml index 29d745732..6f3921903 100644 --- a/toplevel/obligations.ml +++ b/vernac/obligations.ml @@ -20,9 +20,13 @@ open Pp open CErrors open Util +module NamedDecl = Context.Named.Declaration + let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false) let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false) +let get_fix_exn, stm_get_fix_exn = Hook.make () + let succfix (depth, fixrels) = (succ depth, List.map succ fixrels) @@ -34,7 +38,7 @@ let check_evars env evm = | Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_,_,false) -> () | _ -> - Pretype_errors.error_unsolvable_implicit loc env evm key None) + Pretype_errors.error_unsolvable_implicit ~loc env evm key None) (Evd.undefined_map evm) type oblinfo = @@ -51,7 +55,6 @@ type oblinfo = where n binders were passed through. *) let subst_evar_constr evs n idf t = - let open Context.Named.Declaration in let seen = ref Int.Set.empty in let transparent = ref Id.Set.empty in let evar_info id = List.assoc_f Evar.equal id evs in @@ -74,6 +77,7 @@ let subst_evar_constr evs n idf t = in let args = let rec aux hyps args acc = + let open Context.Named.Declaration in match hyps, args with (LocalAssum _ :: tlh), (c :: tla) -> aux tlh tla ((substrec (depth, fixrels) c) :: acc) @@ -116,9 +120,9 @@ let etype_of_evar evs hyps concl = let open Context.Named.Declaration in let rec aux acc n = function decl :: tl -> - let t', s, trans = subst_evar_constr evs n mkVar (get_type decl) in + let t', s, trans = subst_evar_constr evs n mkVar (NamedDecl.get_type decl) in let t'' = subst_vars acc 0 t' in - let rest, s', trans' = aux (get_id decl :: acc) (succ n) tl in + let rest, s', trans' = aux (NamedDecl.get_id decl :: acc) (succ n) tl in let s' = Int.Set.union s s' in let trans' = Id.Set.union trans trans' in (match decl with @@ -258,7 +262,7 @@ let safe_init_constant md name () = Coqlib.gen_constant "Obligations" md name let hide_obligation = safe_init_constant tactics_module "obligation" -let pperror cmd = CErrors.errorlabstrm "Program" cmd +let pperror cmd = CErrors.user_err ~hdr:"Program" cmd let error s = pperror (str s) let reduce c = @@ -394,11 +398,11 @@ let subst_deps expand obls deps t = (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t) let rec prod_app t n = - match kind_of_term (strip_outer_cast t) with + match kind_of_term (Termops.strip_outer_cast t) with | Prod (_,_,b) -> subst1 n b | LetIn (_, b, t, b') -> prod_app (subst1 b b') n | _ -> - errorlabstrm "prod_app" + user_err ~hdr:"prod_app" (str"Needed a product, but didn't find one" ++ fnl ()) @@ -444,7 +448,7 @@ let from_prg : program_info ProgMap.t ref = let close sec = if not (ProgMap.is_empty !from_prg) then let keys = map_keys !from_prg in - errorlabstrm "Program" + user_err ~hdr:"Program" (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++ prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++ (str (if Int.equal (List.length keys) 1 then " has " else " have ") ++ @@ -483,7 +487,7 @@ let declare_definition prg = let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None) (Evd.evar_universe_context_subst prg.prg_ctx) in let opaque = prg.prg_opaque in - let fix_exn = Stm.get_fix_exn () in + let fix_exn = Hook.get get_fix_exn () in let pl, ctx = Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) in let ce = @@ -564,7 +568,7 @@ let declare_mutual_definition l = in (* Declare the recursive definitions *) let ctx = Evd.evar_context_universe_context first.prg_ctx in - let fix_exn = Stm.get_fix_exn () in + let fix_exn = Hook.get get_fix_exn () in let kns = List.map4 (!declare_fix_ref ~opaque (local, poly, kind) ctx) fixnames fixdecls fixtypes fiximps in (* Declare notations *) @@ -598,7 +602,6 @@ let decompose_lam_prod c ty = in aux Context.Rel.empty c ty let shrink_body c ty = - let open Context.Rel.Declaration in let ctx, b, ty = match ty with | None -> @@ -613,6 +616,7 @@ let shrink_body c ty = if noccurn 1 b && Option.cata (noccurn 1) true ty then subst1 mkProp b, Option.map (subst1 mkProp) ty, succ i, args else + let open Context.Rel.Declaration in let args = if is_local_assum decl then mkRel i :: args else args in mkLambda_or_LetIn decl b, Option.map (mkProd_or_LetIn decl) ty, succ i, args) @@ -718,7 +722,7 @@ let get_prog name = let progs = Id.Set.elements (ProgMap.domain prg_infos) in let prog = List.hd progs in let progs = prlist_with_sep pr_comma Nameops.pr_id progs in - errorlabstrm "" + user_err (str "More than one program with unsolved obligations: " ++ progs ++ str "; use the \"of\" clause to specify, as in \"Obligation 1 of " ++ Nameops.pr_id prog ++ str "\"")) @@ -985,7 +989,7 @@ and solve_obligation_by_tac prg obls i tac = let (e, _) = CErrors.push e in match e with | Refiner.FailError (_, s) -> - user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s) + user_err ~loc:(fst obl.obl_location) ~hdr:"solve_obligation" (Lazy.force s) | e -> None (* FIXME really ? *) and solve_prg_obligations prg ?oblset tac = diff --git a/toplevel/obligations.mli b/vernac/obligations.mli index 69d206961..11366fe91 100644 --- a/toplevel/obligations.mli +++ b/vernac/obligations.mli @@ -24,6 +24,12 @@ val declare_definition_ref : Safe_typing.private_constants Entries.definition_entry -> Impargs.manual_implicits -> global_reference Lemmas.declaration_hook -> global_reference) ref +(* This is a hack to make it possible for Obligations to craft a Qed + * behind the scenes. The fix_exn the Stm attaches to the Future proof + * is not available here, so we provide a side channel to get it *) +val stm_get_fix_exn : (unit -> Exninfo.iexn -> Exninfo.iexn) Hook.t + + val check_evars : env -> evar_map -> unit val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t @@ -87,9 +93,9 @@ val add_mutual_definitions : fixpoint_kind -> unit val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> - Tacexpr.raw_tactic_expr option -> unit + Genarg.glob_generic_argument option -> unit -val next_obligation : Names.Id.t option -> Tacexpr.raw_tactic_expr option -> unit +val next_obligation : Names.Id.t option -> Genarg.glob_generic_argument option -> unit val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress (* Number of remaining obligations to be solved for this program *) diff --git a/toplevel/record.ml b/vernac/record.ml index 8d35e5a3d..b494430c2 100644 --- a/toplevel/record.ml +++ b/vernac/record.ml @@ -27,6 +27,8 @@ open Goptions open Sigma.Notations open Context.Rel.Declaration +module RelDecl = Context.Rel.Declaration + (********** definition d'un record (structure) **************) (** Flag governing use of primitive projections. Disabled by default. *) @@ -82,7 +84,7 @@ let compute_constructor_level evars env l = List.fold_right (fun d (env, univ) -> let univ = if is_local_assum d then - let s = Retyping.get_sort_of env evars (get_type d) in + let s = Retyping.get_sort_of env evars (RelDecl.get_type d) in Univ.sup (univ_of_sort s) univ else univ in (push_rel d env, univ)) @@ -102,14 +104,14 @@ let typecheck_params_and_fields def id pl t ps nots fs = let error bk (loc, name) = match bk, name with | Default _, Anonymous -> - user_err_loc (loc, "record", str "Record parameters must be named") + user_err ~loc ~hdr:"record" (str "Record parameters must be named") | _ -> () in List.iter (function LocalRawDef (b, _) -> error default_binder_kind b | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls | LocalPattern (loc,_,_) -> - Loc.raise loc (Stream.Error "pattern with quote not allowed in record parameters.")) ps + Loc.raise ~loc (Stream.Error "pattern with quote not allowed in record parameters.")) ps in let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in let t', template = match t with @@ -128,7 +130,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = sred, true | None -> s, false else s, false) - | _ -> user_err_loc (constr_loc t,"", str"Sort expected.")) + | _ -> user_err ~loc:(constr_loc t) (str"Sort expected.")) | None -> let uvarkind = Evd.univ_flexible_alg in mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), true @@ -168,7 +170,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = Evd.universe_context ?names:pl evars, nf arity, template, imps, newps, impls, newfs let degenerate_decl decl = - let id = match get_name decl with + let id = match RelDecl.get_name decl with | Name id -> id | Anonymous -> anomaly (Pp.str "Unnamed record variable") in match decl with @@ -209,7 +211,7 @@ let warning_or_error coe indsp err = | _ -> (pr_id fi ++ strbrk " cannot be defined because it is not typable.") in - if coe then errorlabstrm "structure" st; + if coe then user_err ~hdr:"structure" st; Flags.if_verbose Feedback.msg_info (hov 0 st) type field_status = @@ -236,7 +238,7 @@ let subst_projection fid l c = | Projection t -> lift depth t | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k | NoProjection Anonymous -> - errorlabstrm "" (str "Field " ++ pr_id fid ++ + user_err (str "Field " ++ pr_id fid ++ str " depends on the " ++ pr_nth (k-depth-1) ++ str " field which has no name.") else @@ -289,8 +291,8 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let (_,_,kinds,sp_projs,_) = List.fold_left3 (fun (nfi,i,kinds,sp_projs,subst) coe decl impls -> - let fi = get_name decl in - let ti = get_type decl in + let fi = RelDecl.get_name decl in + let ti = RelDecl.get_type decl in let (sp_projs,i,subst) = match fi with | Anonymous -> @@ -363,17 +365,17 @@ let structure_signature ctx = | [decl] -> let env = Environ.empty_named_context_val in let evm = Sigma.Unsafe.of_evar_map evm in - let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in + let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm (RelDecl.get_type decl) in let evm = Sigma.to_evar_map evm in evm | decl::tl -> let env = Environ.empty_named_context_val in let evm = Sigma.Unsafe.of_evar_map evm in - let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in + let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm (RelDecl.get_type decl) in let evm = Sigma.to_evar_map evm in let new_tl = Util.List.map_i (fun pos decl -> - map_type (fun t -> Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) decl) 1 tl in + RelDecl.map_type (fun t -> Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) decl) 1 tl in deps_to_evar evm new_tl in deps_to_evar Evd.empty (List.rev ctx) @@ -423,7 +425,7 @@ let implicits_of_context ctx = | Name n -> Some n | Anonymous -> None in ExplByPos (i, explname), (true, true, true)) - 1 (List.rev (Anonymous :: (List.map get_name ctx))) + 1 (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) let declare_class finite def poly ctx id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities sign = @@ -477,13 +479,13 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity if b then Backward, pri else Forward, pri) coe) coers priorities in - let l = List.map3 (fun decl b y -> get_name decl, b, y) + let l = List.map3 (fun decl b y -> RelDecl.get_name decl, b, y) (List.rev fields) coers (Recordops.lookup_projections ind) in IndRef ind, l in let ctx_context = List.map (fun decl -> - match Typeclasses.class_of_constr (get_type decl) with + match Typeclasses.class_of_constr (RelDecl.get_type decl) with | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true) | None -> None) params, params @@ -534,8 +536,8 @@ let declare_existing_class g = match g with | ConstRef x -> add_constant_class x | IndRef x -> add_inductive_class x - | _ -> user_err_loc (Loc.dummy_loc, "declare_existing_class", - Pp.str"Unsupported class type, only constants and inductives are allowed") + | _ -> user_err ~hdr:"declare_existing_class" + (Pp.str"Unsupported class type, only constants and inductives are allowed") open Vernacexpr @@ -553,7 +555,7 @@ let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,id let allnames = idstruc::(List.fold_left extract_name [] fs) in let () = match List.duplicates Id.equal allnames with | [] -> () - | id :: _ -> errorlabstrm "" (str "Two objects have the same name" ++ spc () ++ quote (Id.print id)) + | id :: _ -> user_err (str "Two objects have the same name" ++ spc () ++ quote (Id.print id)) in let isnot_class = match kind with Class false -> false | _ -> true in if isnot_class && List.exists (fun opt -> not (Option.is_empty opt)) priorities then diff --git a/toplevel/record.mli b/vernac/record.mli index c50e57786..c50e57786 100644 --- a/toplevel/record.mli +++ b/vernac/record.mli diff --git a/toplevel/search.ml b/vernac/search.ml index ff3c7a4f4..540573843 100644 --- a/toplevel/search.ml +++ b/vernac/search.ml @@ -20,6 +20,8 @@ open Globnames open Nametab open Goptions +module NamedDecl = Context.Named.Declaration + type filter_function = global_reference -> env -> constr -> bool type display_function = global_reference -> env -> constr -> unit @@ -57,8 +59,7 @@ let iter_constructors indsp u fn env nconstr = done let iter_named_context_name_type f = - let open Context.Named.Declaration in - List.iter (fun decl -> f (get_id decl) (get_type decl)) + List.iter (fun decl -> f (NamedDecl.get_id decl) (NamedDecl.get_type decl)) (* General search over hypothesis of a goal *) let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = @@ -70,13 +71,12 @@ let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = (* General search over declarations *) let iter_declarations (fn : global_reference -> env -> constr -> unit) = - let open Context.Named.Declaration in let env = Global.env () in let iter_obj (sp, kn) lobj = match object_tag lobj with | "VARIABLE" -> begin try let decl = Global.lookup_named (basename sp) in - fn (VarRef (get_id decl)) env (get_type decl) + fn (VarRef (NamedDecl.get_id decl)) env (NamedDecl.get_type decl) with Not_found -> (* we are in a section *) () end | "CONSTANT" -> let cst = Global.constant_of_delta_kn kn in @@ -107,12 +107,78 @@ let generic_search glnumopt fn = | Some glnum -> iter_hypothesis glnum fn); iter_declarations fn +(** This module defines a preference on constrs in the form of a + [compare] function (preferred constr must be big for this + functions, so preferences such as small constr must use a reversed + order). This priority will be used to order search results and + propose first results which are more likely to be relevant to the + query, this is why the type [t] contains the other elements + required of a search. *) +module ConstrPriority = struct + + (* The priority is memoised here. Because of the very localised use + of this module, it is not worth it making a convenient interface. *) + type t = + Globnames.global_reference * Environ.env * Constr.t * priority + and priority = int + + module ConstrSet = CSet.Make(Constr) + + (** A measure of the size of a term *) + let rec size t = + Constr.fold (fun s t -> 1 + s + size t) 0 t + + (** Set of the "symbols" (definitions, inductives, constructors) + which appear in a term. *) + let rec symbols acc t = + let open Constr in + match kind t with + | Const _ | Ind _ | Construct _ -> ConstrSet.add t acc + | _ -> Constr.fold symbols acc t + + (** The number of distinct "symbols" (see {!symbols}) which appear + in a term. *) + let num_symbols t = + ConstrSet.(cardinal (symbols empty t)) + + let priority t : priority = + -(3*(num_symbols t) + size t) + + let compare (_,_,_,p1) (_,_,_,p2) = + compare p1 p2 +end + +module PriorityQueue = Heap.Functional(ConstrPriority) + +let rec iter_priority_queue q fn = + (* use an option to make the function tail recursive. Will be + obsoleted with Ocaml 4.02 with the [match … with | exception …] + syntax. *) + let next = begin + try Some (PriorityQueue.maximum q) + with Heap.EmptyHeap -> None + end in + match next with + | Some (gref,env,t,_) -> + fn gref env t; + iter_priority_queue (PriorityQueue.remove q) fn + | None -> () + +let prioritize_search seq fn = + let acc = ref PriorityQueue.empty in + let iter gref env t = + let p = ConstrPriority.priority t in + acc := PriorityQueue.add (gref,env,t,p) !acc + in + let () = seq iter in + iter_priority_queue !acc fn + (** Filters *) (** This function tries to see whether the conclusion matches a pattern. *) (** FIXME: this is quite dummy, we may find a more efficient algorithm. *) let rec pattern_filter pat ref env typ = - let typ = strip_outer_cast typ in + let typ = Termops.strip_outer_cast typ in if Constr_matching.is_matching env Evd.empty pat typ then true else match kind_of_term typ with | Prod (_, _, typ) @@ -120,7 +186,7 @@ let rec pattern_filter pat ref env typ = | _ -> false let rec head_filter pat ref env typ = - let typ = strip_outer_cast typ in + let typ = Termops.strip_outer_cast typ in if Constr_matching.is_matching_head env Evd.empty pat typ then true else match kind_of_term typ with | Prod (_, _, typ) @@ -301,7 +367,7 @@ let interface_search = let answer = { coq_object_prefix = prefix; coq_object_qualid = qualid; - coq_object_object = string_of_ppcmds (pr_lconstr_env env Evd.empty constr); + coq_object_object = constr; } in ans := answer :: !ans; in diff --git a/toplevel/search.mli b/vernac/search.mli index ba3d48efc..82b79f75d 100644 --- a/toplevel/search.mli +++ b/vernac/search.mli @@ -67,10 +67,18 @@ type 'a coq_object = { } val interface_search : ?glnum:int -> (search_constraint * bool) list -> - string coq_object list + constr coq_object list (** {6 Generic search function} *) val generic_search : int option -> display_function -> unit (** This function iterates over all hypothesis of the goal numbered [glnum] (if present) and all known declarations. *) + +(** {6 Search function modifiers} *) + +val prioritize_search : (display_function -> unit) -> display_function -> unit +(** [prioritize_search iter] iterates over the values of [iter] (seen + as a sequence of declarations), in a relevance order. This requires to + perform the entire iteration of [iter] before starting streaming. So + [prioritize_search] should not be used for low-latency streaming. *) diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml new file mode 100644 index 000000000..f843484f7 --- /dev/null +++ b/vernac/topfmt.ml @@ -0,0 +1,289 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Feedback +open Pp + +(** Pp control also belongs here as the terminal is private to the toplevel *) + +type pp_global_params = { + margin : int; + max_indent : int; + max_depth : int; + ellipsis : string } + +(* Default parameters of pretty-printing *) + +let dflt_gp = { + margin = 78; + max_indent = 50; + max_depth = 50; + ellipsis = "..." } + +(* A deeper pretty-printer to print proof scripts *) + +let deep_gp = { + margin = 78; + max_indent = 50; + max_depth = 10000; + ellipsis = "..." } + +(* set_gp : Format.formatter -> pp_global_params -> unit + * set the parameters of a formatter *) + +let set_gp ft gp = + Format.pp_set_margin ft gp.margin ; + Format.pp_set_max_indent ft gp.max_indent ; + Format.pp_set_max_boxes ft gp.max_depth ; + Format.pp_set_ellipsis_text ft gp.ellipsis + +let set_dflt_gp ft = set_gp ft dflt_gp + +let get_gp ft = + { margin = Format.pp_get_margin ft (); + max_indent = Format.pp_get_max_indent ft (); + max_depth = Format.pp_get_max_boxes ft (); + ellipsis = Format.pp_get_ellipsis_text ft () } + +(* with_fp : 'a pp_formatter_params -> Format.formatter + * returns of formatter for given formatter functions *) + +let with_fp chan out_function flush_function = + let ft = Format.make_formatter out_function flush_function in + Format.pp_set_formatter_out_channel ft chan; + ft + +(* Output on a channel ch *) + +let with_output_to ch = + let ft = with_fp ch (output_substring ch) (fun () -> flush ch) in + set_gp ft deep_gp; + ft + +let std_ft = ref Format.std_formatter +let _ = set_dflt_gp !std_ft + +let err_ft = ref Format.err_formatter +let _ = set_gp !err_ft deep_gp + +let deep_ft = ref (with_output_to stdout) +let _ = set_gp !deep_ft deep_gp + +(* For parametrization through vernacular *) +let default = Format.pp_get_max_boxes !std_ft () +let default_margin = Format.pp_get_margin !std_ft () + +let get_depth_boxes () = Some (Format.pp_get_max_boxes !std_ft ()) +let set_depth_boxes v = + Format.pp_set_max_boxes !std_ft (match v with None -> default | Some v -> v) + +let get_margin () = Some (Format.pp_get_margin !std_ft ()) +let set_margin v = + let v = match v with None -> default_margin | Some v -> v in + Format.pp_set_margin Format.str_formatter v; + Format.pp_set_margin !std_ft v; + Format.pp_set_margin !deep_ft v; + (* Heuristic, based on usage: the column on the right of max_indent + column is 20% of width, capped to 30 characters *) + let m = max (64 * v / 100) (v-30) in + Format.pp_set_max_indent Format.str_formatter m; + Format.pp_set_max_indent !std_ft m; + Format.pp_set_max_indent !deep_ft m + +(** Console display of feedback *) + +(** Default tags *) +module Tag = struct + + let error = "message.error" + let warning = "message.warning" + let debug = "message.debug" + +end + +type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit + +let msgnl_with fmt strm = + pp_with fmt (strm ++ fnl ()); + Format.pp_print_flush fmt () + +(* XXX: This is really painful! *) +module Emacs = struct + + (* Special chars for emacs, to detect warnings inside goal output *) + let emacs_quote_start = String.make 1 (Char.chr 254) + let emacs_quote_end = String.make 1 (Char.chr 255) + + let emacs_quote_err g = + hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end) + + let emacs_quote_info_start = "<infomsg>" + let emacs_quote_info_end = "</infomsg>" + + let emacs_quote_info g = + hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end) + +end + +open Emacs + +let dbg_hdr = tag Tag.debug (str "Debug:") ++ spc () +let info_hdr = mt () +let warn_hdr = tag Tag.warning (str "Warning:") ++ spc () +let err_hdr = tag Tag.error (str "Error:") ++ spc () + +let make_body quoter info ?loc s = + let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in + quoter (hov 0 (loc ++ info ++ s)) + +(* Generic logger *) +let gen_logger dbg err ?loc level msg = match level with + | Debug -> msgnl_with !std_ft (make_body dbg dbg_hdr ?loc msg) + | Info -> msgnl_with !std_ft (make_body dbg info_hdr ?loc msg) + (* XXX: What to do with loc here? *) + | Notice -> msgnl_with !std_ft msg + | Warning -> Flags.if_warn (fun () -> + msgnl_with !err_ft (make_body err warn_hdr ?loc msg)) () + | Error -> msgnl_with !err_ft (make_body err err_hdr ?loc msg) + +(** Standard loggers *) + +(* We provide a generic clear_log_backend callback for backends + wanting to do clenaup after the print. +*) +let std_logger_cleanup = ref (fun () -> ()) + +let std_logger ?loc level msg = + gen_logger (fun x -> x) (fun x -> x) ?loc level msg; + !std_logger_cleanup () + +(** Color logging. Moved from Ppstyle, it may need some more refactoring *) + +(* Tag map for terminal style *) +let default_tag_map () = let open Terminal in [ + (* Local to console toplevel *) + "message.error" , make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () + ; "message.warning" , make ~bold:true ~fg_color:`WHITE ~bg_color:`YELLOW () + ; "message.debug" , make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () + (* Coming from the printer *) + ; "constr.evar" , make ~fg_color:`LIGHT_BLUE () + ; "constr.keyword" , make ~bold:true () + ; "constr.type" , make ~bold:true ~fg_color:`YELLOW () + ; "constr.notation" , make ~fg_color:`WHITE () + (* ["constr"; "variable"] is not assigned *) + ; "constr.reference" , make ~fg_color:`LIGHT_GREEN () + ; "constr.path" , make ~fg_color:`LIGHT_MAGENTA () + ; "module.definition", make ~bold:true ~fg_color:`LIGHT_RED () + ; "module.keyword" , make ~bold:true () + ; "tactic.keyword" , make ~bold:true () + ; "tactic.primitive" , make ~fg_color:`LIGHT_GREEN () + ; "tactic.string" , make ~fg_color:`LIGHT_RED () + ] + +let tag_map = ref CString.Map.empty + +let init_tag_map styles = + let set accu (name, st) = CString.Map.add name st accu in + tag_map := List.fold_left set !tag_map styles + +let clear_styles () = + tag_map := CString.Map.empty + +let parse_color_config file = + let styles = Terminal.parse file in + init_tag_map styles + +let dump_tags () = CString.Map.bindings !tag_map + +(** Not thread-safe. We should put a lock somewhere if we print from + different threads. Do we? *) +let make_style_stack () = + (** Default tag is to reset everything *) + let empty = Terminal.make () in + let default_tag = Terminal.({ + fg_color = Some `DEFAULT; + bg_color = Some `DEFAULT; + bold = Some false; + italic = Some false; + underline = Some false; + negative = Some false; + }) + in + let style_stack = ref [] in + let peek () = match !style_stack with + | [] -> default_tag (** Anomalous case, but for robustness *) + | st :: _ -> st + in + let push tag = + let style = + try CString.Map.find tag !tag_map + with | Not_found -> empty + in + (** Use the merging of the latest tag and the one being currently pushed. + This may be useful if for instance the latest tag changes the background and + the current one the foreground, so that the two effects are additioned. *) + let style = Terminal.merge (peek ()) style in + style_stack := style :: !style_stack; + Terminal.eval style + in + let pop _ = match !style_stack with + | [] -> (** Something went wrong, we fallback *) + Terminal.eval default_tag + | _ :: rem -> style_stack := rem; + Terminal.eval (peek ()) + in + let clear () = style_stack := [] in + push, pop, clear + +let init_color_output () = + init_tag_map (default_tag_map ()); + let push_tag, pop_tag, clear_tag = make_style_stack () in + std_logger_cleanup := clear_tag; + let tag_handler = { + Format.mark_open_tag = push_tag; + Format.mark_close_tag = pop_tag; + Format.print_open_tag = ignore; + Format.print_close_tag = ignore; + } in + Format.pp_set_mark_tags !std_ft true; + Format.pp_set_mark_tags !err_ft true; + Format.pp_set_formatter_tag_functions !std_ft tag_handler; + Format.pp_set_formatter_tag_functions !err_ft tag_handler + +(* Rules for emacs: + - Debug/info: emacs_quote_info + - Warning/Error: emacs_quote_err + - Notice: unquoted + *) +let emacs_logger = gen_logger emacs_quote_info emacs_quote_err + +(* Output to file, used only in extraction so a candidate for removal *) +let ft_logger old_logger ft ?loc level mesg = + let id x = x in + match level with + | Debug -> msgnl_with ft (make_body id dbg_hdr mesg) + | Info -> msgnl_with ft (make_body id info_hdr mesg) + | Notice -> msgnl_with ft mesg + | Warning -> old_logger ?loc level mesg + | Error -> old_logger ?loc level mesg + +let with_output_to_file fname func input = + (* XXX FIXME: redirect std_ft *) + (* let old_logger = !logger in *) + let channel = open_out (String.concat "." [fname; "out"]) in + (* logger := ft_logger old_logger (Format.formatter_of_out_channel channel); *) + try + let output = func input in + (* logger := old_logger; *) + close_out channel; + output + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + (* logger := old_logger; *) + close_out channel; + Exninfo.iraise reraise diff --git a/lib/pp_control.mli b/vernac/topfmt.mli index d26f89eb3..1555f80a9 100644 --- a/lib/pp_control.mli +++ b/vernac/topfmt.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Parameters of pretty-printing. *) +(** Console printing options *) type pp_global_params = { margin : int; @@ -20,13 +20,12 @@ val set_gp : Format.formatter -> pp_global_params -> unit val set_dflt_gp : Format.formatter -> unit val get_gp : Format.formatter -> pp_global_params - (** {6 Output functions of pretty-printing. } *) val with_output_to : out_channel -> Format.formatter -val std_ft : Format.formatter ref -val err_ft : Format.formatter ref +val std_ft : Format.formatter ref +val err_ft : Format.formatter ref val deep_ft : Format.formatter ref (** {6 For parametrization through vernacular. } *) @@ -36,3 +35,21 @@ val get_depth_boxes : unit -> int option val set_margin : int option -> unit val get_margin : unit -> int option + +(** Headers for tagging *) +val err_hdr : Pp.std_ppcmds + +(** Console display of feedback *) +val std_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit + +val emacs_logger : ?loc:Loc.t -> Feedback.level -> Pp.std_ppcmds -> unit + +val init_color_output : unit -> unit +val clear_styles : unit -> unit +val parse_color_config : string -> unit +val dump_tags : unit -> (string * Terminal.style) list + +(** [with_output_to_file file f x] executes [f x] with logging + redirected to a file [file] *) +val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b + diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib new file mode 100644 index 000000000..283c095eb --- /dev/null +++ b/vernac/vernac.mllib @@ -0,0 +1,18 @@ +Lemmas +Himsg +ExplainErr +Class +Locality +Metasyntax +Auto_ind_decl +Search +Indschemes +Obligations +Command +Classes +Record +Assumptions +Vernacinterp +Mltop +Topfmt +Vernacentries diff --git a/toplevel/vernacentries.ml b/vernac/vernacentries.ml index 6736d8329..32e18a014 100644 --- a/toplevel/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -33,12 +33,15 @@ open Misctypes open Locality open Sigma.Notations +module NamedDecl = Context.Named.Declaration + (** TODO: make this function independent of Ltac *) let (f_interp_redexp, interp_redexp_hook) = Hook.make () let debug = false -let prerr_endline x = - if debug then prerr_endline (x ()) else () +(* XXX Should move to a common library *) +let vernac_pperr_endline pp = + if debug then Format.eprintf "@[%a@]@\n%!" Pp.pp_with (pp ()) else () (* Misc *) @@ -105,7 +108,7 @@ let show_intro all = let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in if not (List.is_empty gls) then begin let gl = {Evd.it=List.hd gls ; sigma = sigma; } in - let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in + let l,_= decompose_prod_assum (Termops.strip_outer_cast (pf_concl gl)) in if all then let lid = Tactics.find_intro_names l gl in Feedback.msg_notice (hov 0 (prlist_with_sep spc pr_id lid)) @@ -163,7 +166,7 @@ let show_match id = let print_path_entry p = let dir = pr_dirpath (Loadpath.logical p) in let path = str (Loadpath.physical p) in - (dir ++ str " " ++ tbrk (0, 0) ++ path) + Pp.hov 2 (dir ++ spc () ++ path) let print_loadpath dir = let l = Loadpath.get_load_paths () in @@ -173,9 +176,8 @@ let print_loadpath dir = let filter p = is_dirpath_prefix_of dir (Loadpath.logical p) in List.filter filter l in - Pp.t (str "Logical Path: " ++ - tab () ++ str "Physical path:" ++ fnl () ++ - prlist_with_sep fnl print_path_entry l) + str "Logical Path / Physical path:" ++ fnl () ++ + prlist_with_sep fnl print_path_entry l let print_modules () = let opened = Library.opened_libraries () @@ -383,9 +385,9 @@ let err_unmapped_library loc ?from qid = | Some from -> str " and prefix " ++ pr_dirpath from ++ str "." in - user_err_loc - (loc,"locate_library", - strbrk "Cannot find a physical path bound to logical path matching suffix " ++ + user_err ~loc + ~hdr:"locate_library" + (strbrk "Cannot find a physical path bound to logical path matching suffix " ++ pr_dirpath dir ++ prefix) let err_notfound_library loc ?from qid = @@ -394,9 +396,8 @@ let err_notfound_library loc ?from qid = | Some from -> str " with prefix " ++ pr_dirpath from ++ str "." in - user_err_loc - (loc,"locate_library", - strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) + user_err ~loc ~hdr:"locate_library" + (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) let print_located_library r = let (loc,qid) = qualid_of_reference r in @@ -407,13 +408,13 @@ let print_located_library r = let smart_global r = let gr = Smartlocate.smart_global r in - Dumpglob.add_glob (Constrarg.loc_of_or_by_notation loc_of_reference r) gr; + Dumpglob.add_glob (Stdarg.loc_of_or_by_notation loc_of_reference r) gr; gr let dump_global r = try let gr = Smartlocate.smart_global r in - Dumpglob.add_glob (Constrarg.loc_of_or_by_notation loc_of_reference r) gr + Dumpglob.add_glob (Stdarg.loc_of_or_by_notation loc_of_reference r) gr with e when CErrors.noncritical e -> () (**********) (* Syntax *) @@ -507,21 +508,15 @@ let vernac_start_proof locality p kind l lettop = | None -> ()) l; if not(refining ()) then if lettop then - errorlabstrm "Vernacentries.StartProof" + user_err ~hdr:"Vernacentries.StartProof" (str "Let declarations can only be used in proof editing mode."); start_proof_and_print (local, p, Proof kind) l no_hook let qed_display_script = ref true let vernac_end_proof ?proof = function - | Admitted -> save_proof ?proof Admitted - | Proved (_,_) as e -> - if is_verbose () && !qed_display_script && !Flags.coqtop_ui then - Stm.show_script ?proof (); - save_proof ?proof e - - (* A stupid macro that should be replaced by ``Exact c. Save.'' all along - the theories [??] *) + | Admitted -> save_proof ?proof Admitted + | Proved (_,_) as e -> save_proof ?proof e let vernac_exact_proof c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is @@ -628,15 +623,15 @@ let vernac_combined_scheme lid l = let vernac_universe loc poly l = if poly && not (Lib.sections_are_opened ()) then - user_err_loc (loc, "vernac_universe", - str"Polymorphic universes can only be declared inside sections, " ++ + user_err ~loc ~hdr:"vernac_universe" + (str"Polymorphic universes can only be declared inside sections, " ++ str "use Monomorphic Universe instead"); do_universe poly l let vernac_constraint loc poly l = if poly && not (Lib.sections_are_opened ()) then - user_err_loc (loc, "vernac_constraint", - str"Polymorphic universe constraints can only be declared" + user_err ~loc ~hdr:"vernac_constraint" + (str"Polymorphic universe constraints can only be declared" ++ str " inside sections, use Monomorphic Constraint instead"); do_constraint poly l @@ -863,23 +858,23 @@ let focus_command_cond = Proof.no_cond command_focus let vernac_solve_existential = instantiate_nth_evar_com let vernac_set_end_tac tac = + let open Genintern in + let env = { genv = Global.env (); ltacvars = Id.Set.empty } in + let _, tac = Genintern.generic_intern env tac in if not (refining ()) then error "Unknown command of the non proof-editing mode."; - match tac with - | Tacexpr.TacId [] -> () - | _ -> set_end_tac tac + set_end_tac tac (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) let vernac_set_used_variables e = - let open Context.Named.Declaration in let env = Global.env () in let tys = List.map snd (Proof.initial_goals (Proof_global.give_me_the_proof ())) in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in List.iter (fun id -> - if not (List.exists (Id.equal id % get_id) vars) then - errorlabstrm "vernac_set_used_variables" + if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then + user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ pr_id id)) l; let _, to_clear = set_used_variables l in @@ -1021,12 +1016,12 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags (* Checks *) let err_extra_args names = - errorlabstrm "vernac_declare_arguments" + user_err ~hdr:"vernac_declare_arguments" (strbrk "Extra arguments: " ++ prlist_with_sep pr_comma pr_name names ++ str ".") in let err_missing_args names = - errorlabstrm "vernac_declare_arguments" + user_err ~hdr:"vernac_declare_arguments" (strbrk "The following arguments are not declared: " ++ prlist_with_sep pr_comma pr_name names ++ str ".") in @@ -1107,7 +1102,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags let renaming_specified = Option.has_some !example_renaming in if !rename_flag_required && not rename_flag then - errorlabstrm "vernac_declare_arguments" + user_err ~hdr:"vernac_declare_arguments" (strbrk "To rename arguments the \"rename\" flag must be specified." ++ spc () ++ match !example_renaming with @@ -1121,7 +1116,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags in if not (List.is_empty duplicate_names) then begin let duplicates = prlist_with_sep pr_comma pr_name duplicate_names in - errorlabstrm "_" (strbrk "Some argument names are duplicated: " ++ duplicates) + user_err (strbrk "Some argument names are duplicated: " ++ duplicates) end; (* Parts of this code are overly complicated because the implicit arguments @@ -1148,7 +1143,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags (* With the current impargs API, it is impossible to make an originally anonymous argument implicit *) | Anonymous :: _, (name, _) :: _ -> - errorlabstrm "vernac_declare_arguments" + user_err ~hdr:"vernac_declare_arguments" (strbrk"Argument "++ pr_name name ++ strbrk " cannot be declared implicit.") @@ -1215,7 +1210,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags Reductionops.ReductionBehaviour.set (make_section_locality locality) c (rargs, Option.default ~-1 nargs_for_red, red_flags) - | _ -> errorlabstrm "" + | _ -> user_err (strbrk "Modifiers of the behavior of the simpl tactic "++ strbrk "are relevant for constants only.") end; @@ -1454,8 +1449,8 @@ let _ = optdepr = false; optname = "the printing depth"; optkey = ["Printing";"Depth"]; - optread = Pp_control.get_depth_boxes; - optwrite = Pp_control.set_depth_boxes } + optread = Topfmt.get_depth_boxes; + optwrite = Topfmt.set_depth_boxes } let _ = declare_int_option @@ -1463,8 +1458,8 @@ let _ = optdepr = false; optname = "the printing width"; optkey = ["Printing";"Width"]; - optread = Pp_control.get_margin; - optwrite = Pp_control.set_margin } + optread = Topfmt.get_margin; + optwrite = Topfmt.set_margin } let _ = declare_bool_option @@ -1639,7 +1634,7 @@ let print_about_hyp_globs ref_or_by_not glnumopt = | Some n,AN (Ident (_loc,id)) -> (* goal number given, catch if wong *) (try get_nth_goal n,id with - Failure _ -> errorlabstrm "print_about_hyp_globs" + Failure _ -> user_err ~hdr:"print_about_hyp_globs" (str "No such goal: " ++ int n ++ str ".")) | _ , _ -> raise NoHyp in let hyps = pf_hyps gl in @@ -1647,7 +1642,7 @@ let print_about_hyp_globs ref_or_by_not glnumopt = let natureofid = match decl with | LocalAssum _ -> "Hypothesis" | LocalDef (_,bdy,_) ->"Constant (let in)" in - v 0 (pr_id id ++ str":" ++ pr_constr (get_type decl) ++ fnl() ++ fnl() + v 0 (pr_id id ++ str":" ++ pr_constr (NamedDecl.get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) | NoHyp | Not_found -> print_about ref_or_by_not @@ -1715,8 +1710,8 @@ let global_module r = let (loc,qid) = qualid_of_reference r in try Nametab.full_name_module qid with Not_found -> - user_err_loc (loc, "global_module", - str "Module/section " ++ pr_qualid qid ++ str " not found.") + user_err ~loc ~hdr:"global_module" + (str "Module/section " ++ pr_qualid qid ++ str " not found.") let interp_search_restriction = function | SearchOutside l -> (List.map global_module l, true) @@ -1738,7 +1733,7 @@ let interp_search_about_item env = (fun _ -> true) s sc in GlobSearchSubPattern (Pattern.PRef ref) with UserError _ -> - errorlabstrm "interp_search_about_item" + user_err ~hdr:"interp_search_about_item" (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component") (* 05f22a5d6d5b8e3e80f1a37321708ce401834430 introduced the @@ -1786,13 +1781,13 @@ let vernac_search s gopt r = in match s with | SearchPattern c -> - Search.search_pattern gopt (get_pattern c) r pr_search + (Search.search_pattern gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchRewrite c -> - Search.search_rewrite gopt (get_pattern c) r pr_search + (Search.search_rewrite gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchHead c -> - Search.search_by_head gopt (get_pattern c) r pr_search + (Search.search_by_head gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchAbout sl -> - Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r pr_search + (Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r |> Search.prioritize_search) pr_search let vernac_locate = let open Feedback in function | LocateAny (AN qid) -> msg_notice (print_located_qualid qid) @@ -1867,6 +1862,7 @@ let vernac_bullet (bullet:Proof_global.Bullet.t) = Proof_global.Bullet.put p bullet) let vernac_show = let open Feedback in function + | ShowScript -> assert false (* Only the stm knows the script *) | ShowGoal goalref -> let info = match goalref with | OpenSubgoals -> pr_open_subgoals () @@ -1881,7 +1877,6 @@ let vernac_show = let open Feedback in function Constrextern.with_implicits msg_notice (pr_nth_open_subgoal n) | ShowProof -> show_proof () | ShowNode -> show_node () - | ShowScript -> Stm.show_script () | ShowExistentials -> show_top_evars () | ShowUniverses -> show_universes () | ShowTree -> show_prooftree () @@ -1908,6 +1903,12 @@ let vernac_check_guard () = exception End_of_input +(* XXX: This won't properly set the proof mode, as of today, it is + controlled by the STM. Thus, we would need access information from + the classifier. The proper fix is to move it to the STM, however, + the way the proof mode is set there makes the task non trivial + without a considerable amount of refactoring. + *) let vernac_load interp fname = let interp x = let proof_mode = Proof_global.get_default_proof_mode_name () in @@ -1933,18 +1934,47 @@ let vernac_load interp fname = * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) let interp ?proof ~loc locality poly c = - prerr_endline (fun () -> "interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c)); + vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac c); match c with - (* Done later in this file *) + (* The below vernac are candidates for removal from the main type + and to be put into a new doc_command datatype: *) + | VernacLoad _ -> assert false + + (* Done later in this file *) | VernacFail _ -> assert false | VernacTime _ -> assert false | VernacRedirect _ -> assert false | VernacTimeout _ -> assert false | VernacStm _ -> assert false + (* The STM should handle that, but LOAD bypasses the STM... *) + | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") + | VernacRestart -> CErrors.user_err (str "Restart cannot be used through the Load command") + | VernacUndo _ -> CErrors.user_err (str "Undo cannot be used through the Load command") + | VernacUndoTo _ -> CErrors.user_err (str "UndoTo cannot be used through the Load command") + | VernacBacktrack _ -> CErrors.user_err (str "Backtrack cannot be used through the Load command") + + (* Toplevel control *) + | VernacToplevelControl e -> raise e + + (* Resetting *) + | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm") + | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm") + | VernacBack _ -> anomaly (str "VernacBack not handled by Stm") + | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm") + + (* Horrible Hack that should die. *) | VernacError e -> raise e + (* This one is possible to handle here *) + | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") + + (* Handled elsewhere *) + | VernacProgram _ + | VernacPolymorphic _ + | VernacLocal _ -> assert false + (* Syntax *) | VernacSyntaxExtension (local,sl) -> vernac_syntax_extension locality local sl @@ -2016,12 +2046,6 @@ let interp ?proof ~loc locality poly c = | VernacWriteState s -> vernac_write_state s | VernacRestoreState s -> vernac_restore_state s - (* Resetting *) - | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm") - | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm") - | VernacBack _ -> anomaly (str "VernacBack not handled by Stm") - | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm") - (* Commands *) | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids @@ -2053,14 +2077,6 @@ let interp ?proof ~loc locality poly c = | VernacRegister (id, r) -> vernac_register id r | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n") - (* The STM should handle that, but LOAD bypasses the STM... *) - | VernacAbort id -> CErrors.errorlabstrm "" (str "Abort cannot be used through the Load command") - | VernacAbortAll -> CErrors.errorlabstrm "" (str "AbortAll cannot be used through the Load command") - | VernacRestart -> CErrors.errorlabstrm "" (str "Restart cannot be used through the Load command") - | VernacUndo _ -> CErrors.errorlabstrm "" (str "Undo cannot be used through the Load command") - | VernacUndoTo _ -> CErrors.errorlabstrm "" (str "UndoTo cannot be used through the Load command") - | VernacBacktrack _ -> CErrors.errorlabstrm "" (str "Backtrack cannot be used through the Load command") - (* Proof management *) | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false | VernacFocus n -> vernac_focus n @@ -2083,17 +2099,10 @@ let interp ?proof ~loc locality poly c = Aux_file.record_in_aux_at loc "VernacProof" "tac:yes using:yes"; vernac_set_end_tac tac; vernac_set_used_variables l | VernacProofMode mn -> Proof_global.set_proof_mode mn - (* Toplevel control *) - | VernacToplevelControl e -> raise e (* Extensions *) | VernacExtend (opn,args) -> Vernacinterp.call ?locality (opn,args) - (* Handled elsewhere *) - | VernacProgram _ - | VernacPolymorphic _ - | VernacLocal _ -> assert false - (* Vernaculars that take a locality flag *) let check_vernac_supports_locality c l = match l, c with @@ -2185,13 +2194,13 @@ let with_fail b f = | e -> let e = CErrors.push e in raise (HasFailed (CErrors.iprint - (ExplainErr.process_vernac_interp_error ~allow_uncaught:false ~with_header:false e)))) + (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e)))) () with e when CErrors.noncritical e -> let (e, _) = CErrors.push e in match e with | HasNotFailed -> - errorlabstrm "Fail" (str "The command has not failed!") + user_err ~hdr:"Fail" (str "The command has not failed!") | HasFailed msg -> if is_verbose () || !test_mode || !ide_slave then Feedback.msg_info (str "The command has indeed failed with message:" ++ fnl () ++ msg) @@ -2218,7 +2227,7 @@ let interp ?(verbosely=true) ?proof (loc,c) = current_timeout := Some n; aux ?locality ?polymorphism isprogcmd v | VernacRedirect (s, (_,v)) -> - Feedback.with_output_to_file s (aux false) v + Topfmt.with_output_to_file s (aux false) v | VernacTime (_,v) -> System.with_time !Flags.time (aux ?locality ?polymorphism isprogcmd) v; @@ -2252,6 +2261,3 @@ let interp ?(verbosely=true) ?proof (loc,c) = in if verbosely then Flags.verbosely (aux false) c else aux false c - -let () = Hook.set Stm.interp_hook interp -let () = Hook.set Stm.with_fail_hook with_fail diff --git a/toplevel/vernacentries.mli b/vernac/vernacentries.mli index 4e7fa4a08..7cdc8dd06 100644 --- a/toplevel/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -62,5 +62,5 @@ val with_fail : bool -> (unit -> unit) -> unit val command_focus : unit Proof.focus_kind -val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Tacexpr.raw_red_expr -> +val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t diff --git a/toplevel/vernacinterp.ml b/vernac/vernacinterp.ml index d81e3d6b5..f26ef460d 100644 --- a/toplevel/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -22,7 +22,7 @@ let vinterp_add depr s f = try Hashtbl.add vernac_tab s (depr, f) with Failure _ -> - errorlabstrm "vinterp_add" + user_err ~hdr:"vinterp_add" (str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.") let overwriting_vinterp_add s f = @@ -37,7 +37,7 @@ let vinterp_map s = try Hashtbl.find vernac_tab s with Failure _ | Not_found -> - errorlabstrm "Vernac Interpreter" + user_err ~hdr:"Vernac Interpreter" (str"Cannot find vernac command " ++ str (fst s) ++ str".") let vinterp_init () = Hashtbl.clear vernac_tab diff --git a/toplevel/vernacinterp.mli b/vernac/vernacinterp.mli index 5149b5416..5149b5416 100644 --- a/toplevel/vernacinterp.mli +++ b/vernac/vernacinterp.mli |